From 4177789109631fcbc1c1d5275f30cca06e1f2728 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 13 Jan 2018 12:17:25 -0800 Subject: [PATCH 001/405] BLD: update .travis.yml for python 2.7, 3.4, 3.5, 3.6 --- .travis.yml | 20 +++++++++++++------- conda-recipe/meta.yaml | 2 +- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index c3f24114..ca5d1e18 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,12 +3,18 @@ language: python python: - "2.7" - - "3.3" - - "3.4" +# - "3.4" - "3.5" +# - "3.6" +env: + before_install: - - sudo apt-get install gfortran + # Install gfortran for testing slycot; use apt-get instead of conda in + # order to include the proper CXXABI dependency (updated in GCC 4.9) + # Also need to include liblapack here, to make sure paths are right + - sudo apt-get install gfortran liblapack-dev + # use miniconda to install numpy - if [[ "$TRAVIS_PYTHON_VERSION" == "2.7" ]]; then wget http://repo.continuum.io/miniconda/Miniconda-latest-Linux-x86_64.sh -O miniconda.sh; else @@ -19,17 +25,17 @@ before_install: - hash -r - conda config --set always_yes yes --set changeps1 no - conda update -q conda - - conda install conda-build - - conda config --add channels http://conda.binstar.org/python-control - conda info -a - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose - source activate test-environment + # Make sure to look in the right place for python libraries + - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib" # coveralls not in conda repos :-( - pip install coveralls install: - - conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe - - conda install slycot --use-local + - conda install numpy + - python setup.py install # TODO: replace with nose? script: diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 9644848a..72cd1497 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -8,7 +8,7 @@ build: requirements: build: - python - - numpy >=1.13.3 + - numpy - lapack - m2w64-gcc-fortran # [win] From 72067499787dd5188ed1a59d7018e104ca046092 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 13 Jan 2018 16:13:51 -0800 Subject: [PATCH 002/405] BLD: add test against python-control --- .travis.yml | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index ca5d1e18..1101f0e1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,12 +3,9 @@ language: python python: - "2.7" -# - "3.4" - "3.5" -# - "3.6" + - "3.6" -env: - before_install: # Install gfortran for testing slycot; use apt-get instead of conda in # order to include the proper CXXABI dependency (updated in GCC 4.9) @@ -37,9 +34,21 @@ install: - conda install numpy - python setup.py install -# TODO: replace with nose? script: + # Local unit tests + # TODO: replace with nose? - python runtests.py --coverage + # + # As a deeper set of tests, get test against python-control as well + # + # Additional packages required for python-control + - conda install scipy matplotlib + # Install display manager to allow testing of plotting functions + - export DISPLAY=:99.0 + - sh -e /etc/init.d/xvfb start + # Get python-control from source and install + - git clone https://github.com/python-control/python-control.git control + - cd control; python setup.py test after_success: - coveralls From deef96588a2aed611e2f2101de5cd6414e3e926e Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 13 Jan 2018 16:47:36 -0800 Subject: [PATCH 003/405] BLD: Travis CI build w/ and w/out conda --- .travis.yml | 49 +++++++++++++++++++++++++++++------------- conda-recipe/meta.yaml | 4 ++-- 2 files changed, 36 insertions(+), 17 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1101f0e1..7190bccc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,4 @@ -# cargo-culted from python-control's .travis.yml +# Travis configuration file for slycot language: python python: @@ -6,12 +6,24 @@ python: - "3.5" - "3.6" +env: + - TEST_CONDA=0 + - TEST_CONDA=1 + before_install: - # Install gfortran for testing slycot; use apt-get instead of conda in - # order to include the proper CXXABI dependency (updated in GCC 4.9) - # Also need to include liblapack here, to make sure paths are right - - sudo apt-get install gfortran liblapack-dev - # use miniconda to install numpy + # + # If not using conda, then install gfortran. Also need to include + # liblapack here and set up library paths + # + - if [[ $TEST_CONDA == 0 ]]; then + sudo apt-get install gfortran liblapack-dev; + fi + +install: + # + # Install miniconda to allow quicker installation of dependencies + # See https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html + # - if [[ "$TRAVIS_PYTHON_VERSION" == "2.7" ]]; then wget http://repo.continuum.io/miniconda/Miniconda-latest-Linux-x86_64.sh -O miniconda.sh; else @@ -22,23 +34,30 @@ before_install: - hash -r - conda config --set always_yes yes --set changeps1 no - conda update -q conda + - if [[ $TEST_CONDA == 1 ]]; then conda install conda-build; fi - conda info -a - - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose - - source activate test-environment - # Make sure to look in the right place for python libraries - - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib" + # # coveralls not in conda repos :-( - pip install coveralls - -install: - - conda install numpy - - python setup.py install + # + # Set up a test environment for testing everything out + - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy + - source activate test-environment + # + # Install the slycot package (two ways, to improve robustness) + - if [[ $TEST_CONDA == 1 ]]; then + conda build conda-recipe; + conda install slycot --use-local; + else + export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; + python setup.py install; + fi script: # Local unit tests # TODO: replace with nose? - python runtests.py --coverage - # + # # As a deeper set of tests, get test against python-control as well # # Additional packages required for python-control diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 72cd1497..62dc0665 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -9,13 +9,13 @@ requirements: build: - python - numpy - - lapack + - openblas - m2w64-gcc-fortran # [win] run: - python - numpy - - lapack + - openblas test: imports: From 891ab0a131b74440c62536251ad80bc00cceb6f7 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 13 Jan 2018 18:56:02 -0800 Subject: [PATCH 004/405] BLD: require fortran compiler for conda --- conda-recipe/meta.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 62dc0665..280e2d10 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -11,6 +11,8 @@ requirements: - numpy - openblas - m2w64-gcc-fortran # [win] + - gfortran_linux-64 # [linux] + - gfortran_osx-64 # [osx] run: - python From 2f8cc4df1eddb3e5e83215474a0b8de402068090 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 13 Jan 2018 19:09:38 -0800 Subject: [PATCH 005/405] BLD: require fortran compiler for conda --- conda-recipe/meta.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 280e2d10..6e71824c 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -18,6 +18,8 @@ requirements: - python - numpy - openblas + - gfortran_linux-64 # [linux] + - libgfortran test: imports: From a657287eb7cd57a17d50250095e88829b3140b44 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sun, 14 Jan 2018 08:03:04 -0800 Subject: [PATCH 006/405] BLD: fixes for conda and fortran --- .travis.yml | 22 ++++++++++++++-------- conda-recipe/meta.yaml | 7 +++---- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/.travis.yml b/.travis.yml index 7190bccc..4b4e55e2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,13 +11,12 @@ env: - TEST_CONDA=1 before_install: + - sudo apt-get install gfortran # - # If not using conda, then install gfortran. Also need to include - # liblapack here and set up library paths + # If not using conda, then install liblapack here (conda version + # will handle this through the build recipe) # - - if [[ $TEST_CONDA == 0 ]]; then - sudo apt-get install gfortran liblapack-dev; - fi + - if [[ $TEST_CONDA == 0 ]]; then sudo apt-get install liblapack-dev; fi install: # @@ -44,12 +43,19 @@ install: - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy - source activate test-environment # - # Install the slycot package (two ways, to improve robustness) + # Make sure that fortran compiler can find conda libraries + # + - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; + # + # Install the slycot package (two ways, to improve robustness). For the + # conda version, need to install lapack from conda-forge (no way to specify + # this in the recipe). + # - if [[ $TEST_CONDA == 1 ]]; then - conda build conda-recipe; + conda install -c conda-forge lapack; + conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe; conda install slycot --use-local; else - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; python setup.py install; fi diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 6e71824c..81a7d5f1 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -9,7 +9,7 @@ requirements: build: - python - numpy - - openblas + - lapack - m2w64-gcc-fortran # [win] - gfortran_linux-64 # [linux] - gfortran_osx-64 # [osx] @@ -17,8 +17,7 @@ requirements: run: - python - numpy - - openblas - - gfortran_linux-64 # [linux] + - lapack - libgfortran test: @@ -26,6 +25,6 @@ test: - slycot about: - home: https://github.com/python-control/Slycot + home: https://github.com/python-control/slycot license: GPLv2 summary: 'A wrapper for the SLICOT control and systems library' From 150e1a468aa2cb8134055a2dbc8b6b7c9f0e195c Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sun, 14 Jan 2018 16:44:34 -0800 Subject: [PATCH 007/405] TRV: small cleanups before sending pull request --- .travis.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4b4e55e2..a5de4c6b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,6 +11,9 @@ env: - TEST_CONDA=1 before_install: + # + # Install fortran compiler + # - sudo apt-get install gfortran # # If not using conda, then install liblapack here (conda version @@ -36,9 +39,6 @@ install: - if [[ $TEST_CONDA == 1 ]]; then conda install conda-build; fi - conda info -a # - # coveralls not in conda repos :-( - - pip install coveralls - # # Set up a test environment for testing everything out - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy - source activate test-environment @@ -58,6 +58,9 @@ install: else python setup.py install; fi + # + # coveralls not in conda repos :-( + - pip install coveralls script: # Local unit tests From b0d2bc4504995ace642c936621d41b09f76b8df6 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sun, 14 Jan 2018 17:22:37 -0800 Subject: [PATCH 008/405] DOC: added some additional installation documentation --- README.rst | 46 +++++++++++++++++++++++++++++++--------------- 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/README.rst b/README.rst index 75c583b2..3e8824b4 100644 --- a/README.rst +++ b/README.rst @@ -1,25 +1,27 @@ Slycot ============= -.. image:: https://travis-ci.org/python-control/Slycot.svg?branch=master - :target: https://travis-ci.org/python-control/Slycot -.. image:: https://coveralls.io/repos/python-control/Slycot/badge.png - :target: https://coveralls.io/r/python-control/Slycot +.. image:: https://travis-ci.org/python-control/slycot.svg?branch=master + :target: https://travis-ci.org/python-control/slycot +.. image:: https://coveralls.io/repos/python-control/slycot/badge.png + :target: https://coveralls.io/r/python-control/slycot Python wrapper for selected SLICOT routines, notably including solvers for -Riccati, Lyapunov and Sylvester equations. +Riccati, Lyapunov, and Sylvester equations. -Prerequisite: -------------- +Prerequisites: +-------------- -Slycot depends on Numpy, and if you are installing a binary distribution, Numpy -is the only prerequisite. +Slycot depends on Numpy and, if you are installing a binary distribution, +Numpy should be the only prerequisite (though you may need the LAPACK +libraries as well, depending on your particular system configuration). -If you are installing Slycot from source, you will need a fortran -compiler such as gfortran, and BLAS/LAPACK libraries. +If you are installing Slycot from source, you will need a FORTRAN +compiler, such as gfortran, and BLAS/LAPACK libraries. -On Debian derivates you can install all the above with a single command:: +On Debian derivatives you should be able to install all the above with a +single command:: sudo apt-get build-dep python-scipy @@ -29,7 +31,7 @@ On Mac, you will first need to install the `developer tools brew install gcc -On Windows, I suggest installing on top of the Python(x,y) distribution, and +On Windows, we suggest installing on top of the Python(x,y) distribution, and grabbing BLAS and LAPACK libraries from: http://icl.cs.utk.edu/lapack-for-windows/libraries/VisualStudio/3.4.1/Dynamic-MINGW/Win32/ @@ -64,10 +66,10 @@ Using conda If you use `Anaconda or conda `_ on Linux or Mac, it should be straighforward to install Slycot, without needing any compilers or other prerequisites. Slycot is not included in the standard conda package -repository, but there are packages available on http://binstar.org for Linux and +repository, but there are packages available on conda-forge for Linux and Mac. You can install with the following command:: - conda install -c http://conda.binstar.org/cwrowley slycot + conda install -c conda-forge slycot From Source @@ -96,6 +98,20 @@ with as contents:: [build] compiler=mingw32 +Additional tips for how to install slycot from source can be found in the +.travis.yml (commands used for Travis CI) and conda-recipe/ (conda +pre-requisities). The hardest part about installing from source is getting +a working version of FORTRAN and LAPACK installed on your system and working +properly with Python. If you are using conda, you can also get working +(binary) copies of LAPACK from conda-forge using the command:: + + conda install -c conda-forge lapack + +Note that in some cases you may need to set the LIBRARY_PATH environment +variable to pick up dependencies such as -lpythonN.m (where N.m is the +version of python you are using). + + To-Do ------ From 05f3ba1c4a6866231764c86b9df76689e5bff631 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Thu, 28 Jun 2018 22:32:29 +0200 Subject: [PATCH 009/405] Fixes to the build and test of Slycot * conda recipes, meta.yaml, and batch files - in meta.yaml, ensure test is under same python version as build - keep the openblas conda recipe in separate folder - re-worked windows build to use Flang fortran and vc14 linkage - use conda's compiler('fortran') for linux and mac osx * travis configuration - force installation of slycot from the local channel, avoid using a conda-forge version in the case of previous build failure - use lapack libs for conda and non-conda builds - add conda-forge channel to the conda config, to find lapack * slycot/setup.py - fix for compile on Darwin/Linux, - add library path based on python location, for conda builds - adjust linker options for Linux (specifically ubuntu) - read the environment variable LAPACKLIBS to override the used Lapack libraries --- .travis.yml | 74 +++++++++++++++++++++++++++------ conda-recipe-openblas/bld.bat | 17 ++++++++ conda-recipe-openblas/build.sh | 2 + conda-recipe-openblas/meta.yaml | 37 +++++++++++++++++ conda-recipe/bld.bat | 7 +++- conda-recipe/build.sh | 3 +- conda-recipe/meta.yaml | 23 +++++++--- slycot/setup.py | 36 ++++++++++------ 8 files changed, 165 insertions(+), 34 deletions(-) create mode 100644 conda-recipe-openblas/bld.bat create mode 100644 conda-recipe-openblas/build.sh create mode 100644 conda-recipe-openblas/meta.yaml diff --git a/.travis.yml b/.travis.yml index c3f24114..6245d568 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,14 +1,34 @@ -# cargo-culted from python-control's .travis.yml +# Travis configuration file for slycot language: python python: - "2.7" - - "3.3" - - "3.4" - "3.5" + - "3.6" + +env: + - TEST_CONDA=0 + - TEST_CONDA=1 before_install: - - sudo apt-get install gfortran + # + # Install fortran compiler, if not using Conda's + # + #- sudo apt-get install gfortran + # + # If not using conda, then install liblapack here (conda version + # will handle this through the build recipe) + # + - if [[ $TEST_CONDA == 0 ]]; then + sudo apt-get install liblapack-dev libblas-dev; + sudo apt-get install gfortran; + fi + +install: + # + # Install miniconda to allow quicker installation of dependencies + # See https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html + # - if [[ "$TRAVIS_PYTHON_VERSION" == "2.7" ]]; then wget http://repo.continuum.io/miniconda/Miniconda-latest-Linux-x86_64.sh -O miniconda.sh; else @@ -19,21 +39,51 @@ before_install: - hash -r - conda config --set always_yes yes --set changeps1 no - conda update -q conda - - conda install conda-build - - conda config --add channels http://conda.binstar.org/python-control + - if [[ $TEST_CONDA == 1 ]]; then conda install conda-build; fi - conda info -a - - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose + # + # Set up a test environment for testing everything out + - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy - source activate test-environment + # + # Make sure that fortran compiler can find conda libraries + # + - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; + # + # Install the slycot package (two ways, to improve robustness). For the + # conda version, need to install lapack from conda-forge (no way to specify + # this in the recipe). + # add the conda-forge channel to the config, otherwise openblas or + # lapack cannot be found in the check + # with --override-channels to make sure the locally built slycot is installed + # + - if [[ $TEST_CONDA == 1 ]]; then + conda config --append channels conda-forge; + conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe; + conda install -c conda-forge lapack; + conda install --override-channels -c local slycot; + else + LAPACKLIBS=lapack:blas python setup.py install; + fi + # # coveralls not in conda repos :-( - pip install coveralls -install: - - conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe - - conda install slycot --use-local - -# TODO: replace with nose? script: + # Local unit tests + # TODO: replace with nose? - python runtests.py --coverage + # + # As a deeper set of tests, get test against python-control as well + # + # Additional packages required for python-control + - conda install scipy matplotlib + # Install display manager to allow testing of plotting functions + - export DISPLAY=:99.0 + - sh -e /etc/init.d/xvfb start + # Get python-control from source and install + - git clone https://github.com/python-control/python-control.git control + - cd control; python setup.py test after_success: - coveralls diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat new file mode 100644 index 00000000..c5294765 --- /dev/null +++ b/conda-recipe-openblas/bld.bat @@ -0,0 +1,17 @@ +:: Uncoment following two lines for local test build +cd %RECIPE_DIR% +cd .. + +set F77=%BUILD_PREFIX%\Library\bin\flang.exe +set F90=%BUILD_PREFIX%\Library\bin\flang.exe + +"%PYTHON%" setup.py build +"%PYTHON%" setup.py install + +if errorlevel 1 exit 1 + +:: Add more build steps here, if they are necessary. + +:: See +:: http://docs.continuum.io/conda/build.html +:: for a list of environment variables that are set during the build process. diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh new file mode 100644 index 00000000..abebc130 --- /dev/null +++ b/conda-recipe-openblas/build.sh @@ -0,0 +1,2 @@ +cd $RECIPE_DIR/.. +$PYTHON setup.py install diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml new file mode 100644 index 00000000..1f9ea8fc --- /dev/null +++ b/conda-recipe-openblas/meta.yaml @@ -0,0 +1,37 @@ +package: + name: slycot + version: "0.3.2" + +build: + number: 1 +requirements: + host: + - numpy + - openblas >=0.3.0 + - libflang # [win] + - libgfortran # [not win] + - python + + build: + - {{ compiler('fortran') }} # [not win] + - {{ compiler('c') }} # [win] + - flang # [win] + # on Windows, this relies on having visual studio CE 2015 + # this link needed quite some searching, please do not delete! + # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 + run: + - numpy + - openblas >=0.3.0 + - libgfortran # [not win] + - libflang # [win] + +test: + requires: + - python {{PY_VER}} + imports: + - slycot + +about: + home: https://github.com/python-control/slycot + license: GPLv2 + summary: 'A wrapper for the SLICOT control and systems library' diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 88bfedd3..51da54fe 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -2,8 +2,11 @@ cd %RECIPE_DIR% cd .. -"%PYTHON%" setup.py build --compiler=mingw32 -"%PYTHON%" setup.py install --skip-build +set F77=%BUILD_PREFIX%\Library\bin\flang.exe +set F90=%BUILD_PREFIX%\Library\bin\flang.exe +set LAPACKLIBS=lapack:blas + +"%PYTHON%" setup.py install if errorlevel 1 exit 1 diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index bce90005..5d9c587c 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,2 +1,3 @@ cd $RECIPE_DIR/.. -LDFLAGS="-shared" FFLAGS="-fPIC" $PYTHON setup.py install +export LAPACKLIBS=lapack:blas +$PYTHON setup.py install diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 9644848a..d4534b5a 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -6,18 +6,29 @@ build: number: 1 requirements: - build: - - python - - numpy >=1.13.3 + host: + - numpy - lapack - - m2w64-gcc-fortran # [win] - + - libflang # [win] + - libgfortran # [not win] + - python {{PY_VER}} + + build: + - {{ compiler('fortran') }} # [not win] + - {{ compiler('c') }} # [win] + - flang # [win] + # on Windows, this relies on having visual studio CE 2015 + # this link needed quite some searching, please do not delete! + # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 run: - - python - numpy - lapack + - libgfortran # [not win] + - libflang # [win] test: + requires: + - python {{PY_VER}} imports: - slycot diff --git a/slycot/setup.py b/slycot/setup.py index bcdb3a17..e8a1010d 100644 --- a/slycot/setup.py +++ b/slycot/setup.py @@ -24,12 +24,10 @@ def configuration(parent_package='', top_path=None): pyver = sysconfig.get_config_var('VERSION') if sys.platform == 'win32': - liblist = [ - 'lapack', 'lapacke', 'blas', 'gfortran' - ] - extra_objects = [ - ] + liblist = [ 'openblas', 'flang' ] + extra_objects = [ ] ppath = os.sep.join(sys.executable.split(os.sep)[:-1]) + library_dirs = [r'\Library\lib', ] library_dirs = [ppath + l for l in library_dirs] extra_link_args = [ ] @@ -40,19 +38,31 @@ def configuration(parent_package='', top_path=None): abiflags = sys.abiflags except AttributeError: abiflags = '' - liblist = ['lapack', 'blas', 'python'+pyver+abiflags] extra_objects = [] - library_dirs = [] - extra_link_args = [] - extra_compile_args = [] + ppath = os.sep.join(sys.executable.split(os.sep)[:-2]) + library_dirs = [r'/lib', ] + library_dirs = [ppath + l for l in library_dirs] + if sys.platform == 'darwin': + liblist = ['openblas' ] + extra_link_args = [ '-Wl,-dylib,-undefined,dynamic_lookup' ] + extra_compile_args = [ '-fPIC' ] + else: + liblist = ['openblas'] + extra_link_args = [ '-shared', '-Wl,--allow-shlib-undefined' ] + extra_compile_args = [ '-fPIC' ] + + # override when libraries have been specified + if os.environ.get("LAPACKLIBS", None): + liblist = os.environ.get("LAPACKLIBS").split(':') + print("Overriding library list with", liblist) config.add_extension( name='_wrapper', libraries=liblist, - extra_objects=extra_objects, - extra_link_args=extra_link_args, - library_dirs=library_dirs, - extra_compile_args=extra_compile_args, + extra_objects=extra_objects, + extra_link_args=extra_link_args, + library_dirs=library_dirs, + extra_compile_args=extra_compile_args, sources=fortran_sources + f2py_sources) config.make_config_py() # installs __config__.py From 30dc0e5b80e204ac70c8d3cd8e7b463840d2754e Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 5 Jun 2018 00:56:04 +0200 Subject: [PATCH 010/405] work on getting 'C' version for td04ad working and checked - corrected TD04AD.f to handle the case of 'C' and static gain tf - corrected transform.pyf, to not allocate zero-dim matrices - added tests for td04ad, one static, one checked against Octave with a transfer function set. --- slycot/src/TD04AD.f | 24 +++++++-- slycot/src/transform.pyf | 6 +-- slycot/tests/test_td04ad.py | 105 ++++++++++++++++++++++++++++++++++++ slycot/transform.py | 6 ++- 4 files changed, 131 insertions(+), 10 deletions(-) create mode 100644 slycot/tests/test_td04ad.py diff --git a/slycot/src/TD04AD.f b/slycot/src/TD04AD.f index 9297cee0..15b10e95 100644 --- a/slycot/src/TD04AD.f +++ b/slycot/src/TD04AD.f @@ -245,7 +245,8 @@ SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, $ UCOEFF(LDUCO1,LDUCO2,*) C .. Local Scalars .. LOGICAL LROCOC, LROCOR - INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK + INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK, + $ KU C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME @@ -401,18 +402,31 @@ SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, C state-space representation, and reorder the rows and columns C to get an upper block Hessenberg state dynamics matrix. C - K = IWORK(1)+IWORK(2)-1 - CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, + K = IWORK(1) - 1 + IF ( N.GT.1 ) THEN + K = K + IWORK(2) + END IF +C +C RvP 180615 Try to protect against re-working an empty [] A +C matrix, failed with K < 0 +C + IF ( NR.EQ.0 ) THEN + K = 0 + KU = 0 + ELSE + KU = NR - 1 + END IF + CALL TB01XD( 'D', NR, MWORK, PWORK, K, KU, A, LDA, B, LDB, $ C, LDC, D, LDD, INFO ) IF ( MPLIM.NE.1 ) THEN C C Also, retranspose U(s) if this is non-scalar. C DO 70 K = 1, KDCOEF -C +C DO 60 J = 1, JSTOP CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) + $ UCOEFF(J,J+1,K), LDUCO1 ) 60 CONTINUE C 70 CONTINUE diff --git a/slycot/src/transform.pyf b/slycot/src/transform.pyf index cb35e310..819d6247 100644 --- a/slycot/src/transform.pyf +++ b/slycot/src/transform.pyf @@ -344,17 +344,17 @@ subroutine td04ad_c(rowcol,m,p,index_bn,dcoeff,lddcoe,ucoeff,lduco1,lduco2,nr,a, integer check(m>=0) :: m integer check(p>=0) :: p integer dimension(m),depend(m) :: index_bn - double precision intent(in,copy),dimension(max(1,m),*),depend(p) :: dcoeff + double precision intent(in,copy),dimension(max(1,m),*),depend(m) :: dcoeff integer intent(hide),depend(dcoeff) :: lddcoe=shape(dcoeff,0) double precision intent(in,copy),dimension(max(1,max(m,p)),max(1,max(m,p)),*),depend(p,m) :: ucoeff integer intent(hide),depend(ucoeff) :: lduco1=shape(ucoeff,0) integer intent(hide),depend(ucoeff) :: lduco2=shape(ucoeff,1) integer intent(in,out) :: nr != sum(index_bn) - double precision intent(out),dimension(max(1,nr),nr),depend(nr) :: a + double precision intent(out),dimension(max(1,nr),max(1,nr)),depend(nr) :: a integer intent(hide),depend(a) :: lda = shape(a,0) double precision intent(out),dimension(max(1,nr),max(m,p)),depend(nr,m,p) :: b integer intent(hide),depend(b) :: ldb = shape(b,0) - double precision intent(out),dimension(max(1,max(m,p)),nr),depend(nr,m,p) :: c + double precision intent(out),dimension(max(1,max(m,p)),max(1,nr)),depend(nr,m,p) :: c integer intent(hide),depend(c) :: ldc = shape(c,0) double precision intent(out),dimension(max(1,max(m,p)),max(m,p)),depend(p,m) :: d integer intent(hide),depend(d) :: ldd = shape(d,0) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py new file mode 100644 index 00000000..bebc30f6 --- /dev/null +++ b/slycot/tests/test_td04ad.py @@ -0,0 +1,105 @@ +#!/usr/bin/env python +# +# test_td04ad.py - test suite for tf -> ss conversion +# RvP, 04 Jun 2018 + +from __future__ import print_function + +import unittest +from slycot import transform +import numpy as np + +from numpy.testing import assert_raises, assert_almost_equal + +class TestTf2SS(unittest.TestCase): + + def test_td04ad_case1(self): + # for octave: + """ + num = { [0.0, 0.0, 1.0 ], [ 1.0, 0.0 ]; + [3.0, -1.0, 1.0 ], [ 0.0, 1.0 ]; + [0.0, 0.0, 1.0], [ 0.0, 2.0 ] }; + den = { [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; + [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; + [1.0, 0.4, 3.0], [ 1.0, 1.0 ]}; + """ + + # common denominators for the inputs + n = 2 + m = 2 + p = 3 + num = np.array([ + [ [0.0, 0.0, 1.0 ], [ 1.0, 0.0, 0.0 ] ], + [ [3.0, -1.0, 1.0 ], [ 0.0, 1.0, 0.0 ] ], + [ [0.0, 0.0, 1.0], [ 0.0, 2.0, 0.0 ] ] ]) + p, m, d = num.shape + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) + numc[:p,:m,:] = num + + denc = np.array( + [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ] ]) + indc = np.array( + [ 2, 1 ], dtype=int) + denr = np.array( + [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ], [1.0, 0.0, 0.0] ]) + indr = np.array( + [ 2, 1, 0 ], dtype=int) + + n, A, B, C, D = transform.td04ad('C', 2, 3, indc, denc, numc) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + Ac = [ [-1, 0, 0], [ 0, -0.4, -0.3], [ 0, 10, 0]] + Bc = [ [0, -1] ,[ 1 , 0], [ 0, 0]] + Cc = [ [1, 0, 0.1], [-1, -2.2, -0.8], [ -2, 0, 0.1] ] + Dc = [ [0, 1], [ 3, 0], [ 0, 0]] + np.testing.assert_array_almost_equal(A, Ac) + np.testing.assert_array_almost_equal(B, Bc) + np.testing.assert_array_almost_equal(C, Cc) + np.testing.assert_array_almost_equal(D, Dc) + + resr = transform.td04ad('R', 2, 3, indr, denr, num) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + + def test_staticgain(self): + + # 2 inputs, 3 outputs? columns share a denominator + num = np.array([ [ [1.0], [2.0] ], + [ [0.2], [4.3] ], + [ [1.2], [3.2] ] ]) + p, m, d = num.shape + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) + numc[:p,:m,:] = num + + # denc, columns share a common denominator + denc = np.array([ [ 1.0], [0.5] ]) + Dc = (num / denc).reshape((3,2)) + idxc = np.zeros((2,), dtype=int) + + # denr, rows share a common denominator + denr = np.array([ [1.0], [0.5], [3.0] ]) + idxr = np.zeros((3,), dtype=int) + Dr = (num / denr[:, np.newaxis]).reshape((3,2)) + + # fails with: + # On entry to TB01XD parameter number 5 had an illegal value + + n, A, B, C, D = transform.td04ad('C', 2, 3, idxc, denc, numc) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + self.assertEqual(A.shape, (0,0)) + self.assertEqual(B.shape, (0,2)) + self.assertEqual(C.shape, (3,0)) + np.testing.assert_array_almost_equal(D, Dc) + + n, A, B, C, D = transform.td04ad('R', 2, 3, idxr, denr, num) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + self.assertEqual(A.shape, (0,0)) + self.assertEqual(B.shape, (0,2)) + self.assertEqual(C.shape, (3,0)) + np.testing.assert_array_almost_equal(D, Dr) + + +def suite(): + return unittest.TestLoader().loadTestsFromTestCase(TestTF2SS) + + +if __name__ == "__main__": + unittest.main() diff --git a/slycot/transform.py b/slycot/transform.py index dfa6cfda..485f2f3d 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -670,7 +670,7 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): e = ValueError("The numerator is not a 3D array!") e.info = -7 raise e - if ucoeff.shape != (max([1,m,p]),max([1,m,p]),kdcoef): + if ucoeff.shape != (max(1,m,p),max(1,m,p),kdcoef): e = ValueError("The numerator shape is ("+str(ucoeff.shape[0])+","+str(ucoeff.shape[1])+","+str(ucoeff.shape[2])+"), but expected ("+str(max([1,m,p]))+","+str(max([1,m,p]))+","+str(kdcoef)+")") e.info = -7 raise e @@ -690,7 +690,9 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): e.info = out[-1] raise e if out[-1] > 0: - error_text = "The leading coefficient of a denominator polynomial is nearly zero; calculations would overflow; no state-space representation was calculated. ABS(DCOEFF("+str(out[-1])+",1))="+str(abs(dcoeff(out[-1],1)))+" is too small." + error_text = "The leading coefficient of a denominator polynomial is nearly zero; calculations would overflow; no state-space representation was calculated. ABS(DCOEFF("+str(out[-1])+",1))="+str(abs(dcoeff[out[-1],1]))+" is too small." + print(dcoeff) + e = ValueError(error_text) e.info = out[-1] raise e Nr, A, B, C, D = out[:-1] From 7fce83bbf138eabe75bc9549b46324f576e047cd Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Wed, 20 Jun 2018 22:18:48 +0200 Subject: [PATCH 011/405] working TD04AD.f, does not crash any more on edge cases (N=0, NR=0), and works for 'C' as well as 'R' added a few tests --- slycot/src/TD04AD.f | 21 +++++++++------------ slycot/tests/test_td04ad.py | 35 ++++++++++++++++++++++++++++++++++- 2 files changed, 43 insertions(+), 13 deletions(-) diff --git a/slycot/src/TD04AD.f b/slycot/src/TD04AD.f index 15b10e95..2dde49ad 100644 --- a/slycot/src/TD04AD.f +++ b/slycot/src/TD04AD.f @@ -402,22 +402,19 @@ SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, C state-space representation, and reorder the rows and columns C to get an upper block Hessenberg state dynamics matrix. C - K = IWORK(1) - 1 - IF ( N.GT.1 ) THEN - K = K + IWORK(2) - END IF +C IWORK contains the orders of the diagnonal blocks +C RvP, In TB01PD, IWORK is zeroed from INDCON to N, beyond N it may +C contain nonsense? + K = -1 + DO 55 I = 1, N + K = K + IWORK(I) + 55 CONTINUE C C RvP 180615 Try to protect against re-working an empty [] A C matrix, failed with K < 0 C - IF ( NR.EQ.0 ) THEN - K = 0 - KU = 0 - ELSE - KU = NR - 1 - END IF - CALL TB01XD( 'D', NR, MWORK, PWORK, K, KU, A, LDA, B, LDB, - $ C, LDC, D, LDD, INFO ) + CALL TB01XD( 'D', NR, MWORK, PWORK, MAX(0, K), MAX(0,NR-1), + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) IF ( MPLIM.NE.1 ) THEN C C Also, retranspose U(s) if this is non-scalar. diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index bebc30f6..7d97a512 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -14,6 +14,8 @@ class TestTf2SS(unittest.TestCase): def test_td04ad_case1(self): + """td04ad: Convert with both 'C' and 'R' options""" + # for octave: """ num = { [0.0, 0.0, 1.0 ], [ 1.0, 0.0 ]; @@ -60,7 +62,8 @@ def test_td04ad_case1(self): #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) def test_staticgain(self): - + """td04ad: Convert a transferfunction to SS with only static gain""" + # 2 inputs, 3 outputs? columns share a denominator num = np.array([ [ [1.0], [2.0] ], [ [0.2], [4.3] ], @@ -97,6 +100,36 @@ def test_staticgain(self): np.testing.assert_array_almost_equal(D, Dr) + def test_mixfeedthrough(self): + """Test case popping up from control testing""" + # a mix of feedthrough and dynamics. The problem from the control + # package was somewhere else + num = np.array([ [ [ 0.0, 0.0 ], [ 0.0, -0.2 ] ], + [ [ -0.1, 0.0 ], [ 0.0, 0.0 ] ] ]) + p, m, d = num.shape + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) + numc[:p,:m,:] = num + denc = np.array([ [ 1.0, 1.1 ], [ 1.0, 0.0 ] ]) + idxc = np.array([ 1, 0 ]) + n, A, B, C, D = transform.td04ad('C', 2, 2, idxc, denc, numc) + np.testing.assert_array_almost_equal(D, np.array([[0, 0],[-0.1, 0]])) + + def test_toandfrom(self): + + A = np.array([[-3.0]]) + B = np.array([[0.1, 0.0]]) + C = np.array([[1.0],[0.0]]) + D = np.array([[0.0, 0.0],[0.0, 1.0]]) + + tfout = transform.tb04ad(1, 2, 2, A, B, C, D) + + num = tfout[6] + den = tfout[5] + idxc = np.array([1, 0]) + n, At, Bt, Ct, Dt = transform.td04ad('R', 2, 2, idxc, den, num) + np.testing.assert_array_almost_equal(D, Dt) + np.testing.assert_array_almost_equal(A, At) + def suite(): return unittest.TestLoader().loadTestsFromTestCase(TestTF2SS) From dacd67f783f29c5f437c70fc8eaff21683e9a9ad Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Thu, 28 Jun 2018 21:00:15 -0700 Subject: [PATCH 012/405] update version number to 0.3.3 --- conda-recipe-openblas/meta.yaml | 2 +- conda-recipe/meta.yaml | 2 +- setup.py | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 1f9ea8fc..840ceb3a 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -1,6 +1,6 @@ package: name: slycot - version: "0.3.2" + version: "0.3.3" build: number: 1 diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 6aa574dd..a3ff283a 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -1,6 +1,6 @@ package: name: slycot - version: "0.3.2" + version: "0.3.3" build: number: 1 diff --git a/setup.py b/setup.py index bb0afdbc..946ba1e7 100644 --- a/setup.py +++ b/setup.py @@ -44,7 +44,7 @@ MAJOR = 0 MINOR = 3 -MICRO = 2 +MICRO = 3 POST = 0 ISRELEASED = False VERSION = '%d.%d.%d' % (MAJOR, MINOR, MICRO) From fdcc0efe4466ccc61f18c68a30a52ba5364e843d Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Thu, 28 Jun 2018 21:00:52 -0700 Subject: [PATCH 013/405] create slycot.__version__ with current version number --- slycot/__init__.py | 3 +++ 1 file changed, 3 insertions(+) diff --git a/slycot/__init__.py b/slycot/__init__.py index d9d23741..ca429748 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -37,6 +37,9 @@ from .transform import tf01md, tf01rd from .transform import td04ad, tb01pd + # Version information + from .version import version as __version__ + from numpy.testing import Tester test = Tester().test bench = Tester().bench From dd8ac27ef379c70629f99c3fcfdd1f9b6de59b06 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Thu, 28 Jun 2018 21:01:26 -0700 Subject: [PATCH 014/405] updated README to capture conflicted changes from PR #22 --- README.rst | 85 +++++++++++++++++++++++++++--------------------------- 1 file changed, 43 insertions(+), 42 deletions(-) diff --git a/README.rst b/README.rst index 3e8824b4..0a28d2de 100644 --- a/README.rst +++ b/README.rst @@ -1,17 +1,24 @@ Slycot -============= +====== + +.. image:: https://img.shields.io/pypi/v/slycot.svg + :target: https://pypi.org/project/slycot/ + +.. image:: https://anaconda.org/conda-forge/slycot/badges/version.svg + :target: https://anaconda.org/conda-forge/slycot .. image:: https://travis-ci.org/python-control/slycot.svg?branch=master - :target: https://travis-ci.org/python-control/slycot + :target: https://travis-ci.org/python-control/slycot + .. image:: https://coveralls.io/repos/python-control/slycot/badge.png - :target: https://coveralls.io/r/python-control/slycot + :target: https://coveralls.io/r/python-control/slycot Python wrapper for selected SLICOT routines, notably including solvers for Riccati, Lyapunov, and Sylvester equations. -Prerequisites: --------------- +Dependencies +------------ Slycot depends on Numpy and, if you are installing a binary distribution, Numpy should be the only prerequisite (though you may need the LAPACK @@ -23,13 +30,13 @@ compiler, such as gfortran, and BLAS/LAPACK libraries. On Debian derivatives you should be able to install all the above with a single command:: - sudo apt-get build-dep python-scipy + sudo apt-get build-dep python-scipy On Mac, you will first need to install the `developer tools `_. You can then install gfortran using `homebrew `_ with:: - brew install gcc + brew install gcc On Windows, we suggest installing on top of the Python(x,y) distribution, and grabbing BLAS and LAPACK libraries from: @@ -39,64 +46,65 @@ http://icl.cs.utk.edu/lapack-for-windows/libraries/VisualStudio/3.4.1/Dynamic-MI * install dll files in C:\Python27\DLLs * install lib files in C:\Python27\libs - Installing ----------- Using pip ~~~~~~~~~ -Slycot supports the pip packaging system. You must first have -pip installed. +Slycot supports the pip packaging system. You must first have pip installed. -On debian linux based systems you can install pip with the command:: +On Debian Linux based systems you can install pip with the command:: - sudo apt-get install pip + sudo apt-get install pip -Pip can then be used to install Slycot wih the command:: +Pip can then be used to install Slycot with the command:: - sudo pip install slycot + pip install slycot -There are some binary "wheels" available on PyPI, so if those versions match -with your system, you may be able to avoid installing from source. +Note that installing with pip may or may not require having the build +dependencies installed. There are some binary "wheels" available on PyPI, +so if those versions match with your system, you may be able to avoid +installing from source. Using conda ~~~~~~~~~~~ -If you use `Anaconda or conda `_ on Linux or Mac, -it should be straighforward to install Slycot, without needing any compilers or -other prerequisites. Slycot is not included in the standard conda package -repository, but there are packages available on conda-forge for Linux and -Mac. You can install with the following command:: - - conda install -c conda-forge slycot +Slycot can be installed for Linux or Mac via the conda package manager from +the conda-forge channel with the following command:: + conda install -c conda-forge slycot -From Source +From source ~~~~~~~~~~~ -Unpack to a directory of your choice, say /path/to/slycot_src/, and execute:: +Unpack the course code to a directory of your choice, +e.g. ``/path/to/slycot_src/``, and execute:: - cd /path/to/slycot_src/ - # python setup.py install + cd /path/to/slycot_src/ + python setup.py install Where # is for commands that needs to be executed as root/administrator. If the build fails and you are on a 64bit OS you may want to try:: - cd /path/to/slycot_src/ - python setup.py config_fc --arch="-march=x86-64" build - # python setup.py install + python setup.py config_fc --arch="-march=x86-64" build + python setup.py install + +You can also use conda to build and install slycot from source:: + + conda build conda-recipe + conda install --use-local slycot For Windows, and using Python(x,y), specify that you are using the -mingw compiler. Create a file +mingw compiler. Create a file -C:\\Python27\\Lib\\distutils\\distutils.cfg + C:\\Python27\\Lib\\distutils\\distutils.cfg -with as contents:: +with contents:: - [build] - compiler=mingw32 + [build] + compiler=mingw32 Additional tips for how to install slycot from source can be found in the .travis.yml (commands used for Travis CI) and conda-recipe/ (conda @@ -110,10 +118,3 @@ properly with Python. If you are using conda, you can also get working Note that in some cases you may need to set the LIBRARY_PATH environment variable to pick up dependencies such as -lpythonN.m (where N.m is the version of python you are using). - - -To-Do ------- - -- write unit tests, already added test script, and simple test -- add examples in the doc-strings From b0eccf220fd9332ee24a61d4bf5cd4ff144ffdc0 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Fri, 29 Jun 2018 09:44:32 -0700 Subject: [PATCH 015/405] change build number to zero for conda --- conda-recipe-openblas/meta.yaml | 3 ++- conda-recipe/meta.yaml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 840ceb3a..3fa9eca1 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -3,7 +3,8 @@ package: version: "0.3.3" build: - number: 1 + number: 0 + requirements: host: - numpy diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index a3ff283a..8ff28a28 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -3,7 +3,7 @@ package: version: "0.3.3" build: - number: 1 + number: 0 requirements: host: From 3af1189b409d34c294ee03d6e2116880ed30605a Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 30 Jun 2018 06:43:02 -0700 Subject: [PATCH 016/405] Updated README to respond to PR #28 feedback --- README.rst | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/README.rst b/README.rst index 0a28d2de..f81b9ed1 100644 --- a/README.rst +++ b/README.rst @@ -38,13 +38,10 @@ On Mac, you will first need to install the `developer tools brew install gcc -On Windows, we suggest installing on top of the Python(x,y) distribution, and -grabbing BLAS and LAPACK libraries from: +On Windows, the BLAS and LAPACK libraries can be obtained from: http://icl.cs.utk.edu/lapack-for-windows/libraries/VisualStudio/3.4.1/Dynamic-MINGW/Win32/ -* install dll files in C:\Python27\DLLs -* install lib files in C:\Python27\libs Installing ----------- @@ -70,8 +67,8 @@ installing from source. Using conda ~~~~~~~~~~~ -Slycot can be installed for Linux or Mac via the conda package manager from -the conda-forge channel with the following command:: +Slycot can be installed via the conda package manager from the conda-forge +channel with the following command:: conda install -c conda-forge slycot @@ -94,17 +91,10 @@ If the build fails and you are on a 64bit OS you may want to try:: You can also use conda to build and install slycot from source:: conda build conda-recipe - conda install --use-local slycot + conda install --use-local slycot -For Windows, and using Python(x,y), specify that you are using the -mingw compiler. Create a file - - C:\\Python27\\Lib\\distutils\\distutils.cfg - -with contents:: - - [build] - compiler=mingw32 +If you prefer to use the OpenBLAS library, a conda recipe is available in +``conda-recipe-openblas``. Additional tips for how to install slycot from source can be found in the .travis.yml (commands used for Travis CI) and conda-recipe/ (conda @@ -115,6 +105,8 @@ properly with Python. If you are using conda, you can also get working conda install -c conda-forge lapack +Slycot will also work with the OpenBLAS libraries. + Note that in some cases you may need to set the LIBRARY_PATH environment variable to pick up dependencies such as -lpythonN.m (where N.m is the version of python you are using). From bcf2f791daa3017fa265b65d623513e988fe6d10 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Wed, 4 Jul 2018 12:08:32 -0700 Subject: [PATCH 017/405] mark this as 0.3.3 release in setup.py --- setup.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/setup.py b/setup.py index 946ba1e7..47488207 100644 --- a/setup.py +++ b/setup.py @@ -46,7 +46,7 @@ MINOR = 3 MICRO = 3 POST = 0 -ISRELEASED = False +ISRELEASED = True VERSION = '%d.%d.%d' % (MAJOR, MINOR, MICRO) if POST != 0: VERSION += '-post{:d}'.format(POST) From d02a3015a55c7f3056d91ec24d5c95e2bb9cc152 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 7 Jul 2018 12:25:04 -0700 Subject: [PATCH 018/405] update version number to 0.3.4 (not released) --- setup.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/setup.py b/setup.py index 47488207..ee1a44e1 100644 --- a/setup.py +++ b/setup.py @@ -44,9 +44,9 @@ MAJOR = 0 MINOR = 3 -MICRO = 3 +MICRO = 4 POST = 0 -ISRELEASED = True +ISRELEASED = False VERSION = '%d.%d.%d' % (MAJOR, MINOR, MICRO) if POST != 0: VERSION += '-post{:d}'.format(POST) From c80fad093bc62016aed935c1bf3def7c102e5e64 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Tue, 17 Jul 2018 14:20:37 +0200 Subject: [PATCH 019/405] add support for ag08bd, sb10jd and tg01fd """ A,B,C,D = sl10jd(n,m,np,A,B,C,D,E,[ldwork]) To convert the descriptor state-space system E*dx/dt = A*x + B*u y = C*x + D*u into regular state-space form dx/dt = Ad*x + Bd*u y = Cd*x + Dd*u . Required arguments: n : input int The order of the descriptor system. n >= 0. m : input int The column size of the matrix B. m >= 0. np : input int The row size of the matrix C. np >= 0. A : rank-2 array('d') with bounds (n,n) The leading n-by-n part of this array must contain the state matrix A of the descriptor system. B : rank-2 array('d') with bounds (l,m) The leading n-by-m part of this array must contain the input matrix B of the descriptor system. C : rank-2 array('d') with bounds (np,n) The leading np-by-n part of this array must contain the output matrix C of the descriptor system. D : rank-2 array('d') with bounds (np,m) The leading np-by-m part of this array must contain the matrix D of the descriptor system. E : rank-2 array('d') with bounds (l,n) The leading n-by-n part of this array must contain the matrix E of the descriptor system. Optional arguments: ldwork : input int The length of the cache array. ldwork >= max( 1, 2*n*n + 2*n + n*MAX( 5, n + m + np ) ). For good performance, ldwork must generally be larger. Return objects: A : rank-2 array('d') with bounds (nsys,nsys) The leading nsys-by-nsys part of this array contains the state matrix Ad of the converted system. B : rank-2 array('d') with bounds (nsys,m) The leading NSYS-by-M part of this array contains the input matrix Bd of the converted system. C : rank-2 array('d') with bounds (np,nsys) The leading NP-by-NSYS part of this array contains the output matrix Cd of the converted system. D : rank-2 array('d') with bounds (np,m) The leading NP-by-M part of this array contains the matrix Dd of the converted system. """ hidden = ' (hidden by the wrapper)' arg_list = ['n', 'm', 'np', 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'E', 'lde'+hidden, 'nsys', 'dwork'+hidden, 'ldwork', 'info'] if ldwork is None: ldwork = max(1, 2 * n * n + 2 * n + n * max(5, n + m + np)) A,B,C,D,nsys,info = _wrapper.sb10jd(n,m,np,A,B,C,D,E,ldwork) if info < 0: error_text = "The following argument had an illegal value: "+arg_list[-info-1] e = ValueError(error_text) e.info = info raise e elif info == 1: e = ArithmeticError("The sb10jd algorithm did not converge") e.info = 1 raise e elif info != 0: e = ArithmeticError('sb10jd failed') e.info = info raise e return A[:nsys,:nsys],B[:nsys,:m],C[:np, :nsys],D[:np, :m] --- slycot/analysis.py | 113 +++++++++++++++++++++++ slycot/src/analysis.pyf | 33 +++++++ slycot/src/synthesis.pyf | 19 ++++ slycot/src/transform.pyf | 88 +++++++++++++++++- slycot/synthesis.py | 79 ++++++++++++++++ slycot/transform.py | 194 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 525 insertions(+), 1 deletion(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index daf05c94..ffaf304d 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1571,4 +1571,117 @@ def ab13fd(n, A, tol = 0.0): else: raise RuntimeError("unknown error code %r" % out[-1]) +def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): + """ Af,Ef,nrank,infz,kronr,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) + + To extract from the system pencil + + ( A-lambda*E B ) + S(lambda) = ( ) + ( C D ) + + a regular pencil Af-lambda*Ef which has the finite Smith zeros of + S(lambda) as generalized eigenvalues. The routine also computes + the orders of the infinite Smith zeros and determines the singular + and infinite Kronecker structure of system pencil, i.e., the right + and left Kronecker indices, and the multiplicities of infinite + eigenvalues. + + Required arguments: + l : input int + The number of rows of matrices A, B, and E. l >= 0. + n : input int + The number of columns of matrices A, E, and C. n >= 0. + m : input int + The number of columns of matrix B. m >= 0. + p : input int + The number of rows of matrix C. p >= 0. + A : rank-2 array('d') with bounds (l,n) + The leading l-by-n part of this array must + contain the state dynamics matrix A of the system. + E : rank-2 array('d') with bounds (l,n) + The leading l-by-n part of this array must + contain the descriptor matrix E of the system. + B : rank-2 array('d') with bounds (l,m) + The leading l-by-m part of this array must + contain the input/state matrix B of the system. + C : rank-2 array('d') with bounds (p,n) + The leading p-by-n part of this array must + contain the state/output matrix C of the system. + D : rank-2 array('d') with bounds (p,m) + The leading p-by-m part of this array must contain the + direct transmission matrix D of the system. + Optional arguments: + equil := 'N' input string(len=1) + Specifies whether the user wishes to balance the system + matrix as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + tol := 0 input float + A tolerance used in rank decisions to determine the + effective rank, which is defined as the order of the + largest leading (or trailing) triangular submatrix in the + QR (or RQ) factorization with column (or row) pivoting + whose estimated condition number is less than 1/TOL. + If the user sets TOL <= 0, then default tolerances are + used instead, as follows: TOLDEF = L*N*EPS in TG01FD + (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS + in the rest, where EPS is the machine precision + (see LAPACK Library routine DLAMCH). TOL < 1. + ldwork : input int + The length of the cache array. + ldwork >= max( 4*(lnN), ldw ), if equil = 'S', + ldwork >= ldw, if equil = 'N', where + ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)). + For optimum performance ldwork should be larger. + Return objects: + Af : rank-2 array('d') + the leading NFZ-by-NFZ part of this array + contains the matrix Af of the reduced pencil. + Ef : rank-2 array('d') + the leading NFZ-by-NFZ part of this array + contains the matrix Ef of the reduced pencil. + nrank : output int + The normal rank of the system pencil. + niz : output int + The number of infinite zeros. + infz : rank-1 array('i') + The leading DINFZ elements of infz contain information + on the infinite elementary divisors as follows: + the system has infz(i) infinite elementary divisors of + degree i in the Smith form, where i = 1,2,...,DINFZ. + kronr : rank-1 array('i') + The leading NKROR elements of this array contain the + right Kronecker (column) indices. + infe : rank-1 array('i') + The leading NINFE elements of infe contain the + multiplicities of infinite eigenvalues. + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['equil', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nfz', 'nrank', 'niz', 'dinfz', 'nkror', 'ninfe', 'nkrol', 'infz', 'kronr', 'infe', 'kronl', 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] + + if equil != 'S' and equil != 'N': + raise ValueError('Parameter equil had an illegal value') + + if ldwork is None: + ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)) + if equil == 'S': + ldwork = max(l+p, m+n) * (m+n) + max (1, 5 * max (l+p, m+n)) + else: #equil == 'N' + ldwork = ldw + + [Af,Ef,nfz,nrank,niz,dinfz,nkror,ninfe,nkrol,infz,kronr,infe,kronl,info]= _wrapper.ag08bd(equil,l,n,m,p,A,E,B,C,D,tol,ldwork) + + if info < 0: + error_text = "The following argument had an illegal value: "+arg_list[-info-1] + e = ValueError(error_text) + e.info = info + raise e + if info != 0: + e = ArithmeticError('ag08bd failed') + e.info = info + raise e + + return Af[:nfz,:nfz],Ef[:nfz,:nfz],nrank,niz,infz[:dinfz],kronr[:nkror],infe[:ninfe], kronl[:nkrol] + # to be replaced by python wrappers diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 25c8edb2..227fbe98 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -386,3 +386,36 @@ subroutine ab13fd(n,a,lda,beta,omega,tol,dwork,ldwork,cwork,lcwork,info) ! in AB integer intent(hide),depend(n) :: lcwork = max(1,n*(n+3)) integer intent(out) :: info end subroutine ab13fd +subroutine ag08bd(equil,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,d,ldd,nfz,nrank,niz,dinfz,nkror,ninfe,nkrol,infz,kronr,infe,kronl,tol,iwork,dwork,ldwork,info) ! in AG08BD.f + character intent(in) :: equil + integer intent(in),required,check(l>=0) :: l + integer intent(in),required,check(n>=0) :: n + integer intent(in),required,check(m>=0) :: m + integer intent(in),required,check(p>=0) :: p + double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e + integer intent(hide),depend(e) :: lde=shape(e,0) + double precision intent(in,copy),dimension(l,m),depend(l,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + double precision intent(in,copy),dimension(p,n),depend(p,n) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + double precision intent(in,copy),dimension(p,m),depend(p,m) :: d + integer intent(hide),depend(d) :: ldd=shape(d,0) + integer intent(out) :: nfz + integer intent(out) :: nrank + integer intent(out) :: niz + integer intent(out) :: dinfz + integer intent(out) :: nkror + integer intent(out) :: ninfe + integer intent(out) :: nkrol + integer intent(out),dimension(n+1),depend(n) :: infz + integer intent(out),dimension(n+m+1),depend(n,m) :: kronr + integer intent(out),dimension(1+MIN(l+p,n+m)),depend(l,p,n,m) :: infe + integer intent(out),dimension(l+p+1),depend(l,p) :: kronl + double precision intent(in) :: tol + integer intent(cache,hide),dimension(ldwork),depend(ldwork) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork + integer required intent(in) :: ldwork + integer intent(out) :: info +end subroutine ag08bd \ No newline at end of file diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index 2fdb1308..a94cec3a 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -525,6 +525,25 @@ subroutine sb10hd(n,m,np,ncon,nmeas,a,lda,b,ldb,c,ldc,d,ldd,ak,ldak,bk,ldbk,ck,l logical intent(hide), dimension(2*n), depend(n) :: bwork integer intent(out) :: info end subroutine sb10hd +subroutine sb10jd(n,m,np,a,lda,b,ldb,c,ldc,d,ldd,e,lde,nsys,dwork,ldwork,info) ! in SB10JD.f + integer intent(in),required :: n + integer intent(in),required :: m + integer intent(in),required :: np + double precision intent(in,out,copy),dimension(lda,n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + double precision intent(in,out,copy),dimension(ldb,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + double precision intent(in,out,copy),dimension(ldc,n) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + double precision intent(in,out,copy),dimension(ldd,m) :: d + integer intent(hide),depend(d) :: ldd=shape(d,0) + double precision intent(in,copy),dimension(lde,n) :: e + integer intent(hide),depend(e) :: lde=shape(e,0) + integer intent(out) :: nsys + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork +integer required intent(in) :: ldwork + integer intent(out) :: info +end subroutine sb10jd subroutine sg03ad(dico,job,fact,trans,uplo,n,a,lda,e,lde,q,ldq,z,ldz,x,ldx,scale,sep,ferr,alphar,alphai,beta,iwork,dwork,ldwork,info) ! in SG03AD.f character :: dico character :: job diff --git a/slycot/src/transform.pyf b/slycot/src/transform.pyf index 819d6247..ae59862b 100644 --- a/slycot/src/transform.pyf +++ b/slycot/src/transform.pyf @@ -421,4 +421,90 @@ subroutine tb01pd(job,equil,n,m,p,a,lda,b,ldb,c,ldc,nr,tol,iwork,dwork,ldwork,in integer optional,depend(n,m,p) :: ldwork=max(1,n+max(n,max(3*m,3*p))) integer intent(out) :: info end subroutine tb01pd - +subroutine tg01fd_nn(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ldz,ranke,rnka22,tol,iwork,dwork,ldwork,info) ! in TG01FD.f + fortranname tg01fd + character intent(hide) :: compq = 'N' + character intent(hide) :: compz = 'N' + character intent(in),required :: joba + integer intent(in),required,check(l>=0) :: l + integer intent(in),required,check(n>=0) :: n + integer intent(in),required,check(m>=0) :: m + integer intent(in),required,check(p>=0) :: p + double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e + integer intent(hide),depend(e) :: lde=shape(e,0) + double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + double precision intent(hide),dimension(0,0) :: q + integer intent(hide),depend(q) :: ldq=1 + double precision intent(hide),dimension(0,0) :: z + integer intent(hide),depend(z) :: ldz=1 + integer intent(out) :: ranke + integer intent(out) :: rnka22 + double precision intent(in) :: tol + integer intent(cache,hide),dimension(ldwork),depend(ldwork) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork +integer required intent(in) :: ldwork + integer intent(out) :: info +end subroutine tg01fd_nn +subroutine tg01fd_ii(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ldz,ranke,rnka22,tol,iwork,dwork,ldwork,info) ! in TG01FD.f + fortranname tg01fd + character intent(hide) :: compq = 'I' + character intent(hide) :: compz = 'I' + character intent(in),required :: joba + integer intent(in),required,check(l>=0) :: l + integer intent(in),required,check(n>=0) :: n + integer intent(in),required,check(m>=0) :: m + integer intent(in),required,check(p>=0) :: p + double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e + integer intent(hide),depend(e) :: lde=shape(e,0) + double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + double precision intent(out),dimension(l,l) :: q + integer intent(hide),depend(q) :: ldq=shape(q,0) + double precision intent(out),dimension(n,n) :: z + integer intent(hide),depend(z) :: ldz=shape(z,0) + integer intent(out) :: ranke + integer intent(out) :: rnka22 + double precision intent(in) :: tol + integer intent(cache,hide),dimension(ldwork),depend(ldwork) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork +integer required intent(in) :: ldwork + integer intent(out) :: info +end subroutine tg01fd_ii +subroutine tg01fd_uu(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ldz,ranke,rnka22,tol,iwork,dwork,ldwork,info) ! in TG01FD.f + fortranname tg01fd + character intent(hide) :: compq = 'U' + character intent(hide) :: compz = 'U' + character intent(in),required :: joba + integer intent(in),required,check(l>=0) :: l + integer intent(in),required,check(n>=0) :: n + integer intent(in),required,check(m>=0) :: m + integer intent(in),required,check(p>=0) :: p + double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e + integer intent(hide),depend(e) :: lde=shape(e,0) + double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + double precision intent(in,out,copy),dimension(l,l) :: q + integer intent(hide),depend(q) :: ldq=shape(q,0) + double precision intent(in,out,copy),dimension(n,n) :: z + integer intent(hide),depend(z) :: ldz=shape(z,0) + integer intent(out) :: ranke + integer intent(out) :: rnka22 + double precision intent(in) :: tol + integer intent(cache,hide),dimension(ldwork),depend(ldwork) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork +integer required intent(in) :: ldwork + integer intent(out) :: info +end subroutine tg01fd_uu diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 75daa347..c0653f0c 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1838,6 +1838,85 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): raise e return out[:-1] + +def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): + """ A,B,C,D = sl10jd(n,m,np,A,B,C,D,E,[ldwork]) + + To convert the descriptor state-space system + + E*dx/dt = A*x + B*u + y = C*x + D*u + + into regular state-space form + + dx/dt = Ad*x + Bd*u + y = Cd*x + Dd*u . + + Required arguments: + n : input int + The order of the descriptor system. n >= 0. + m : input int + The column size of the matrix B. m >= 0. + np : input int + The row size of the matrix C. np >= 0. + A : rank-2 array('d') with bounds (n,n) + The leading n-by-n part of this array must + contain the state matrix A of the descriptor system. + B : rank-2 array('d') with bounds (l,m) + The leading n-by-m part of this array must + contain the input matrix B of the descriptor system. + C : rank-2 array('d') with bounds (np,n) + The leading np-by-n part of this array must + contain the output matrix C of the descriptor system. + D : rank-2 array('d') with bounds (np,m) + The leading np-by-m part of this array must + contain the matrix D of the descriptor system. + E : rank-2 array('d') with bounds (l,n) + The leading n-by-n part of this array must + contain the matrix E of the descriptor system. + Optional arguments: + ldwork : input int + The length of the cache array. + ldwork >= max( 1, 2*n*n + 2*n + n*MAX( 5, n + m + np ) ). + For good performance, ldwork must generally be larger. + Return objects: + A : rank-2 array('d') with bounds (nsys,nsys) + The leading nsys-by-nsys part of this array + contains the state matrix Ad of the converted system. + B : rank-2 array('d') with bounds (nsys,m) + The leading NSYS-by-M part of this array + contains the input matrix Bd of the converted system. + C : rank-2 array('d') with bounds (np,nsys) + The leading NP-by-NSYS part of this array + contains the output matrix Cd of the converted system. + D : rank-2 array('d') with bounds (np,m) + The leading NP-by-M part of this array contains + the matrix Dd of the converted system. + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['n', 'm', 'np', 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'E', 'lde'+hidden, 'nsys', 'dwork'+hidden, 'ldwork', 'info'] + + if ldwork is None: + ldwork = max(1, 2 * n * n + 2 * n + n * max(5, n + m + np)) + + A,B,C,D,nsys,info = _wrapper.sb10jd(n,m,np,A,B,C,D,E,ldwork) + + if info < 0: + error_text = "The following argument had an illegal value: "+arg_list[-info-1] + e = ValueError(error_text) + e.info = info + raise e + elif info == 1: + e = ArithmeticError("The sb10jd algorithm did not converge") + e.info = 1 + raise e + elif info != 0: + e = ArithmeticError('sb10jd failed') + e.info = info + raise e + + return A[:nsys,:nsys],B[:nsys,:m],C[:np, :nsys],D[:np, :m] def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): """ A,E,Q,Z,X,scale,sep,ferr,alphar,alphai,beta = diff --git a/slycot/transform.py b/slycot/transform.py index 485f2f3d..3d39f0a7 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1050,5 +1050,199 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): raise e return out[:-1] +def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): + """ A,E,B,C,ranke,rnka22,Q,Z = tg01fd(l,n,m,p,A,E,B,C,[Q,Z,compq,compz,joba,tol,ldwork]) + + To compute for the descriptor system (A-lambda E,B,C) + the orthogonal transformation matrices Q and Z such that the + transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is + in a SVD-like coordinate form with + + ( A11 A12 ) ( Er 0 ) + Q'*A*Z = ( ) , Q'*E*Z = ( ) , + ( A21 A22 ) ( 0 0 ) + + where Er is an upper triangular invertible matrix. + Optionally, the A22 matrix can be further reduced to the form + + ( Ar X ) + A22 = ( ) , + ( 0 0 ) + + with Ar an upper triangular invertible matrix, and X either a full + or a zero matrix. + The left and/or right orthogonal transformations performed + to reduce E and A22 can be optionally accumulated. + + Required arguments: + l : input int + The number of rows of matrices A, B, and E. l >= 0. + n : input int + The number of columns of matrices A, E, and C. n >= 0. + m : input int + The number of columns of matrix B. m >= 0. + p : input int + The number of rows of matrix C. p >= 0. + A : rank-2 array('d') with bounds (l,n) + The leading l-by-n part of this array must + contain the state dynamics matrix A. + E : rank-2 array('d') with bounds (l,n) + The leading l-by-n part of this array must + contain the descriptor matrix E. + B : rank-2 array('d') with bounds (l,m) + The leading L-by-M part of this array must + contain the input/state matrix B. + C : rank-2 array('d') with bounds (p,n) + The leading P-by-N part of this array must + contain the state/output matrix C. + Optional arguments: + Q : rank-2 array('d') with bounds (l,l) + If COMPQ = 'N': Q is not referenced. + If COMPQ = 'I': Q need not be set. + If COMPQ = 'U': The leading l-by-l part of this + array must contain an orthogonal matrix + Q1. + Z : rank-2 array('d') with bounds (n,n) + If COMPZ = 'N': Z is not referenced. + If COMPZ = 'I': Z need not be set. + If COMPZ = 'U': The leading n-by-n part of this + array must contain an orthogonal matrix + Z1. + compq := 'N' input string(len=1) + = 'N': do not compute Q. + = 'I': Q is initialized to the unit matrix, and the + orthogonal matrix Q is returned. + = 'U': Q must contain an orthogonal matrix Q1 on entry, + and the product Q1*Q is returned. + compz := 'N' input string(len=1) + = 'N': do not compute Z. + = 'I': Z is initialized to the unit matrix, and the + orthogonal matrix Z is returned. + = 'U': Z must contain an orthogonal matrix Z1 on entry, + and the product Z1*Z is returned. + joba := 'N' input string(len=1) + = 'N': do not reduce A22. + = 'R': reduce A22 to a SVD-like upper triangular form. + = 'T': reduce A22 to an upper trapezoidal form. + tol := 0 input float + The tolerance to be used in determining the rank of E + and of A22. If the user sets TOL > 0, then the given + value of TOL is used as a lower bound for the + reciprocal condition numbers of leading submatrices + of R or R22 in the QR decompositions E * P = Q * R of E + or A22 * P22 = Q22 * R22 of A22. + A submatrix whose estimated condition number is less than + 1/TOL is considered to be of full rank. If the user sets + TOL <= 0, then an implicitly computed, default tolerance, + defined by TOLDEF = L*N*EPS, is used instead, where + EPS is the machine precision (see LAPACK Library routine + DLAMCH). TOL < 1. + ldwork : input int + The length of the cache array. + ldwork >= MAX( 1, n+p, MIN(l,n)+MAX(3*n-1,m,l) ). + For optimal performance, ldwork should be larger. + Return objects: + A : rank-2 array('d') with bounds (l,n) + On entry, the leading L-by-N part of this array must + contain the state dynamics matrix A. + On exit, the leading L-by-N part of this array contains + the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix + is in the form + + ( A11 * * ) + Q'*A*Z = ( * Ar X ) , + ( * 0 0 ) + + where A11 is a RANKE-by-RANKE matrix and Ar is a + RNKA22-by-RNKA22 invertible upper triangular matrix. + If JOBA = 'R' then A has the above form with X = 0. + E : rank-2 array('d') with bounds (l,n) + The leading L-by-N part of this array contains + the transformed matrix Q'*E*Z. + + ( Er 0 ) + Q'*E*Z = ( ) , + ( 0 0 ) + + where Er is a RANKE-by-RANKE upper triangular invertible + matrix. + B : rank-2 array('d') with bounds (l,m) + The leading L-by-M part of this array contains + the transformed matrix Q'*B. + C : rank-2 array('d') with bounds (p,n) + The leading P-by-N part of this array contains + the transformed matrix C*Z. + Q : rank-2 array('d') with bounds (l,l) + If COMPQ = 'N': Q is not referenced. + If COMPQ = 'I': The leading L-by-L part of this + array contains the orthogonal matrix Q, + where Q' is the product of Householder + transformations which are applied to A, + E, and B on the left. + If COMPQ = 'U': The leading L-by-L part of this + array contains the orthogonal matrix + Q1*Q. + Z : rank-2 array('d') with bounds (n,n) + If COMPZ = 'N': Z is not referenced. + If COMPZ = 'I': The leading N-by-N part of this + array contains the orthogonal matrix Z, + which is the product of Householder + transformations applied to A, E, and C + on the right. + If COMPZ = 'U': The leading N-by-N part of this + array contains the orthogonal matrix + Z1*Z. + ranke : output int + The estimated rank of matrix E, and thus also the order + of the invertible upper triangular submatrix Er. + rnka22 : output int + If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of + matrix A22, and thus also the order of the invertible + upper triangular submatrix Ar. + If JOBA = 'N', then RNKA22 is not referenced. + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['compq', 'compz', 'joba', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden,'Q','ldq'+hidden,'Z','ldz'+hidden,'ranke','rnka22','tol','iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] + + + if compq != 'N' and compq != 'I' and compq != 'U': + raise ValueError('Parameter compq had an illegal value') + + if compz != 'N' and compz != 'I' and compz != 'U': + raise ValueError('Parameter compz had an illegal value') + + if joba != 'N' and joba != 'R' and joba != 'T': + raise ValueError('Parameter joba had an illegal value') + + if ldwork is None: + ldwork = max(1, n+p, min(l,n) + max(3*n-1, m, l)) + + + if compq == 'N' and compz == 'N': + A,E,B,C,ranke,rnka22,info = _wrapper.tg01fd_nn(joba,l,n,m,p,A,E,B,C,tol,ldwork) + Q = None + Z = None + elif compq == 'I' and compz == 'I': + A,E,B,C,Q,Z,ranke,rnka22,info = _wrapper.tg01fd_ii(joba,l,n,m,p,A,E,B,C,tol,ldwork) + elif compq == 'U' and compz == 'U': + A,E,B,C,Q,Z,ranke,rnka22,info = _wrapper.tg01fd_uu(joba,l,n,m,p,A,E,B,C,Q,Z,tol,ldwork) + else: + raise ValueError("The combination of compq and compz in not implemented") + + if info < 0: + error_text = "The following argument had an illegal value: "+arg_list[-info-1] + e = ValueError(error_text) + e.info = info + raise e + if info != 0: + e = ArithmeticError('tg01fd failed') + e.info = info + raise e + + if joba == 'N': + rnka22 = None + + return A,E,B,C,ranke,rnka22,Q,Z # to be replaced by python wrappers From 388f8eef0bf3b9ec7c3b17685492d482c07b2084 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Tue, 17 Jul 2018 16:22:56 +0200 Subject: [PATCH 020/405] correct ldwork for ag08bd --- slycot/analysis.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index ffaf304d..d446970e 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1630,7 +1630,7 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): (see LAPACK Library routine DLAMCH). TOL < 1. ldwork : input int The length of the cache array. - ldwork >= max( 4*(lnN), ldw ), if equil = 'S', + ldwork >= max( 4*(l,n), ldw ), if equil = 'S', ldwork >= ldw, if equil = 'N', where ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)). For optimum performance ldwork should be larger. @@ -1666,7 +1666,7 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): if ldwork is None: ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)) if equil == 'S': - ldwork = max(l+p, m+n) * (m+n) + max (1, 5 * max (l+p, m+n)) + ldwork = max(4*(l+n), ldw) else: #equil == 'N' ldwork = ldw From 3edd2c97a8acc20ec6b4bc54e797eee2373252ff Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Tue, 17 Jul 2018 18:37:16 +0200 Subject: [PATCH 021/405] sb10jd, tg01fd Correct some spelling and alignments --- slycot/synthesis.py | 4 ++-- slycot/transform.py | 16 ++++++++-------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index c0653f0c..2c0e442f 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1840,12 +1840,12 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): return out[:-1] def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): - """ A,B,C,D = sl10jd(n,m,np,A,B,C,D,E,[ldwork]) + """ A,B,C,D = sb10jd(n,m,np,A,B,C,D,E,[ldwork]) To convert the descriptor state-space system E*dx/dt = A*x + B*u - y = C*x + D*u + y = C*x + D*u into regular state-space form diff --git a/slycot/transform.py b/slycot/transform.py index 3d39f0a7..f3731893 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1058,16 +1058,16 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in a SVD-like coordinate form with - ( A11 A12 ) ( Er 0 ) + ( A11 A12 ) ( Er 0 ) Q'*A*Z = ( ) , Q'*E*Z = ( ) , - ( A21 A22 ) ( 0 0 ) + ( A21 A22 ) ( 0 0 ) where Er is an upper triangular invertible matrix. Optionally, the A22 matrix can be further reduced to the form - ( Ar X ) + ( Ar X ) A22 = ( ) , - ( 0 0 ) + ( 0 0 ) with Ar an upper triangular invertible matrix, and X either a full or a zero matrix. @@ -1149,9 +1149,9 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix is in the form - ( A11 * * ) + ( A11 * * ) Q'*A*Z = ( * Ar X ) , - ( * 0 0 ) + ( * 0 0 ) where A11 is a RANKE-by-RANKE matrix and Ar is a RNKA22-by-RNKA22 invertible upper triangular matrix. @@ -1160,9 +1160,9 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld The leading L-by-N part of this array contains the transformed matrix Q'*E*Z. - ( Er 0 ) + ( Er 0 ) Q'*E*Z = ( ) , - ( 0 0 ) + ( 0 0 ) where Er is a RANKE-by-RANKE upper triangular invertible matrix. From 34b33690ead74f159546f45b40daf86b8c22ad3b Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Wed, 18 Jul 2018 21:08:52 +0200 Subject: [PATCH 022/405] add tests for tg01fd --- slycot/tests/test_tg01fd.py | 113 ++++++++++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 slycot/tests/test_tg01fd.py diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py new file mode 100644 index 00000000..2bec5ed7 --- /dev/null +++ b/slycot/tests/test_tg01fd.py @@ -0,0 +1,113 @@ +# =================================================== +# tg01fd tests + +import unittest +from slycot import transform +import numpy as np + +from numpy.testing import assert_raises, assert_almost_equal, assert_equal + +# test1 input parameters +test1_l = 4 +test1_n = 4 +test1_m = 2 +test1_p = 2 +test1_tol = 0.0 +test1_A = np.array([[-1, 0, 0, 3], + [ 0, 0, 1, 2], + [ 1, 1, 0, 4], + [ 0, 0, 0, 0]]) + +test1_E = np.array([[1, 2, 0, 0], + [0, 1, 0, 1], + [3, 9, 6, 3], + [0, 0, 2, 0]]) + +test1_B = np.array([[1, 0], + [0, 0], + [0, 1], + [1, 1]]) + +test1_C = np.array([[-1, 0, 1, 0], + [ 0, 1, -1, 1]]) + +#test1 expected output +test1_Aexp = np.array([[ 2.02781052, 0.10783277, 3.90616686, -2.15710472], + [-0.09804588, 0.25437761, 1.60529591, -0.12692683], + [ 0.27131089, 0.77603837, -0.36920735, -0.48533567], + [ 0.06900656, -0.56694671, -2.19740106, 0.3086067 ]]) + +test1_Eexp = np.array([[10.15874008, 5.82296975, 1.30205562, 0. ], + [ 0. , -2.468405 , -0.18960188, 0. ], + [ 0. , 0. , 1.03378058, 0. ], + [ 0. , 0. , 0. , 0. ]]) + +test1_Bexp = np.array([[-0.21566555, -0.97049496], + [ 0.30148458, 0.95156071], + [ 0.75952691, 0.09906873], + [ 1.13389342, 0.37796447]]) + +test1_Cexp = np.array([[ 3.65148372e-01, -1.00000000e+00, -4.47213595e-01, -8.16496581e-01], + [-1.09544512e+00, 1.00000000e+00, -8.94427191e-01, 2.22044605e-16]]) + +test1_Qexp = np.array([[-0.21566555, -0.50875523, 0.61092382, 0.56694671], + [-0.10783277, -0.25437761, -0.77603837, 0.56694671], + [-0.97049496, 0.1413209 , -0.04953436, -0.18898224], + [ 0. , 0.81023981, 0.14860309, 0.56694671]]) +test1_Zexp = np.array([[-3.65148372e-01, -1.35772740e-16, 4.47213595e-01, 8.16496581e-01], + [-9.12870929e-01, 0.00000000e+00, 0.00000000e+00, -4.08248290e-01], + [ 6.19714937e-17, -1.00000000e+00, 0.00000000e+00, -1.38572473e-16], + [-1.82574186e-01, -6.78863700e-17, -8.94427191e-01, 4.08248290e-01]]) + +test1_ranke_exp = 3 +test1_rnka22_exp = 1 + +class test_tg01fd(unittest.TestCase): + + def test1_tg01fd(self): + """ test1: Verify from tg01fd with input parameters according to test in documentation """ + A,E,B,C,ranke,rnka22,Q,Z = transform.tg01fd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,compq='I',compz='I',joba='T',tol=test1_tol) + assert_almost_equal(A, test1_Aexp) + assert_almost_equal(E, test1_Eexp) + assert_almost_equal(B, test1_Bexp) + assert_almost_equal(C, test1_Cexp) + assert_almost_equal(Q, test1_Qexp) + assert_almost_equal(Z, test1_Zexp) + assert_equal(test1_ranke_exp, ranke) + assert_equal(test1_rnka22_exp, rnka22) + + def test2_tg01fd(self): + """ verify that Q and Z output with compq and compz set to 'U' equals the dot product of Q and Z input and Q and Z output with compq and compz set to 'I' """ + + l = 30 + n = 30 + m = 70 + p = 44 + + Ain = np.random.rand(l, n) + Ein = np.random.rand(l, n) + Bin = np.random.rand(n, m) + Cin = np.random.rand(p, n) + Qin = np.random.randn(l,l) + Zin = np.random.randn(n,n) + + A_1,E_1,B_1,C_1,ranke_1,rnka22_1,Q_1,Z_1= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,compq='I', compz='I', joba='T', tol=0.0) + + A_2,E_2,B_2,C_2,ranke_2,rnka22_2,Q_2,Z_2= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,Q=Qin,Z=Zin,compq='U', compz='U', joba='T', tol=0.0) + + assert_equal(A_1, A_2) + assert_equal(E_1, E_2) + assert_equal(B_1, B_2) + assert_equal(C_1, C_2) + assert_equal(ranke_1, ranke_2) + assert_equal(rnka22_1, rnka22_2) + + assert_almost_equal(Qin @ Q_1, Q_2) + assert_almost_equal(Zin @ Z_1, Z_2) + +def suite(): + return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + + +if __name__ == "__main__": + unittest.main() \ No newline at end of file From 4dc5451b38170f8b1b052b9f83cd9db9b520bc36 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Thu, 19 Jul 2018 08:23:15 +0200 Subject: [PATCH 023/405] test_tg01fd.py: make python2.7 compatibale and add a seed before creating random arrays --- slycot/tests/test_tg01fd.py | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py index 2bec5ed7..bc8fe2cb 100644 --- a/slycot/tests/test_tg01fd.py +++ b/slycot/tests/test_tg01fd.py @@ -84,6 +84,8 @@ def test2_tg01fd(self): m = 70 p = 44 + np.random.seed(0) + Ain = np.random.rand(l, n) Ein = np.random.rand(l, n) Bin = np.random.rand(n, m) @@ -102,12 +104,12 @@ def test2_tg01fd(self): assert_equal(ranke_1, ranke_2) assert_equal(rnka22_1, rnka22_2) - assert_almost_equal(Qin @ Q_1, Q_2) - assert_almost_equal(Zin @ Z_1, Z_2) + assert_almost_equal(np.dot(Qin, Q_1), Q_2) + assert_almost_equal(np.dot(Zin, Z_1), Z_2) def suite(): return unittest.TestLoader().loadTestsFromTestCase(TestConvert) if __name__ == "__main__": - unittest.main() \ No newline at end of file + unittest.main() From fb04bd6ecb420b9e3d049fdb5e3dda0071f5d9f9 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Thu, 19 Jul 2018 20:30:48 +0200 Subject: [PATCH 024/405] correct documentation and spaces --- slycot/analysis.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index d446970e..eb18f35e 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1572,7 +1572,7 @@ def ab13fd(n, A, tol = 0.0): raise RuntimeError("unknown error code %r" % out[-1]) def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): - """ Af,Ef,nrank,infz,kronr,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) + """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) To extract from the system pencil @@ -1682,6 +1682,6 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): e.info = info raise e - return Af[:nfz,:nfz],Ef[:nfz,:nfz],nrank,niz,infz[:dinfz],kronr[:nkror],infe[:ninfe], kronl[:nkrol] + return Af[:nfz,:nfz],Ef[:nfz,:nfz],nrank,niz,infz[:dinfz],kronr[:nkror],infe[:ninfe],kronl[:nkrol] # to be replaced by python wrappers From 1b2c5b1f85bcdd1b7d2c12c15960519e04fb2947 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Thu, 19 Jul 2018 20:30:58 +0200 Subject: [PATCH 025/405] add ag08bd tests --- slycot/tests/test_ag08bd.py | 118 ++++++++++++++++++++++++++++++++++++ 1 file changed, 118 insertions(+) create mode 100644 slycot/tests/test_ag08bd.py diff --git a/slycot/tests/test_ag08bd.py b/slycot/tests/test_ag08bd.py new file mode 100644 index 00000000..f1101765 --- /dev/null +++ b/slycot/tests/test_ag08bd.py @@ -0,0 +1,118 @@ +# =================================================== +# ag08bd tests + +import unittest +from slycot import analysis +import numpy as np + +from numpy.testing import assert_raises, assert_almost_equal, assert_equal + +# test1 input parameters + +test1_l = 9 +test1_n = 9 +test1_m = 3 +test1_p = 3 +test1_tol = 1.0e-7 +test1_equil = 'N' + +test1_A = np.eye(9, dtype=int) + +test1_E = np.array([[0, 0, 0, 0, 0, 0, 0, 0, 0], + [1, 0, 0, 0, 0, 0, 0, 0, 0], + [0, 1, 0, 0, 0, 0, 0, 0, 0], + [0, 0, 0, 0, 0, 0, 0, 0, 0], + [0, 0, 0, 1, 0, 0, 0, 0, 0], + [0, 0, 0, 0, 1, 0, 0, 0, 0], + [0, 0, 0, 0, 0, 0, 0, 0, 0], + [0, 0, 0, 0, 0, 0, 1, 0, 0], + [0, 0, 0, 0, 0, 0, 0, 1, 0]]) + +test1_B = np.array([[-1, 0, 0], + [ 0, 0, 0], + [ 0, 0, 0], + [ 0, -1, 0], + [ 0, 0, 0], + [ 0, 0, 0], + [ 0, 0, -1], + [ 0, 0, 0], + [ 0, 0, 0]]) + +test1_C = np.array([[ 0, 1, 1, 0, 3, 4, 0, 0, 2], + [ 0, 1, 0, 0, 4, 0, 0, 2, 0], + [ 0, 0, 1, 0, -1, 4, 0, -2, 2]]) + +test1_D = np.array([[ 1, 2, -2], + [ 0, -1, -2], + [ 0, 0, 0]]) + + +class test_tg01fd(unittest.TestCase): + """ test1 to 4: Verify ag08bd with input parameters according to example in documentation """ + + def test1_ag08bd(self): + #test [A-lambda*E] + #B,C,D must have correct dimensions according to l,n,m and p, but cannot have zero length in any dimenstion. Then the wrapper will complain. The length is then set to one. + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=0,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=np.zeros((1,test1_n)),D=np.zeros((1,1)),equil=test1_equil, tol=test1_tol) + + assert_equal(Af, np.zeros((0,0))) + assert_equal(Ef, np.zeros((0,0))) + assert_equal(nrank, 9) + assert_equal(niz, 6) + assert_equal(infz, [0,3]) + assert_equal(kronr, []) + assert_equal(infe, [3,3,3]) + assert_equal(kronl, []) + + def test2_ag08bd(self): + #test [A-lambda*E;C] + #B,D must have correct dimensions as before + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=test1_p,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=test1_C,D=np.zeros((test1_p,1)),equil=test1_equil, tol=test1_tol) + + assert_equal(Af, np.zeros((0,0))) + assert_equal(Ef, np.zeros((0,0))) + assert_equal(nrank, 9) + assert_equal(niz, 4) + assert_equal(infz, [0,2]) + assert_equal(kronr, []) + assert_equal(infe, [1,3,3]) + assert_equal(kronl, [0,1,1]) + + def test3_ag08bd(self): + #test [A-lambda*E,B] + #C,D must have correct dimensions as before + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=0,A=test1_A,E=test1_E,B=test1_B,C=np.zeros((1,test1_n)),D=np.zeros((1,test1_m)),equil=test1_equil, tol=test1_tol) + + assert_equal(Af, np.zeros((0,0))) + assert_equal(Ef, np.zeros((0,0))) + assert_equal(nrank, 9) + assert_equal(niz, 0) + assert_equal(infz, []) + assert_equal(kronr, [2,2,2]) + assert_equal(infe, [1,1,1]) + assert_equal(kronl, []) + + def test4_ag08bd(self): + #test [A-lambda*E,B;C,D] + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,D=test1_D,equil=test1_equil, tol=test1_tol) + + assert_almost_equal(Af, [[0.77045021]]) + assert_almost_equal(Ef, [[0.77045021]]) + assert_equal(nrank, 11) + assert_equal(niz, 2) + assert_equal(infz, [0,1]) + assert_equal(kronr, [2]) + assert_equal(infe, [1,1,1,1,3]) + assert_equal(kronl, [1]) + + +def suite(): + return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + + +if __name__ == "__main__": + unittest.main() From b804b92f71a22a4b477842877a6261e7ceb2a467 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Thu, 19 Jul 2018 20:48:17 +0200 Subject: [PATCH 026/405] add test for sb10jd --- slycot/tests/test_sb10jd.py | 71 +++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 slycot/tests/test_sb10jd.py diff --git a/slycot/tests/test_sb10jd.py b/slycot/tests/test_sb10jd.py new file mode 100644 index 00000000..8a1bfbb7 --- /dev/null +++ b/slycot/tests/test_sb10jd.py @@ -0,0 +1,71 @@ +# =================================================== +# sb10jd tests + +import unittest +from slycot import synthesis +import numpy as np +from numpy.testing import assert_raises, assert_almost_equal, assert_equal + +# test1 input parameters + +test1_n = 6 +test1_m = 1 +test1_np = 6 + +test1_A = np.array([[ 0, 0, 0, -1, 1, 0], + [ 0, 32, 0, 0, -1, 1], + [ 0, 0, 1, 0, 0, 0], + [ 0, 0, 0, 1, 0, 0], + [-1, 1, 0, 0, 0, 0], + [ 0, -1, 1, 0, 0, 0]]) + + +test1_E = np.array([[ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, -10, 0, 10], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0]]) + +test1_B = np.array([[-7.1], + [ 0. ], + [ 0. ], + [ 0. ], + [ 0. ], + [ 0. ]]) + +test1_C = np.eye(6) + +test1_D = np.zeros((7,1)) + +# test1 expected results +test1_Aexp = np.array([[-0.003125]]) +test1_Bexp = np.array([[0.05899985]]) +test1_Cexp = np.array([[-1.17518847e-02], + [-1.17518847e-02], + [-1.17518847e-02], + [ 5.90449456e-17], + [ 1.47612364e-16], + [ 3.76060309e-01]]) +test1_Dexp = np.array([[2.2187500e-01], + [2.2187500e-01], + [2.2187500e-01], + [0.0000000e+00], + [7.1000000e+00], + [4.4408921e-16]]) + +class test_sb10jd(unittest.TestCase): + def test1_sb10jd(self): + """ verify the output of sb10jd for a descriptor system """ + A,B,C,D = synthesis.sb10jd(test1_n,test1_m,test1_np,test1_A,test1_B,test1_C,test1_D,test1_E) + assert_almost_equal(A, test1_Aexp) + assert_almost_equal(B, test1_Bexp) + assert_almost_equal(C, test1_Cexp) + assert_almost_equal(D, test1_Dexp) + +def suite(): + return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + + +if __name__ == "__main__": + unittest.main() \ No newline at end of file From 40ccf9142711a9c85739621c85e112fd20acd711 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Thu, 19 Jul 2018 20:51:47 +0200 Subject: [PATCH 027/405] test_sb10jd: round some low numbers --- slycot/tests/test_sb10jd.py | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/slycot/tests/test_sb10jd.py b/slycot/tests/test_sb10jd.py index 8a1bfbb7..c252dcee 100644 --- a/slycot/tests/test_sb10jd.py +++ b/slycot/tests/test_sb10jd.py @@ -39,20 +39,21 @@ test1_D = np.zeros((7,1)) # test1 expected results -test1_Aexp = np.array([[-0.003125]]) -test1_Bexp = np.array([[0.05899985]]) -test1_Cexp = np.array([[-1.17518847e-02], + +test1_Aexp = np.array([[-0.00312500]]) +test1_Bexp = np.array([[ 0.05899985]]) +test1_Cexp = np.array([[-1.17518847e-02], [-1.17518847e-02], [-1.17518847e-02], - [ 5.90449456e-17], - [ 1.47612364e-16], + [ 0.00000000e+00], + [ 0.00000000e+00], [ 3.76060309e-01]]) -test1_Dexp = np.array([[2.2187500e-01], - [2.2187500e-01], - [2.2187500e-01], - [0.0000000e+00], - [7.1000000e+00], - [4.4408921e-16]]) +test1_Dexp = np.array([[ 2.21875000e-01], + [ 2.21875000e-01], + [ 2.21875000e-01], + [ 0.00000000e+00], + [ 7.10000000e+00], + [ 0.00000000e+00]]) class test_sb10jd(unittest.TestCase): def test1_sb10jd(self): @@ -68,4 +69,4 @@ def suite(): if __name__ == "__main__": - unittest.main() \ No newline at end of file + unittest.main() From dcbee80ff7ab80cc68749ed60b3cd8536032f134 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Sun, 22 Jul 2018 23:24:05 +0200 Subject: [PATCH 028/405] change ld*=shape(*,0) to ld*=MAX(shape(*,0),1) for ag08bd, sb10jd and tg01fd --- slycot/src/analysis.pyf | 12 ++++++------ slycot/src/synthesis.pyf | 10 +++++----- slycot/src/transform.pyf | 32 ++++++++++++++++---------------- 3 files changed, 27 insertions(+), 27 deletions(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 227fbe98..58a0656b 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -393,15 +393,15 @@ subroutine ag08bd(equil,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,d,ldd,nfz,nrank,niz,dinf integer intent(in),required,check(m>=0) :: m integer intent(in),required,check(p>=0) :: p double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e - integer intent(hide),depend(e) :: lde=shape(e,0) + integer intent(hide),depend(e) :: lde=MAX(shape(e,0),1) double precision intent(in,copy),dimension(l,m),depend(l,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) + integer intent(hide),depend(b) :: ldb=MAX(shape(b,0),1) double precision intent(in,copy),dimension(p,n),depend(p,n) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) + integer intent(hide),depend(c) :: ldc=MAX(shape(c,0),1) double precision intent(in,copy),dimension(p,m),depend(p,m) :: d - integer intent(hide),depend(d) :: ldd=shape(d,0) + integer intent(hide),depend(d) :: ldd=MAX(shape(d,0),1) integer intent(out) :: nfz integer intent(out) :: nrank integer intent(out) :: niz @@ -418,4 +418,4 @@ subroutine ag08bd(equil,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,d,ldd,nfz,nrank,niz,dinf double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork integer required intent(in) :: ldwork integer intent(out) :: info -end subroutine ag08bd \ No newline at end of file +end subroutine ag08bd diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index a94cec3a..56e53721 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -530,15 +530,15 @@ subroutine sb10jd(n,m,np,a,lda,b,ldb,c,ldc,d,ldd,e,lde,nsys,dwork,ldwork,info) ! integer intent(in),required :: m integer intent(in),required :: np double precision intent(in,out,copy),dimension(lda,n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) double precision intent(in,out,copy),dimension(ldb,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) + integer intent(hide),depend(b) :: ldb=MAX(shape(b,0),1) double precision intent(in,out,copy),dimension(ldc,n) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) + integer intent(hide),depend(c) :: ldc=MAX(shape(c,0),1) double precision intent(in,out,copy),dimension(ldd,m) :: d - integer intent(hide),depend(d) :: ldd=shape(d,0) + integer intent(hide),depend(d) :: ldd=MAX(shape(d,0),1) double precision intent(in,copy),dimension(lde,n) :: e - integer intent(hide),depend(e) :: lde=shape(e,0) + integer intent(hide),depend(e) :: lde=MAX(shape(e,0),1) integer intent(out) :: nsys double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork integer required intent(in) :: ldwork diff --git a/slycot/src/transform.pyf b/slycot/src/transform.pyf index ae59862b..48c6d44f 100644 --- a/slycot/src/transform.pyf +++ b/slycot/src/transform.pyf @@ -431,13 +431,13 @@ subroutine tg01fd_nn(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ld integer intent(in),required,check(m>=0) :: m integer intent(in),required,check(p>=0) :: p double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e - integer intent(hide),depend(e) :: lde=shape(e,0) + integer intent(hide),depend(e) :: lde=MAX(shape(e,0),1) double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) + integer intent(hide),depend(b) :: ldb=MAX(shape(b,0),1) double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) + integer intent(hide),depend(c) :: ldc=MAX(shape(c,0),1) double precision intent(hide),dimension(0,0) :: q integer intent(hide),depend(q) :: ldq=1 double precision intent(hide),dimension(0,0) :: z @@ -460,17 +460,17 @@ subroutine tg01fd_ii(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ld integer intent(in),required,check(m>=0) :: m integer intent(in),required,check(p>=0) :: p double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e - integer intent(hide),depend(e) :: lde=shape(e,0) + integer intent(hide),depend(e) :: lde=MAX(shape(e,0),1) double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) + integer intent(hide),depend(b) :: ldb=MAX(shape(b,0),1) double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) + integer intent(hide),depend(c) :: ldc=MAX(shape(c,0),1) double precision intent(out),dimension(l,l) :: q - integer intent(hide),depend(q) :: ldq=shape(q,0) + integer intent(hide),depend(q) :: ldq=MAX(shape(q,0),1) double precision intent(out),dimension(n,n) :: z - integer intent(hide),depend(z) :: ldz=shape(z,0) + integer intent(hide),depend(z) :: ldz=MAX(shape(z,0),1) integer intent(out) :: ranke integer intent(out) :: rnka22 double precision intent(in) :: tol @@ -489,17 +489,17 @@ subroutine tg01fd_uu(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ld integer intent(in),required,check(m>=0) :: m integer intent(in),required,check(p>=0) :: p double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e - integer intent(hide),depend(e) :: lde=shape(e,0) + integer intent(hide),depend(e) :: lde=MAX(shape(e,0),1) double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) + integer intent(hide),depend(b) :: ldb=MAX(shape(b,0),1) double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) + integer intent(hide),depend(c) :: ldc=MAX(shape(c,0),1) double precision intent(in,out,copy),dimension(l,l) :: q - integer intent(hide),depend(q) :: ldq=shape(q,0) + integer intent(hide),depend(q) :: ldq=MAX(shape(q,0),1) double precision intent(in,out,copy),dimension(n,n) :: z - integer intent(hide),depend(z) :: ldz=shape(z,0) + integer intent(hide),depend(z) :: ldz=MAX(shape(z,0),1) integer intent(out) :: ranke integer intent(out) :: rnka22 double precision intent(in) :: tol From d8b90a34619eec4256477f3daddbcccc42ad4d97 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Tue, 31 Jul 2018 11:13:22 +0200 Subject: [PATCH 029/405] add support for tg01ad --- slycot/src/transform.pyf | 20 +++++++ slycot/tests/test_tg01ad.py | 89 +++++++++++++++++++++++++++++ slycot/transform.py | 108 ++++++++++++++++++++++++++++++++++++ 3 files changed, 217 insertions(+) create mode 100644 slycot/tests/test_tg01ad.py diff --git a/slycot/src/transform.pyf b/slycot/src/transform.pyf index 48c6d44f..dc7277b1 100644 --- a/slycot/src/transform.pyf +++ b/slycot/src/transform.pyf @@ -421,6 +421,26 @@ subroutine tb01pd(job,equil,n,m,p,a,lda,b,ldb,c,ldc,nr,tol,iwork,dwork,ldwork,in integer optional,depend(n,m,p) :: ldwork=max(1,n+max(n,max(3*m,3*p))) integer intent(out) :: info end subroutine tb01pd +subroutine tg01ad(job,l,n,m,p,thresh,a,lda,e,lde,b,ldb,c,ldc,lscale,rscale,dwork,info) ! in TG01AD.f + character :: job + integer intent(in),required,check(l>=0) :: l + integer intent(in),required,check(n>=0) :: n + integer intent(in),required,check(m>=0) :: m + integer intent(in),required,check(p>=0) :: p + double precision intent(in),required,check(thresh>=0) :: thresh + double precision intent(in,out,copy),dimension(l,n),depend(l,n) :: a + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) + double precision intent(in,out,copy),dimension(l,n),depend(l,m) :: e + integer intent(hide),depend(e) :: lde=MAX(shape(e,0),1) + double precision intent(in,out,copy),dimension(l,m),depend(l,m) :: b + integer intent(hide),depend(b) :: ldb=MAX(shape(b,0),1) + double precision intent(in,out,copy),dimension(p,n),depend(p,n) :: c + integer intent(hide),depend(c) :: ldc=MAX(shape(c,0),1) + double precision intent(out),dimension(l) :: lscale + double precision intent(out),dimension(n) :: rscale + double precision intent(cache,hide),dimension(3*(l+n)) :: dwork + integer intent(out) :: info +end subroutine tg01ad subroutine tg01fd_nn(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ldz,ranke,rnka22,tol,iwork,dwork,ldwork,info) ! in TG01FD.f fortranname tg01fd character intent(hide) :: compq = 'N' diff --git a/slycot/tests/test_tg01ad.py b/slycot/tests/test_tg01ad.py new file mode 100644 index 00000000..458fa87d --- /dev/null +++ b/slycot/tests/test_tg01ad.py @@ -0,0 +1,89 @@ +# =================================================== +# tg01ad tests + +import unittest +from slycot import transform +import numpy as np + +from numpy.testing import assert_raises, assert_almost_equal, assert_equal + +# test1 input parameters + +test1_l = 4 +test1_n = 4 +test1_m = 2 +test1_p = 2 +test1_job = 'A' +test1_thresh = 0.0 + +test1_A = \ + np.array([[-1.0, 0.0, 0.0, 3e-3 ], + [ 0.0, 0.0, 0.1, 2e-2 ], + [ 1e2, 10.0, 0.0, 0.4 ], + [ 0.0, 0.0, 0.0, 0.0 ]]) + +test1_E = \ + np.array([[ 1.0, 0.2, 0.0, 0.0 ], + [ 0.0, 1.0, 0.0, 1e-2 ], + [ 3e2, 90.0, 6.0, 0.3 ], + [ 0.0, 0.0, 20.0, 0.0 ]]) + +test1_B = \ + np.array([[ 10.0, 0.0 ], + [ 0.0, 0.0 ], + [ 0.0, 1e3 ], + [ 1e4, 1e4 ]]) + +test1_C = \ + np.array([[-0.1, 0.0, 1e-3, 0.0 ], + [ 0.0, 1e-2, -1e-3, 1e-4 ]]) + +test1_A_desired = \ + np.array([[-1.0, 0.0, 0.0, 0.3 ], + [ 0.0, 0.0, 1.0, 2.0 ], + [ 1.0, 0.1, 0.0, 0.4 ], + [ 0.0, 0.0, 0.0, 0.0 ]]) + +test1_E_desired = \ + np.array([[ 1.0, 0.2, 0.0, 0.0 ], + [ 0.0, 1.0, 0.0, 1.0 ], + [ 3.0, 0.9, 0.6, 0.3 ], + [ 0.0, 0.0, 0.2, 0.0 ]]) + +test1_B_desired = \ + np.array([[ 1e2, 0.0 ], + [ 0.0, 0.0 ], + [ 0.0, 1e2 ], + [ 1e2, 1e2 ]]) + +test1_C_desired = \ + np.array([[-1e-2, 0.0, 1e-3, 0.0 ], + [ 0.0, 1e-3, -1e-3, 1e-3 ]]) + +test1_lscale_desired = \ + np.array([ 10.0, 10.0, 0.1, 1e-2 ]) + +test1_rscale_desired = \ + np.array([ 0.1, 0.1, 1.0, 10.0 ]) + +class test_tg01ad(unittest.TestCase): + """ test1: Verify tg01ad with input parameters according to example in documentation """ + + def test1_tg01add(self): + + A,E,B,C,lscale,rscale = transform.tg01ad(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,job=test1_job, thresh=test1_thresh) + + assert_almost_equal(A, test1_A_desired) + assert_almost_equal(E, test1_E_desired) + assert_almost_equal(B, test1_B_desired) + assert_almost_equal(C, test1_C_desired) + assert_almost_equal(lscale, test1_lscale_desired) + assert_almost_equal(rscale, test1_rscale_desired) + + +def suite(): + return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + + +if __name__ == "__main__": + unittest.main() diff --git a/slycot/transform.py b/slycot/transform.py index f3731893..13c23892 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1050,6 +1050,114 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): raise e return out[:-1] +def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): + """ A,E,B,C,lscale,rscale = tg01ad(l,n,m,p,A,E,B,C,[thresh,job]) + + To balance the matrices of the system pencil + + S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, + ( C 0 ) ( 0 0 ) + + corresponding to the descriptor triple (A-lambda E,B,C), + by balancing. This involves diagonal similarity transformations + (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system + (A-lambda E,B,C) to make the rows and columns of system pencil + matrices + + diag(Dl,I) * S * diag(Dr,I) + + as close in norm as possible. Balancing may reduce the 1-norms + of the matrices of the system pencil S. + + The balancing can be performed optionally on the following + particular system pencils + + S = A-lambda E, + + S = ( A-lambda E B ), or + + S = ( A-lambda E ). + ( C ) + Required arguments: + l : input int + The number of rows of matrices A, B, and E. l >= 0. + n : input int + The number of columns of matrices A, E, and C. n >= 0. + m : input int + The number of columns of matrix B. m >= 0. + p : input int + The number of rows of matrix C. P >= 0. + A : rank-2 array('d') with bounds (l,n) + The leading L-by-N part of this array must + contain the state dynamics matrix A. + E : rank-2 array('d') with bounds (l,n) + The leading L-by-N part of this array must + contain the descriptor matrix E. + B : rank-2 array('d') with bounds (l,m) + The leading L-by-M part of this array must + contain the input/state matrix B. + The array B is not referenced if M = 0. + C : rank-2 array('d') with bounds (p,n) + The leading P-by-N part of this array must + contain the state/output matrix C. + The array C is not referenced if P = 0. + Optional arguments: + job := 'A' input string(len=1) + Indicates which matrices are involved in balancing, as + follows: + = 'A': All matrices are involved in balancing; + = 'B': B, A and E matrices are involved in balancing; + = 'C': C, A and E matrices are involved in balancing; + = 'N': B and C matrices are not involved in balancing. + thresh := 0.0 input float + Threshold value for magnitude of elements: + elements with magnitude less than or equal to + THRESH are ignored for balancing. THRESH >= 0. + Return objects: + A : rank-2 array('d') with bounds (l,n) + The leading L-by-N part of this array contains + the balanced matrix Dl*A*Dr. + E : rank-2 array('d') with bounds (l,n) + The leading L-by-N part of this array contains + the balanced matrix Dl*E*Dr. + B : rank-2 array('d') with bounds (l,m) + If M > 0, the leading L-by-M part of this array + contains the balanced matrix Dl*B. + The array B is not referenced if M = 0. + C : rank-2 array('d') with bounds (p,n) + If P > 0, the leading P-by-N part of this array + contains the balanced matrix C*Dr. + The array C is not referenced if P = 0. + lscale : rank-1 array('d') with bounds (l) + The scaling factors applied to S from left. If Dl(j) is + the scaling factor applied to row j, then + SCALE(j) = Dl(j), for j = 1,...,L. + rscale : rank-1 array('d') with bounds (n) + The scaling factors applied to S from right. If Dr(j) is + the scaling factor applied to column j, then + SCALE(j) = Dr(j), for j = 1,...,N. + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['job', 'l', 'n', 'm', 'p', 'thresh', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden, 'lscale', 'rscale', 'dwork'+hidden, 'info'] + + if job != 'A' and job != 'B' and job != 'C': + raise ValueError('Parameter job had an illegal value') + + A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) + + if info < 0: + error_text = "The following argument had an illegal value: "+arg_list[-info-1] + e = ValueError(error_text) + e.info = info + raise e + if info != 0: + e = ArithmeticError('tg01ad failed') + e.info = info + raise e + + return A,E,B,C,lscale,rscale + def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): """ A,E,B,C,ranke,rnka22,Q,Z = tg01fd(l,n,m,p,A,E,B,C,[Q,Z,compq,compz,joba,tol,ldwork]) From bdd767d324e36a1e0248856588ab7403ba1045c6 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Tue, 31 Jul 2018 21:12:51 +0200 Subject: [PATCH 030/405] test_tg01ad: correct spelling --- slycot/tests/test_tg01ad.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/tests/test_tg01ad.py b/slycot/tests/test_tg01ad.py index 458fa87d..2ad78f7f 100644 --- a/slycot/tests/test_tg01ad.py +++ b/slycot/tests/test_tg01ad.py @@ -69,7 +69,7 @@ class test_tg01ad(unittest.TestCase): """ test1: Verify tg01ad with input parameters according to example in documentation """ - def test1_tg01add(self): + def test1_tg01ad(self): A,E,B,C,lscale,rscale = transform.tg01ad(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,job=test1_job, thresh=test1_thresh) From 3de678358bfc472e3340328cf57a5d7963c25d17 Mon Sep 17 00:00:00 2001 From: Marcus Liljedahl Date: Fri, 3 Aug 2018 09:12:41 +0200 Subject: [PATCH 031/405] tg01ad: paramter 'job' can have value of 'N' --- slycot/transform.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/transform.py b/slycot/transform.py index 13c23892..80a1d79d 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1141,7 +1141,7 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): hidden = ' (hidden by the wrapper)' arg_list = ['job', 'l', 'n', 'm', 'p', 'thresh', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden, 'lscale', 'rscale', 'dwork'+hidden, 'info'] - if job != 'A' and job != 'B' and job != 'C': + if job != 'A' and job != 'B' and job != 'C' and job != 'N': raise ValueError('Parameter job had an illegal value') A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) From 8c528a3c08afe807adf7ec6faf66dc065cfcf393 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 21 Aug 2018 14:17:29 +0200 Subject: [PATCH 032/405] Using scikit-build as buildsystem --- .travis.yml | 11 +++-- conda-recipe-openblas/bld.bat | 81 +++++++++++++++++++++++++++++++-- conda-recipe-openblas/build.sh | 20 ++++++++ conda-recipe-openblas/meta.yaml | 26 ++++++++--- conda-recipe/bld.bat | 7 +++ conda-recipe/build.sh | 6 ++- conda-recipe/meta.yaml | 26 ++++++++--- setup.py | 65 +++++++++++++------------- slycot/version.py.in | 12 +++-- 9 files changed, 195 insertions(+), 59 deletions(-) diff --git a/.travis.yml b/.travis.yml index ca454932..a436e2f2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -19,6 +19,7 @@ before_install: - if [[ $TEST_CONDA == 0 ]]; then sudo apt-get install liblapack-dev libblas-dev; sudo apt-get install gfortran; + sudo apt-get install cmake; fi install: @@ -46,6 +47,11 @@ install: # Make sure that fortran compiler can find conda libraries # - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; + + # pip install scikit-build, one in conda repos is currently too old + - if [[ $TEST_CONDA == 0 ]]; then + pip install https://github.com/scikit-build/scikit-build/archive/0.7.1.zip; + fi # # Install the slycot package (two ways, to improve robustness). For the # conda version, need to install lapack from conda-forge (no way to specify @@ -56,11 +62,10 @@ install: # - if [[ $TEST_CONDA == 1 ]]; then conda config --append channels conda-forge; - conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe; - conda install -c conda-forge lapack; + conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe-openblas; conda install --override-channels -c local slycot; else - LAPACKLIBS=lapack:blas python setup.py install; + python setup.py install; fi # # coveralls not in conda repos :-( diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index c5294765..7f8ff7d9 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -2,16 +2,89 @@ cd %RECIPE_DIR% cd .. -set F77=%BUILD_PREFIX%\Library\bin\flang.exe -set F90=%BUILD_PREFIX%\Library\bin\flang.exe +:: until scikit-build on conda-forge is updated to 0.6.1 or higher ... +"%PYTHON%" -m pip install "https://github.com/scikit-build/scikit-build/archive/0.7.1.zip" + +:: indicating fortran compiler is essential +set FC=%BUILD_PREFIX%\Library\bin\flang.exe + +:: The batch file created by conda-build sets a load of environment variables +:: Building worked fine without conda; apparently one or more of these +:: variables produce test & link failures. Resetting most of these here +set ARCH= +set BUILD= +set BUILD_PREFIX= +set CMAKE_GENERATOR= +set CommandPromptType= +set CPU_COUNT= +set DISTUTILS_USE_SDK= +set folder= +set cpu_optimization_target= +set fortran_compiler= +set Framework40Version= +set FrameworkDir= +set FrameworkDIR64= +set FrameworkVersion= +set FrameworkVersion64= +set ignore_build_only_deps= +set CFLAGS= +set CXXFLAGS= +set cxx_compiler= +set c_compiler= +set INCLUDE= +set LDFLAGS_SHARED= +set LIBPATH= +set LIB=;%LIB% +set MSSdk= +set MSYS2_ARG_CONV_EXCL= +set MSYS2_ENV_CONV_EXCL= +set NETFSXDIR= +set PIP_IGNORE_INSTALLED= +set platform= +set WindowsLibPath= +set WindowsSdkDir= +set CYGWIN_PREFIX= +set SRC_DIR= +set STDLIB_DIR= +set SUBDIR= +set SYS_PREFIX= +set target_platform= +set UCRTVersion= +set UniversalCRTSdkDir= +set VCINSTALLDIR= +set vc= +set win= +set VisualStudioVersion= +set VSINSTALLDIR= +set VSREGKEY= +set VS_MAJOR= +set VS_VERSION= +set VS_YEAR= +set WindowsSDKLibVersion= +set WindowsSDKVersion= +set WindowsSDKExecutablePath_x64= +set WindowsSDKExecutablePath_x86= + +:: information on remaining variables +set + +set BLAS_ROOT=%CONDA_PREFIX% +set LAPACK_ROOT=%CONDA_PREFIX% -"%PYTHON%" setup.py build "%PYTHON%" setup.py install +:: remove scikit-build again, don't want to include that +"%PYTHON%" -m pip uninstall --yes scikit-build +"%PYTHON%" -m pip uninstall --yes packaging +"%PYTHON%" -m pip uninstall --yes pyparsing +"%PYTHON%" -m pip uninstall --yes setuptools +"%PYTHON%" -m pip uninstall --yes six +"%PYTHON%" -m pip uninstall --yes wheel + if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. :: See -:: http://docs.continuum.io/conda/build.html +:: http://docs.continlsuum.io/conda/build.html :: for a list of environment variables that are set during the build process. diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index abebc130..5a5055bb 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -1,2 +1,22 @@ + cd $RECIPE_DIR/.. +# HACK, until scikit-build is updated to 0.7.1 or higher ... +$PYTHON -m pip install \ + https://github.com/scikit-build/scikit-build/archive/0.7.1.zip + +env + +# specify where CMAKE will search for lapack and blas +# needs recent cmake (conda's 3.12) and policy CMP0074 NEW +export BLAS_ROOT=${CONDA_PREFIX} +export LAPACK_ROOT=${CONDA_PREFIX} + $PYTHON setup.py install + +# same HACK, remove again +$PYTHON -m pip uninstall --yes scikit-build +$PYTHON -m pip uninstall --yes packaging +$PYTHON -m pip uninstall --yes pyparsing +$PYTHON -m pip uninstall --yes setuptools +$PYTHON -m pip uninstall --yes six +$PYTHON -m pip uninstall --yes wheel diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 3fa9eca1..fa6f99ea 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -7,19 +7,27 @@ build: requirements: host: + - python {{PY_VER}} + - cmake + - pip + - flang # [win] + - {{ compiler('c') }} # [win] + - {{ compiler('fortran') }} # [not win] - numpy - - openblas >=0.3.0 + build: + - numpy + - pyparsing + - setuptools + - wheel + - six + - packaging - libflang # [win] - libgfortran # [not win] - - python - - build: - - {{ compiler('fortran') }} # [not win] - - {{ compiler('c') }} # [win] - - flang # [win] + - openblas >=0.3.0 # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 + run: - numpy - openblas >=0.3.0 @@ -28,7 +36,11 @@ requirements: test: requires: + - numpy + - openblas - python {{PY_VER}} + - libgfortran # [not win] + - libflang # [win] imports: - slycot diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 51da54fe..98cc73fc 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -2,12 +2,19 @@ cd %RECIPE_DIR% cd .. +:: until scikit-build is updated to 0.7.1 or higher ... +"%PYTHON%" -m pip install "https://github.com/scikit-build/scikit-build/archive/0.7.1.zip" + set F77=%BUILD_PREFIX%\Library\bin\flang.exe set F90=%BUILD_PREFIX%\Library\bin\flang.exe set LAPACKLIBS=lapack:blas +"%PYTHON%" setup.py build "%PYTHON%" setup.py install +:: remove scikit-build again, don't want to include that +"%PYTHON%" -m pip uninstall --yes scikit-build + if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index 5d9c587c..1ab51dbb 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,3 +1,7 @@ cd $RECIPE_DIR/.. -export LAPACKLIBS=lapack:blas +# HACK, until scikit-build is updated to 0.7.1 or higher ... +$PYTHON -m pip install \ + https://github.com/scikit-build/scikit-build/archive/0.7.1.zip $PYTHON setup.py install +# same HACK +$PYTHON -m pip uninstall --yes scikit-build diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 8ff28a28..f070481d 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -7,16 +7,24 @@ build: requirements: host: - - numpy - - lapack - - libflang # [win] - - libgfortran # [not win] - python {{PY_VER}} + - cmake + - pip + - numpy + - flang # [win] + - {{ compiler('c') }} # [win] + - {{ compiler('fortran') }} # [not win] build: - - {{ compiler('fortran') }} # [not win] - - {{ compiler('c') }} # [win] - - flang # [win] + - numpy + - pyparsing + - setuptools + - wheel + - six + - packaging + - libflang # [win] + - libgfortran # [not win] + - lapack # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 @@ -29,7 +37,11 @@ requirements: test: requires: + - numpy + - lapack - python {{PY_VER}} + - libgfortran # [not win] + - libflang # [win] imports: - slycot diff --git a/setup.py b/setup.py index ee1a44e1..d015cddd 100644 --- a/setup.py +++ b/setup.py @@ -5,7 +5,7 @@ Slycot wraps the SLICOT library which is used for control and systems analysis. """ -from __future__ import division, print_function +from skbuild import setup DOCLINES = __doc__.split("\n") @@ -52,8 +52,8 @@ VERSION += '-post{:d}'.format(POST) # Return the git revision as a string -def git_version(): - def _minimal_ext_cmd(cmd): +def git_version(srcdir=None): + def _minimal_ext_cmd(cmd, srcdir): # construct minimal environment env = {} for k in ['SYSTEMROOT', 'PATH']: @@ -66,12 +66,13 @@ def _minimal_ext_cmd(cmd): env['LC_ALL'] = 'C' out = subprocess.Popen( cmd, + cwd=srcdir, stdout=subprocess.PIPE, env=env).communicate()[0] return out try: - out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD']) + out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD'], srcdir) GIT_REVISION = out.strip().decode('ascii') except OSError: GIT_REVISION = "Unknown" @@ -185,14 +186,16 @@ def run(self): def setup_package(): src_path = os.path.dirname(os.path.abspath(sys.argv[0])) old_path = os.getcwd() - os.chdir(src_path) + #os.chdir(src_path) sys.path.insert(0, src_path) # Rewrite the version file everytime - write_version_py() - + #write_version_py(src_path+'/slycot/version.py') + gitrevision = git_version(src_path) + metadata = dict( name='slycot', + version=VERSION, maintainer="Slycot developers", maintainer_email="python-control-discuss@lists.sourceforge.net", description=DOCLINES[0], @@ -203,37 +206,35 @@ def setup_package(): classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], cmdclass={"sdist": sdist_checked}, + cmake_args=[ '-DSLYCOT_VERSION:STRING=' + VERSION, + '-DGIT_REVISION:STRING=' + gitrevision, + '-DISRELEASE:STRING=' + str(ISRELEASED), + '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7] ], + #cmake_source_dir=src_path, + zip_safe=False, ) - # Run build - if len(sys.argv) >= 2 and \ - ('--help' in sys.argv[1:] or - sys.argv[1] in ('--help-commands', 'egg_info', '--version', - 'clean')): - # Use setuptools for these commands (they don't work well or at all - # with distutils). For normal builds use distutils. - try: - from setuptools import setup - except ImportError: - from distutils.core import setup - - FULLVERSION, GIT_REVISION = get_version_info() - metadata['version'] = FULLVERSION - elif len(sys.argv) >= 2 and sys.argv[1] == 'bdist_wheel': - # bdist_wheel needs setuptools - import setuptools - setuptools # reference once for pyflakes - from numpy.distutils.core import setup - metadata['configuration'] = configuration - else: - from numpy.distutils.core import setup - metadata['configuration'] = configuration - + # Windows builds use Flang. + # Flang detection and configuration is not automatic yet; the CMAKE + # settings below are to circumvent that; when scikit-build and cmake + # tools have improved, most of this might be removed? + import platform + if platform.system() == 'Windows': + pbase = r'/'.join(sys.executable.split(os.sep)[:-1]) + metadata['cmake_args'].extend([ + '-GNMake Makefiles', + '-DF2PY_EXECUTABLE=' + pbase + r'/Scripts/f2py.bat', + '-DCMAKE_Fortran_COMPILER=' + pbase + r'/Library/bin/flang.exe', + '-DCMAKE_Fortran_COMPILER_ID=Flang', + '-DCMAKE_C_COMPILER_ID=MSVC', + '-DCMAKE_C_COMPILER_VERSION=19.0.0', + '-DNumPy_INCLUDE_DIR=' + pbase + r'/Include', + '-DCMAKE_VERBOSE_MAKEFILE:BOOL=ON' ]) try: setup(**metadata) finally: del sys.path[0] - os.chdir(old_path) + #os.chdir(old_path) return diff --git a/slycot/version.py.in b/slycot/version.py.in index 506afa39..0843bf15 100644 --- a/slycot/version.py.in +++ b/slycot/version.py.in @@ -1,8 +1,10 @@ -short_version = $VERSION -version = $VERSION -full_version = $FULL_VERSION -git_revision = $GIT_REVISION -release = $IS_RELEASED + +# THIS FILE IS GENERATED FROM SLYCOT SETUP.PY +short_version = '@SLYCOT_VERSION@' +version = '@SLYCOT_VERSION@' +full_version = '@FULL_VERSION@' +git_revision = '@GIT_REVISION@' +release = @ISRELEASE@ if not release: version = full_version From b3168f477708cc5a65af185c5294f4d924f7d03e Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 21 Aug 2018 14:17:29 +0200 Subject: [PATCH 033/405] Using scikit-build as buildsystem --- .travis.yml | 11 +- CMakeLists.txt | 50 ++++++++++ conda-recipe-openblas/bld.bat | 81 ++++++++++++++- conda-recipe-openblas/build.sh | 20 ++++ conda-recipe-openblas/meta.yaml | 26 +++-- conda-recipe/bld.bat | 7 ++ conda-recipe/build.sh | 6 +- conda-recipe/meta.yaml | 26 +++-- setup.py | 65 ++++++------ slycot/CMakeLists.txt | 172 ++++++++++++++++++++++++++++++++ slycot/tests/CMakeLists.txt | 6 ++ slycot/version.py.in | 12 ++- 12 files changed, 423 insertions(+), 59 deletions(-) create mode 100644 CMakeLists.txt create mode 100644 slycot/CMakeLists.txt create mode 100644 slycot/tests/CMakeLists.txt diff --git a/.travis.yml b/.travis.yml index ca454932..a436e2f2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -19,6 +19,7 @@ before_install: - if [[ $TEST_CONDA == 0 ]]; then sudo apt-get install liblapack-dev libblas-dev; sudo apt-get install gfortran; + sudo apt-get install cmake; fi install: @@ -46,6 +47,11 @@ install: # Make sure that fortran compiler can find conda libraries # - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; + + # pip install scikit-build, one in conda repos is currently too old + - if [[ $TEST_CONDA == 0 ]]; then + pip install https://github.com/scikit-build/scikit-build/archive/0.7.1.zip; + fi # # Install the slycot package (two ways, to improve robustness). For the # conda version, need to install lapack from conda-forge (no way to specify @@ -56,11 +62,10 @@ install: # - if [[ $TEST_CONDA == 1 ]]; then conda config --append channels conda-forge; - conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe; - conda install -c conda-forge lapack; + conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe-openblas; conda install --override-channels -c local slycot; else - LAPACKLIBS=lapack:blas python setup.py install; + python setup.py install; fi # # coveralls not in conda repos :-( diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 00000000..bf67a8ed --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,50 @@ +# CMake file for use in conjunction with scikit-build + +cmake_minimum_required(VERSION 3.4.0) + +if (CMAKE_VERSION VERSION_GREATER "3.11.0") + cmake_policy(SET CMP0074 NEW) +endif() + +project(slycot VERSION ${SLYCOT_VERSION}) + +# Fortran detection fails on windows, use the CMAKE_C_SIMULATE flag to +# force success +if(WIN32) + set(CMAKE_Fortran_SIMULATE_VERSION 19.0) +# set(CMAKE_Fortran_COMPILER_FORCED TRUE) +# set(CMAKE_C_COMPILER_VERSION 19.0) +endif() + +enable_language(C) +enable_language(Fortran) + +find_package(PythonLibs REQUIRED) +find_package(NumPy REQUIRED) +#set(BLA_VENDOR "OpenBLAS") +find_package(LAPACK REQUIRED) +message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") +message(STATUS "Slycot version: ${SLYCOT_VERSION}") + +# find python, standard packages, F2PY find flaky on Windows +if (NOT WIN32) + find_package(F2PY REQUIRED) +endif() + +# pic option for flang not correct, remove for Windows +if (WIN32) + set(CMAKE_Fortran_COMPILE_OPTIONS_PIC "") +endif() + +# base site dir, use python installation for location specific includes +execute_process( + COMMAND "${PYTHON_EXECUTABLE}" -c + "from distutils.sysconfig import get_python_lib as pl; print(pl())" + OUTPUT_VARIABLE PYTHON_SITE + OUTPUT_STRIP_TRAILING_WHITESPACE) +if(WIN32) + string(REPLACE "\\" "/" PYTHON_SITE ${PYTHON_SITE}) +endif() + +add_subdirectory(slycot) + diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index c5294765..7f8ff7d9 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -2,16 +2,89 @@ cd %RECIPE_DIR% cd .. -set F77=%BUILD_PREFIX%\Library\bin\flang.exe -set F90=%BUILD_PREFIX%\Library\bin\flang.exe +:: until scikit-build on conda-forge is updated to 0.6.1 or higher ... +"%PYTHON%" -m pip install "https://github.com/scikit-build/scikit-build/archive/0.7.1.zip" + +:: indicating fortran compiler is essential +set FC=%BUILD_PREFIX%\Library\bin\flang.exe + +:: The batch file created by conda-build sets a load of environment variables +:: Building worked fine without conda; apparently one or more of these +:: variables produce test & link failures. Resetting most of these here +set ARCH= +set BUILD= +set BUILD_PREFIX= +set CMAKE_GENERATOR= +set CommandPromptType= +set CPU_COUNT= +set DISTUTILS_USE_SDK= +set folder= +set cpu_optimization_target= +set fortran_compiler= +set Framework40Version= +set FrameworkDir= +set FrameworkDIR64= +set FrameworkVersion= +set FrameworkVersion64= +set ignore_build_only_deps= +set CFLAGS= +set CXXFLAGS= +set cxx_compiler= +set c_compiler= +set INCLUDE= +set LDFLAGS_SHARED= +set LIBPATH= +set LIB=;%LIB% +set MSSdk= +set MSYS2_ARG_CONV_EXCL= +set MSYS2_ENV_CONV_EXCL= +set NETFSXDIR= +set PIP_IGNORE_INSTALLED= +set platform= +set WindowsLibPath= +set WindowsSdkDir= +set CYGWIN_PREFIX= +set SRC_DIR= +set STDLIB_DIR= +set SUBDIR= +set SYS_PREFIX= +set target_platform= +set UCRTVersion= +set UniversalCRTSdkDir= +set VCINSTALLDIR= +set vc= +set win= +set VisualStudioVersion= +set VSINSTALLDIR= +set VSREGKEY= +set VS_MAJOR= +set VS_VERSION= +set VS_YEAR= +set WindowsSDKLibVersion= +set WindowsSDKVersion= +set WindowsSDKExecutablePath_x64= +set WindowsSDKExecutablePath_x86= + +:: information on remaining variables +set + +set BLAS_ROOT=%CONDA_PREFIX% +set LAPACK_ROOT=%CONDA_PREFIX% -"%PYTHON%" setup.py build "%PYTHON%" setup.py install +:: remove scikit-build again, don't want to include that +"%PYTHON%" -m pip uninstall --yes scikit-build +"%PYTHON%" -m pip uninstall --yes packaging +"%PYTHON%" -m pip uninstall --yes pyparsing +"%PYTHON%" -m pip uninstall --yes setuptools +"%PYTHON%" -m pip uninstall --yes six +"%PYTHON%" -m pip uninstall --yes wheel + if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. :: See -:: http://docs.continuum.io/conda/build.html +:: http://docs.continlsuum.io/conda/build.html :: for a list of environment variables that are set during the build process. diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index abebc130..5a5055bb 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -1,2 +1,22 @@ + cd $RECIPE_DIR/.. +# HACK, until scikit-build is updated to 0.7.1 or higher ... +$PYTHON -m pip install \ + https://github.com/scikit-build/scikit-build/archive/0.7.1.zip + +env + +# specify where CMAKE will search for lapack and blas +# needs recent cmake (conda's 3.12) and policy CMP0074 NEW +export BLAS_ROOT=${CONDA_PREFIX} +export LAPACK_ROOT=${CONDA_PREFIX} + $PYTHON setup.py install + +# same HACK, remove again +$PYTHON -m pip uninstall --yes scikit-build +$PYTHON -m pip uninstall --yes packaging +$PYTHON -m pip uninstall --yes pyparsing +$PYTHON -m pip uninstall --yes setuptools +$PYTHON -m pip uninstall --yes six +$PYTHON -m pip uninstall --yes wheel diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 3fa9eca1..fa6f99ea 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -7,19 +7,27 @@ build: requirements: host: + - python {{PY_VER}} + - cmake + - pip + - flang # [win] + - {{ compiler('c') }} # [win] + - {{ compiler('fortran') }} # [not win] - numpy - - openblas >=0.3.0 + build: + - numpy + - pyparsing + - setuptools + - wheel + - six + - packaging - libflang # [win] - libgfortran # [not win] - - python - - build: - - {{ compiler('fortran') }} # [not win] - - {{ compiler('c') }} # [win] - - flang # [win] + - openblas >=0.3.0 # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 + run: - numpy - openblas >=0.3.0 @@ -28,7 +36,11 @@ requirements: test: requires: + - numpy + - openblas - python {{PY_VER}} + - libgfortran # [not win] + - libflang # [win] imports: - slycot diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 51da54fe..98cc73fc 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -2,12 +2,19 @@ cd %RECIPE_DIR% cd .. +:: until scikit-build is updated to 0.7.1 or higher ... +"%PYTHON%" -m pip install "https://github.com/scikit-build/scikit-build/archive/0.7.1.zip" + set F77=%BUILD_PREFIX%\Library\bin\flang.exe set F90=%BUILD_PREFIX%\Library\bin\flang.exe set LAPACKLIBS=lapack:blas +"%PYTHON%" setup.py build "%PYTHON%" setup.py install +:: remove scikit-build again, don't want to include that +"%PYTHON%" -m pip uninstall --yes scikit-build + if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index 5d9c587c..1ab51dbb 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,3 +1,7 @@ cd $RECIPE_DIR/.. -export LAPACKLIBS=lapack:blas +# HACK, until scikit-build is updated to 0.7.1 or higher ... +$PYTHON -m pip install \ + https://github.com/scikit-build/scikit-build/archive/0.7.1.zip $PYTHON setup.py install +# same HACK +$PYTHON -m pip uninstall --yes scikit-build diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 8ff28a28..f070481d 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -7,16 +7,24 @@ build: requirements: host: - - numpy - - lapack - - libflang # [win] - - libgfortran # [not win] - python {{PY_VER}} + - cmake + - pip + - numpy + - flang # [win] + - {{ compiler('c') }} # [win] + - {{ compiler('fortran') }} # [not win] build: - - {{ compiler('fortran') }} # [not win] - - {{ compiler('c') }} # [win] - - flang # [win] + - numpy + - pyparsing + - setuptools + - wheel + - six + - packaging + - libflang # [win] + - libgfortran # [not win] + - lapack # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 @@ -29,7 +37,11 @@ requirements: test: requires: + - numpy + - lapack - python {{PY_VER}} + - libgfortran # [not win] + - libflang # [win] imports: - slycot diff --git a/setup.py b/setup.py index ee1a44e1..d015cddd 100644 --- a/setup.py +++ b/setup.py @@ -5,7 +5,7 @@ Slycot wraps the SLICOT library which is used for control and systems analysis. """ -from __future__ import division, print_function +from skbuild import setup DOCLINES = __doc__.split("\n") @@ -52,8 +52,8 @@ VERSION += '-post{:d}'.format(POST) # Return the git revision as a string -def git_version(): - def _minimal_ext_cmd(cmd): +def git_version(srcdir=None): + def _minimal_ext_cmd(cmd, srcdir): # construct minimal environment env = {} for k in ['SYSTEMROOT', 'PATH']: @@ -66,12 +66,13 @@ def _minimal_ext_cmd(cmd): env['LC_ALL'] = 'C' out = subprocess.Popen( cmd, + cwd=srcdir, stdout=subprocess.PIPE, env=env).communicate()[0] return out try: - out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD']) + out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD'], srcdir) GIT_REVISION = out.strip().decode('ascii') except OSError: GIT_REVISION = "Unknown" @@ -185,14 +186,16 @@ def run(self): def setup_package(): src_path = os.path.dirname(os.path.abspath(sys.argv[0])) old_path = os.getcwd() - os.chdir(src_path) + #os.chdir(src_path) sys.path.insert(0, src_path) # Rewrite the version file everytime - write_version_py() - + #write_version_py(src_path+'/slycot/version.py') + gitrevision = git_version(src_path) + metadata = dict( name='slycot', + version=VERSION, maintainer="Slycot developers", maintainer_email="python-control-discuss@lists.sourceforge.net", description=DOCLINES[0], @@ -203,37 +206,35 @@ def setup_package(): classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], cmdclass={"sdist": sdist_checked}, + cmake_args=[ '-DSLYCOT_VERSION:STRING=' + VERSION, + '-DGIT_REVISION:STRING=' + gitrevision, + '-DISRELEASE:STRING=' + str(ISRELEASED), + '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7] ], + #cmake_source_dir=src_path, + zip_safe=False, ) - # Run build - if len(sys.argv) >= 2 and \ - ('--help' in sys.argv[1:] or - sys.argv[1] in ('--help-commands', 'egg_info', '--version', - 'clean')): - # Use setuptools for these commands (they don't work well or at all - # with distutils). For normal builds use distutils. - try: - from setuptools import setup - except ImportError: - from distutils.core import setup - - FULLVERSION, GIT_REVISION = get_version_info() - metadata['version'] = FULLVERSION - elif len(sys.argv) >= 2 and sys.argv[1] == 'bdist_wheel': - # bdist_wheel needs setuptools - import setuptools - setuptools # reference once for pyflakes - from numpy.distutils.core import setup - metadata['configuration'] = configuration - else: - from numpy.distutils.core import setup - metadata['configuration'] = configuration - + # Windows builds use Flang. + # Flang detection and configuration is not automatic yet; the CMAKE + # settings below are to circumvent that; when scikit-build and cmake + # tools have improved, most of this might be removed? + import platform + if platform.system() == 'Windows': + pbase = r'/'.join(sys.executable.split(os.sep)[:-1]) + metadata['cmake_args'].extend([ + '-GNMake Makefiles', + '-DF2PY_EXECUTABLE=' + pbase + r'/Scripts/f2py.bat', + '-DCMAKE_Fortran_COMPILER=' + pbase + r'/Library/bin/flang.exe', + '-DCMAKE_Fortran_COMPILER_ID=Flang', + '-DCMAKE_C_COMPILER_ID=MSVC', + '-DCMAKE_C_COMPILER_VERSION=19.0.0', + '-DNumPy_INCLUDE_DIR=' + pbase + r'/Include', + '-DCMAKE_VERBOSE_MAKEFILE:BOOL=ON' ]) try: setup(**metadata) finally: del sys.path[0] - os.chdir(old_path) + #os.chdir(old_path) return diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt new file mode 100644 index 00000000..3207d92c --- /dev/null +++ b/slycot/CMakeLists.txt @@ -0,0 +1,172 @@ +# CMakeLists.txt file for Slycot +# use in conjunction with scikit-build +# +# RvP, 180710 + + +set(FSOURCES + + src/AB01MD.f src/MA02AD.f src/MB03YT.f src/NF01BW.f src/SB10KD.f + src/AB01ND.f src/MA02BD.f src/MB03ZA.f src/NF01BX.f src/SB10LD.f + src/AB01OD.f src/MA02BZ.f src/MB03ZD.f src/NF01BY.f src/SB10MD.f + src/AB04MD.f src/MA02CD.f src/MB04DD.f src/SB01BD.f src/SB10PD.f + src/AB05MD.f src/MA02CZ.f src/MB04DI.f src/SB01BX.f src/SB10QD.f + src/AB05ND.f src/MA02DD.f src/MB04DS.f src/SB01BY.f src/SB10RD.f + src/AB05OD.f src/MA02ED.f src/MB04DY.f src/SB01DD.f src/SB10SD.f + src/AB05PD.f src/MA02FD.f src/MB04GD.f src/SB01FY.f src/SB10TD.f + src/AB05QD.f src/MA02GD.f src/MB04ID.f src/SB01MD.f src/SB10UD.f + src/AB05RD.f src/MA02HD.f src/MB04IY.f src/SB02CX.f src/SB10VD.f + src/AB05SD.f src/MA02ID.f src/MB04IZ.f src/SB02MD.f src/SB10WD.f + src/AB07MD.f src/MA02JD.f src/MB04JD.f src/SB02MR.f src/SB10YD.f + src/AB07ND.f src/MB01MD.f src/MB04KD.f src/SB02MS.f src/SB10ZD.f + src/AB08MD.f src/MB01ND.f src/MB04LD.f src/SB02MT.f src/SB10ZP.f + src/AB08MZ.f src/MB01PD.f src/MB04MD.f src/SB02MU.f src/SB16AD.f + src/AB08ND.f src/MB01QD.f src/MB04ND.f src/SB02MV.f src/SB16AY.f + src/AB08NX.f src/MB01RD.f src/MB04NY.f src/SB02MW.f src/SB16BD.f + src/AB08NZ.f src/MB01RU.f src/MB04OD.f src/SB02ND.f src/SB16CD.f + src/AB09AD.f src/MB01RW.f src/MB04OW.f src/SB02OD.f src/SB16CY.f + src/AB09AX.f src/MB01RX.f src/MB04OX.f src/SB02OU.f src/select.f + src/AB09BD.f src/MB01RY.f src/MB04OY.f src/SB02OV.f src/SG02AD.f + src/AB09BX.f src/MB01SD.f src/MB04PA.f src/SB02OW.f src/SG03AD.f + src/AB09CD.f src/MB01TD.f src/MB04PB.f src/SB02OX.f src/SG03AX.f + src/AB09CX.f src/MB01UD.f src/MB04PU.f src/SB02OY.f src/SG03AY.f + src/AB09DD.f src/MB01UW.f src/MB04PY.f src/SB02PD.f src/SG03BD.f + src/AB09ED.f src/MB01UX.f src/MB04QB.f src/SB02QD.f src/SG03BU.f + src/AB09FD.f src/MB01VD.f src/MB04QC.f src/SB02RD.f src/SG03BV.f + src/AB09GD.f src/MB01WD.f src/MB04QF.f src/SB02RU.f src/SG03BW.f + src/AB09HD.f src/MB01XD.f src/MB04QU.f src/SB02SD.f src/SG03BX.f + src/AB09HX.f src/MB01XY.f src/MB04TB.f src/SB03MD.f src/SG03BY.f + src/AB09HY.f src/MB01YD.f src/MB04TS.f src/SB03MU.f + src/SLCT_DLATZM.f src/AB09ID.f src/MB01ZD.f src/MB04TT.f + src/SB03MV.f src/SLCT_ZLATZM.f src/AB09IX.f src/MB02CD.f + src/MB04TU.f src/SB03MW.f src/TB01ID.f src/AB09IY.f src/MB02CU.f + src/MB04TV.f src/SB03MX.f src/TB01IZ.f src/AB09JD.f src/MB02CV.f + src/MB04TW.f src/SB03MY.f src/TB01KD.f src/AB09JV.f src/MB02CX.f + src/MB04TX.f src/SB03OD.f src/TB01LD.f src/AB09JW.f src/MB02CY.f + src/MB04TY.f src/SB03OR.f src/TB01MD.f src/AB09JX.f src/MB02DD.f + src/MB04UD.f src/SB03OT.f src/TB01ND.f src/AB09KD.f src/MB02ED.f + src/MB04VD.f src/SB03OU.f src/TB01PD.f src/AB09KX.f src/MB02FD.f + src/MB04VX.f src/SB03OV.f src/TB01TD.f src/AB09MD.f src/MB02GD.f + src/MB04WD.f src/SB03OY.f src/TB01TY.f src/AB09ND.f src/MB02HD.f + src/MB04WP.f src/SB03PD.f src/TB01UD.f src/AB13AD.f src/MB02ID.f + src/MB04WR.f src/SB03QD.f src/TB01VD.f src/AB13AX.f src/MB02JD.f + src/MB04WU.f src/SB03QX.f src/TB01VY.f src/AB13BD.f src/MB02JX.f + src/MB04XD.f src/SB03QY.f src/TB01WD.f src/AB13CD.f src/MB02KD.f + src/MB04XY.f src/SB03RD.f src/TB01XD.f src/AB13DD.f src/MB02MD.f + src/MB04YD.f src/SB03SD.f src/TB01XZ.f src/AB13DX.f src/MB02ND.f + src/MB04YW.f src/SB03SX.f src/TB01YD.f src/AB13ED.f src/MB02NY.f + src/MB04ZD.f src/SB03SY.f src/TB01ZD.f src/AB13FD.f src/MB02OD.f + src/MB05MD.f src/SB03TD.f src/TB03AD.f src/AB13MD.f src/MB02PD.f + src/MB05MY.f src/SB03UD.f src/TB03AY.f src/AB8NXZ.f src/MB02QD.f + src/MB05ND.f src/SB04MD.f src/TB04AD.f src/AG07BD.f src/MB02QY.f + src/MB05OD.f src/SB04MR.f src/TB04AY.f src/AG08BD.f src/MB02RD.f + src/MB05OY.f src/SB04MU.f src/TB04BD.f src/AG08BY.f src/MB02RZ.f + src/MB3OYZ.f src/SB04MW.f src/TB04BV.f src/AG08BZ.f src/MB02SD.f + src/MB3PYZ.f src/SB04MY.f src/TB04BW.f src/AG8BYZ.f src/MB02SZ.f + src/MC01MD.f src/SB04ND.f src/TB04BX.f src/BB01AD.f src/MB02TD.f + src/MC01ND.f src/SB04NV.f src/TB04CD.f src/BB02AD.f src/MB02TZ.f + src/MC01OD.f src/SB04NW.f src/TB05AD.f src/BB03AD.f src/MB02UD.f + src/MC01PD.f src/SB04NX.f src/TC01OD.f src/BB04AD.f src/MB02UU.f + src/MC01PY.f src/SB04NY.f src/TC04AD.f src/BD01AD.f src/MB02UV.f + src/MC01QD.f src/SB04OD.f src/TC05AD.f src/BD02AD.f src/MB02VD.f + src/MC01RD.f src/SB04OW.f src/TD03AD.f src/DE01OD.f src/MB02WD.f + src/MC01SD.f src/SB04PD.f src/TD03AY.f src/DE01PD.f src/MB02XD.f + src/MC01SW.f src/SB04PX.f src/TD04AD.f src/delctg.f src/MB02YD.f + src/MC01SX.f src/SB04PY.f src/TD05AD.f src/DF01MD.f src/MB03MD.f + src/MC01SY.f src/SB04QD.f src/TF01MD.f src/DG01MD.f src/MB03MY.f + src/MC01TD.f src/SB04QR.f src/TF01MX.f src/DG01ND.f src/MB03ND.f + src/MC01VD.f src/SB04QU.f src/TF01MY.f src/DG01NY.f src/MB03NY.f + src/MC01WD.f src/SB04QY.f src/TF01ND.f src/DG01OD.f src/MB03OD.f + src/MC03MD.f src/SB04RD.f src/TF01OD.f src/DK01MD.f src/MB03OY.f + src/MC03ND.f src/SB04RV.f src/TF01PD.f src/FB01QD.f src/MB03PD.f + src/MC03NX.f src/SB04RW.f src/TF01QD.f src/FB01RD.f src/MB03PY.f + src/MC03NY.f src/SB04RX.f src/TF01RD.f src/FB01SD.f src/MB03QD.f + src/MD03AD.f src/SB04RY.f src/TG01AD.f src/FB01TD.f src/MB03QX.f + src/MD03BA.f src/SB06ND.f src/TG01AZ.f src/FB01VD.f src/MB03QY.f + src/MD03BB.f src/SB08CD.f src/TG01BD.f src/FD01AD.f src/MB03RD.f + src/MD03BD.f src/SB08DD.f src/TG01CD.f src/IB01AD.f src/MB03RX.f + src/MD03BF.f src/SB08ED.f src/TG01DD.f src/IB01BD.f src/MB03RY.f + src/MD03BX.f src/SB08FD.f src/TG01ED.f src/IB01CD.f src/MB03SD.f + src/MD03BY.f src/SB08GD.f src/TG01FD.f src/IB01MD.f src/MB03TD.f + src/NF01AD.f src/SB08HD.f src/TG01FZ.f src/IB01MY.f src/MB03TS.f + src/NF01AY.f src/SB08MD.f src/TG01HD.f src/IB01ND.f src/MB03UD.f + src/NF01BA.f src/SB08MY.f src/TG01HX.f src/IB01OD.f src/MB03VD.f + src/NF01BB.f src/SB08ND.f src/TG01ID.f src/IB01OY.f src/MB03VY.f + src/NF01BD.f src/SB08NY.f src/TG01JD.f src/IB01PD.f src/MB03WA.f + src/NF01BE.f src/SB09MD.f src/TG01WD.f src/IB01PX.f src/MB03WD.f + src/NF01BF.f src/SB10AD.f src/UD01BD.f src/IB01PY.f src/MB03WX.f + src/NF01BP.f src/SB10DD.f src/UD01CD.f src/IB01QD.f src/MB03XD.f + src/NF01BQ.f src/SB10ED.f src/UD01DD.f src/IB01RD.f src/MB03XP.f + src/NF01BR.f src/SB10FD.f src/UD01MD.f src/IB03AD.f src/MB03XU.f + src/NF01BS.f src/SB10HD.f src/UD01MZ.f src/IB03BD.f src/MB03YA.f + src/NF01BU.f src/SB10ID.f src/UD01ND.f src/MA01AD.f src/MB03YD.f + src/NF01BV.f src/SB10JD.f src/UE01MD.f) + +set(F2PYSOURCE src/_wrapper.pyf) + +configure_file(version.py.in version.py @ONLY) + +set(PYSOURCE + + __init__.py analysis.py examples.py math.py synthesis.py + transform.py ${CMAKE_CURRENT_BINARY_DIR}/version.py) + +set(SLYCOT_MODULE "_wrapper") +set(GENERATED_MODULE + ${CMAKE_CURRENT_BINARY_DIR}/${SLYCOT_MODULE}${PYTHON_EXTENSION_MODULE_SUFFIX}) + + +set(CMAKE_Fortran_FLAGS ) + +add_custom_target(wrapper ALL DEPENDS ${FSOURCES}) +add_custom_command( + OUTPUT SLYCOTmodule.c _wrappermodule.c _wrapper-f2pywrappers.f + COMMAND ${F2PY_EXECUTABLE} -m SLYCOT + ${CMAKE_CURRENT_SOURCE_DIR}/${F2PYSOURCE} + ) + +add_library( + ${SLYCOT_MODULE} SHARED + SLYCOTmodule.c _wrappermodule.c _wrapper-f2pywrappers.f + "${PYTHON_SITE}/numpy/f2py/src/fortranobject.c" + ${FSOURCES}) + +set(CMAKE_SHARED_LIBRARY_PREFIX "") +if (WIN32) + set(CMAKE_SHARED_LIBRARY_SUFFIX ".pyd") +endif() +set_target_properties(${SLYCOT_MODULE} PROPERTIES + OUTPUT_NAME "_wrapper") +if (WIN32) + target_link_libraries(${SLYCOT_MODULE} PUBLIC + ${PYTHON_LIBRARIES} ${LAPACK_LIBRARIES}) +endif() + +if (UNIX) + target_link_libraries(${SLYCOT_MODULE} PUBLIC + ${LAPACK_LIBRARIES}) + + if (APPLE) + set_target_properties(${SLYCOT_MODULE} PROPERTIES + LINK_FLAGS '-Wl,-dylib,-undefined,dynamic_lookup') + string(REGEX REPLACE "^([0-9]+)\.([0-9]+)\.[0-9]+$" "\\1\\2" + PYMAJORMINOR ${PYTHON_VERSION_STRING}) + set(CMAKE_SHARED_LIBRARY_SUFFIX ".cpython-${PYMAJORMINOR}m-darwin.so") + message(STATUS "binary module suffix ${CMAKE_SHARED_LIBRARY_SUFFIX}") + else() + set_target_properties(${SLYCOT_MODULE} PROPERTIES + LINK_FLAGS '-Wl,--allow-shlib-undefined') + endif() +endif() + +target_include_directories( + ${SLYCOT_MODULE} PUBLIC + ${PYTHON_SITE}/numpy/core/include + ${PYTHON_SITE}/numpy/f2py/src + ${PYTHON_INCLUDE_DIRS} + ) + +install(TARGETS ${SLYCOT_MODULE} DESTINATION slycot) +install(FILES ${PYSOURCE} DESTINATION slycot) + +add_subdirectory(tests) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt new file mode 100644 index 00000000..c97cb500 --- /dev/null +++ b/slycot/tests/CMakeLists.txt @@ -0,0 +1,6 @@ +set(PYSOURCE + + __init__.py test.py test_sg02ad.py test_sg03ad.py test_tb05ad.py + test_td04ad.py) + +install(FILES ${PYSOURCE} DESTINATION slycot/tests) diff --git a/slycot/version.py.in b/slycot/version.py.in index 506afa39..0843bf15 100644 --- a/slycot/version.py.in +++ b/slycot/version.py.in @@ -1,8 +1,10 @@ -short_version = $VERSION -version = $VERSION -full_version = $FULL_VERSION -git_revision = $GIT_REVISION -release = $IS_RELEASED + +# THIS FILE IS GENERATED FROM SLYCOT SETUP.PY +short_version = '@SLYCOT_VERSION@' +version = '@SLYCOT_VERSION@' +full_version = '@FULL_VERSION@' +git_revision = '@GIT_REVISION@' +release = @ISRELEASE@ if not release: version = full_version From aba817df01342bc5779aabcd27befa60720eca02 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 21 Aug 2018 15:47:35 +0200 Subject: [PATCH 034/405] build command modifications for .travis.yml --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index a436e2f2..94f24a43 100644 --- a/.travis.yml +++ b/.travis.yml @@ -34,6 +34,7 @@ install: fi - bash miniconda.sh -b -p $HOME/miniconda - export PATH="$HOME/miniconda/bin:$PATH" + - export PYTHONPATH="${HOME}/build/python-control/Slycot/build/testenv/lib/python${TRAVIS_PYTHON_VERSION}/site-packages:${PYTHONPATH}" - hash -r - conda config --set always_yes yes --set changeps1 no - conda update -q conda @@ -63,6 +64,7 @@ install: - if [[ $TEST_CONDA == 1 ]]; then conda config --append channels conda-forge; conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe-openblas; + conda install -c conda-forge openblas >=0.3.0; conda install --override-channels -c local slycot; else python setup.py install; From 3d12649e16a3a8d0610ce57049fce57562934b90 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 21 Aug 2018 17:07:01 +0200 Subject: [PATCH 035/405] - For travis, do not re-build through runtest.py --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 94f24a43..05ec09fe 100644 --- a/.travis.yml +++ b/.travis.yml @@ -44,6 +44,7 @@ install: # Set up a test environment for testing everything out - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy - source activate test-environment + # # Make sure that fortran compiler can find conda libraries # @@ -76,7 +77,7 @@ install: script: # Local unit tests # TODO: replace with nose? - - python runtests.py --coverage + - python runtests.py --coverage --no-build # # As a deeper set of tests, get test against python-control as well # From adc13d7e05178fcae46be93f0c53074d2a4c35cb Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 21 Aug 2018 17:32:12 +0200 Subject: [PATCH 036/405] - do not run tests from Slycot dir --- .travis.yml | 6 +++--- CMakeLists.txt | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 05ec09fe..73959170 100644 --- a/.travis.yml +++ b/.travis.yml @@ -34,7 +34,6 @@ install: fi - bash miniconda.sh -b -p $HOME/miniconda - export PATH="$HOME/miniconda/bin:$PATH" - - export PYTHONPATH="${HOME}/build/python-control/Slycot/build/testenv/lib/python${TRAVIS_PYTHON_VERSION}/site-packages:${PYTHONPATH}" - hash -r - conda config --set always_yes yes --set changeps1 no - conda update -q conda @@ -42,7 +41,7 @@ install: - conda info -a # # Set up a test environment for testing everything out - - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy + - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy openblas - source activate test-environment # @@ -77,7 +76,8 @@ install: script: # Local unit tests # TODO: replace with nose? - - python runtests.py --coverage --no-build + - cd .. + - python Slycot/runtests.py --coverage --no-build # # As a deeper set of tests, get test against python-control as well # diff --git a/CMakeLists.txt b/CMakeLists.txt index bf67a8ed..12d61a67 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,7 +2,7 @@ cmake_minimum_required(VERSION 3.4.0) -if (CMAKE_VERSION VERSION_GREATER "3.11.0") +if (CMAKE_VERSION VERSION_GREATER "3.11.99") cmake_policy(SET CMP0074 NEW) endif() From 9d435d422e377570703f939c6a2ea8665c88af44 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Wed, 22 Aug 2018 13:49:42 +0200 Subject: [PATCH 037/405] - since scikit-build is now in conda-forge, could remove the hack --- .travis.yml | 5 +++-- conda-recipe-openblas/bld.bat | 11 ----------- conda-recipe-openblas/build.sh | 13 ------------- conda-recipe-openblas/meta.yaml | 9 ++------- conda-recipe/bld.bat | 7 ------- conda-recipe/build.sh | 5 ----- conda-recipe/meta.yaml | 8 +------- 7 files changed, 6 insertions(+), 52 deletions(-) diff --git a/.travis.yml b/.travis.yml index 73959170..832eb5cf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -49,9 +49,10 @@ install: # - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; - # pip install scikit-build, one in conda repos is currently too old + # install scikit-build - if [[ $TEST_CONDA == 0 ]]; then - pip install https://github.com/scikit-build/scikit-build/archive/0.7.1.zip; + conda config --append channels conda-forge; + conda install -c conda-forge scikit-build >=0.8.0 ; fi # # Install the slycot package (two ways, to improve robustness). For the diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index 7f8ff7d9..4be8c4f7 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -2,9 +2,6 @@ cd %RECIPE_DIR% cd .. -:: until scikit-build on conda-forge is updated to 0.6.1 or higher ... -"%PYTHON%" -m pip install "https://github.com/scikit-build/scikit-build/archive/0.7.1.zip" - :: indicating fortran compiler is essential set FC=%BUILD_PREFIX%\Library\bin\flang.exe @@ -73,14 +70,6 @@ set LAPACK_ROOT=%CONDA_PREFIX% "%PYTHON%" setup.py install -:: remove scikit-build again, don't want to include that -"%PYTHON%" -m pip uninstall --yes scikit-build -"%PYTHON%" -m pip uninstall --yes packaging -"%PYTHON%" -m pip uninstall --yes pyparsing -"%PYTHON%" -m pip uninstall --yes setuptools -"%PYTHON%" -m pip uninstall --yes six -"%PYTHON%" -m pip uninstall --yes wheel - if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index 5a5055bb..6868b900 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -1,10 +1,5 @@ cd $RECIPE_DIR/.. -# HACK, until scikit-build is updated to 0.7.1 or higher ... -$PYTHON -m pip install \ - https://github.com/scikit-build/scikit-build/archive/0.7.1.zip - -env # specify where CMAKE will search for lapack and blas # needs recent cmake (conda's 3.12) and policy CMP0074 NEW @@ -12,11 +7,3 @@ export BLAS_ROOT=${CONDA_PREFIX} export LAPACK_ROOT=${CONDA_PREFIX} $PYTHON setup.py install - -# same HACK, remove again -$PYTHON -m pip uninstall --yes scikit-build -$PYTHON -m pip uninstall --yes packaging -$PYTHON -m pip uninstall --yes pyparsing -$PYTHON -m pip uninstall --yes setuptools -$PYTHON -m pip uninstall --yes six -$PYTHON -m pip uninstall --yes wheel diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index fa6f99ea..020c0f01 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -8,19 +8,14 @@ build: requirements: host: - python {{PY_VER}} - - cmake - - pip - flang # [win] - {{ compiler('c') }} # [win] - {{ compiler('fortran') }} # [not win] - numpy + - scikit-build >=0.8.0 + build: - numpy - - pyparsing - - setuptools - - wheel - - six - - packaging - libflang # [win] - libgfortran # [not win] - openblas >=0.3.0 diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 98cc73fc..c5294765 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -2,19 +2,12 @@ cd %RECIPE_DIR% cd .. -:: until scikit-build is updated to 0.7.1 or higher ... -"%PYTHON%" -m pip install "https://github.com/scikit-build/scikit-build/archive/0.7.1.zip" - set F77=%BUILD_PREFIX%\Library\bin\flang.exe set F90=%BUILD_PREFIX%\Library\bin\flang.exe -set LAPACKLIBS=lapack:blas "%PYTHON%" setup.py build "%PYTHON%" setup.py install -:: remove scikit-build again, don't want to include that -"%PYTHON%" -m pip uninstall --yes scikit-build - if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index 1ab51dbb..abebc130 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,7 +1,2 @@ cd $RECIPE_DIR/.. -# HACK, until scikit-build is updated to 0.7.1 or higher ... -$PYTHON -m pip install \ - https://github.com/scikit-build/scikit-build/archive/0.7.1.zip $PYTHON setup.py install -# same HACK -$PYTHON -m pip uninstall --yes scikit-build diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index f070481d..d72239b1 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -8,20 +8,14 @@ build: requirements: host: - python {{PY_VER}} - - cmake - - pip - numpy - flang # [win] - {{ compiler('c') }} # [win] - {{ compiler('fortran') }} # [not win] + - scikit-build >=0.8.0 build: - numpy - - pyparsing - - setuptools - - wheel - - six - - packaging - libflang # [win] - libgfortran # [not win] - lapack From 13b3fe63bb730403b0dac7d1ecd330da3e94e092 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Wed, 22 Aug 2018 13:59:54 +0200 Subject: [PATCH 038/405] - explicitly selecting CMAKE_GENERATOR="Unix Makefiles" --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 832eb5cf..62bc33d9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -68,7 +68,7 @@ install: conda install -c conda-forge openblas >=0.3.0; conda install --override-channels -c local slycot; else - python setup.py install; + CMAKE_GENERATOR="Unix Makefiles" python setup.py install; fi # # coveralls not in conda repos :-( From 23138558b1589bba12f7067357de1672359dabf3 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sat, 8 Dec 2018 12:35:12 +0100 Subject: [PATCH 039/405] Added information on scikit-build and cmake build dependency on README.rst --- README.rst | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.rst b/README.rst index f81b9ed1..a723ad4a 100644 --- a/README.rst +++ b/README.rst @@ -25,7 +25,8 @@ Numpy should be the only prerequisite (though you may need the LAPACK libraries as well, depending on your particular system configuration). If you are installing Slycot from source, you will need a FORTRAN -compiler, such as gfortran, and BLAS/LAPACK libraries. +compiler, such as gfortran, and BLAS/LAPACK libraries. The build +system uses skbuild (scikit-buildsystem >= 0.8.1) and cmake. On Debian derivatives you should be able to install all the above with a single command:: From a5d0d78579f1c3bc921eea20ff89cbc011df3fa7 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Fri, 28 Dec 2018 19:29:05 +0200 Subject: [PATCH 040/405] Update Miniconda URL from Conda docs. According to [1], use Miniconda2-latest-Linux-x86_64.sh. This fixes a build bug on Travis. [1] https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html, retrieved 2018-12-28. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 62bc33d9..7fa21636 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,7 +28,7 @@ install: # See https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html # - if [[ "$TRAVIS_PYTHON_VERSION" == "2.7" ]]; then - wget http://repo.continuum.io/miniconda/Miniconda-latest-Linux-x86_64.sh -O miniconda.sh; + wget http://repo.continuum.io/miniconda/Miniconda2-latest-Linux-x86_64.sh -O miniconda.sh; else wget http://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh; fi From 75d6867b7d39e6713709d7e6bde4684b226b9a5f Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Mon, 7 Jan 2019 12:43:18 +0100 Subject: [PATCH 041/405] Update conda-recipe-openblas/bld.bat Co-Authored-By: repagh --- conda-recipe-openblas/bld.bat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index 4be8c4f7..372501cb 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -75,5 +75,5 @@ if errorlevel 1 exit 1 :: Add more build steps here, if they are necessary. :: See -:: http://docs.continlsuum.io/conda/build.html +:: https://conda.io/docs/user-guide/tasks/build-packages/environment-variables.html :: for a list of environment variables that are set during the build process. From 1d686b7c8a364a282bdb9430b4a7c22dcf689dba Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 7 Jan 2019 13:06:10 +0100 Subject: [PATCH 042/405] RoryYorke's build fix on .travis.yml --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 62bc33d9..ae1cdb4a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -36,7 +36,7 @@ install: - export PATH="$HOME/miniconda/bin:$PATH" - hash -r - conda config --set always_yes yes --set changeps1 no - - conda update -q conda + - conda update -q --all - if [[ $TEST_CONDA == 1 ]]; then conda install conda-build; fi - conda info -a # From 01b92e37e3847bfb92f36747414a8c8ddd8ee52b Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Fri, 18 Jan 2019 17:38:16 +0200 Subject: [PATCH 043/405] FIX: correct URL for Travis CI build badge The URL is case-sensitive. --- README.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.rst b/README.rst index a723ad4a..5e5f27a0 100644 --- a/README.rst +++ b/README.rst @@ -7,8 +7,8 @@ Slycot .. image:: https://anaconda.org/conda-forge/slycot/badges/version.svg :target: https://anaconda.org/conda-forge/slycot -.. image:: https://travis-ci.org/python-control/slycot.svg?branch=master - :target: https://travis-ci.org/python-control/slycot +.. image:: https://travis-ci.org/python-control/Slycot.svg?branch=master + :target: https://travis-ci.org/python-control/Slycot .. image:: https://coveralls.io/repos/python-control/slycot/badge.png :target: https://coveralls.io/r/python-control/slycot From d23ab7b5d733af30e2db1ce2e728346f62981eaa Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Fri, 18 Jan 2019 19:43:46 +0200 Subject: [PATCH 044/405] FIX: on Travis, install local slycot with dependencies. Got local::slycot usage from Kale Franz' "Conda Tips & Tricks" slides [1]; couldn't find docs for it elsewhere. [1] https://www.slideshare.net/continuumio/conda-tips-and-tricks-anacondacon-2018 --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 932f7342..542aa8ac 100644 --- a/.travis.yml +++ b/.travis.yml @@ -65,8 +65,8 @@ install: - if [[ $TEST_CONDA == 1 ]]; then conda config --append channels conda-forge; conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe-openblas; - conda install -c conda-forge openblas >=0.3.0; - conda install --override-channels -c local slycot; + conda install conda-forge::openblas>=0.3.0; + conda install local::slycot; else CMAKE_GENERATOR="Unix Makefiles" python setup.py install; fi From f275e2ac5950856e9dafc45f0aecddefcf9f8c9b Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 30 Dec 2018 07:42:33 +0200 Subject: [PATCH 045/405] Don't use deprecated np.matrix in tests. This involves 1. changing np.matrix to np.array, or removing conversion from array to matrix, and in one case by-hand converting "string constructor". 2. replacing np.matrix "*" with np.array ".dot"; since we're still supporting Python 2.7, can't use "@". --- slycot/tests/test.py | 4 ++-- slycot/tests/test_sg02ad.py | 22 +++++++++++----------- slycot/tests/test_sg03ad.py | 19 ++++++++----------- 3 files changed, 21 insertions(+), 24 deletions(-) diff --git a/slycot/tests/test.py b/slycot/tests/test.py index 69e43d49..ec0b0720 100644 --- a/slycot/tests/test.py +++ b/slycot/tests/test.py @@ -12,8 +12,8 @@ def test_1(self): synthesis.sb02mt(1,1,1,1) def test_2(self): - from numpy import matrix - a = matrix("-2 0.5;-1.6 -5") + from numpy import array + a = array([[-2, 0.5], [-1.6, -5]]) Ar, Vr, Yr, VALRr, VALDr = math.mb05md(a, 0.1) def test_sb02ad(self): diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py index 7fe0bf65..60627014 100644 --- a/slycot/tests/test_sg02ad.py +++ b/slycot/tests/test_sg02ad.py @@ -18,24 +18,24 @@ def test_sg02ad_case1(self): m = 1 # from a discussion here: # https://github.com/scipy/scipy/issues/2251 - A = np.matrix([[ 0.63399379, 0.54906824, 0.76253406], + A = np.array([[ 0.63399379, 0.54906824, 0.76253406], [ 0.5404729 , 0.53745766, 0.08731853], [ 0.27524045, 0.84922129, 0.4681622 ]]) - B = np.matrix([[ 0.96861695],[ 0.05532739],[ 0.78934047]]) - Q = np.matrix(np.eye(3)) - E = np.matrix(np.eye(3)) - R = np.matrix(np.ones((1,1), dtype=float)) - S = np.matrix([[-2.67522766, -5.39447418, 2.19128542], - [-1.94918951, -3.15480639, 5.24379117], - [ 4.29133973, 8.10585767, -5.88895897]]) - L = np.matrix(np.zeros((3,1))) + B = np.array([[ 0.96861695],[ 0.05532739],[ 0.78934047]]) + Q = np.eye(3) + E = np.eye(3) + R = np.ones((1,1), dtype=float) + S = np.array([[-2.67522766, -5.39447418, 2.19128542], + [-1.94918951, -3.15480639, 5.24379117], + [ 4.29133973, 8.10585767, -5.88895897]]) + L = np.array(np.zeros((3,1))) rcondu, X, alphar, alphai, beta, S, T, U, iwarn = \ synthesis.sg02ad('D', 'B', 'N', 'U', 'Z', 'N', 'S', 'R', n, m, 1, A, E, B, Q, R, L) assert_almost_equal( - A.T*X*A - E.T*X*E - - (L + A.T*X*B) * np.linalg.solve (R+B.T*X*B, (L+A.T*X*B).T) + + A.T.dot(X).dot(A) - E.T.dot(X).dot(E) - + (L + A.T.dot(X).dot(B)) .dot( np.linalg.solve (R+B.T.dot(X).dot(B), (L+A.T.dot(X).dot(B)).T) ) + Q, np.zeros((n,n))) diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index 40f9684c..7b498d6a 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -21,12 +21,9 @@ def test_sg03ad_a(self): Xref = np.ones((n,n)) U = np.tril(Xref) for t in range(0, 50, 10): - A = np.matrix( - 2.0**(-t) - np.eye(n) + np.diag(range(1,n+1)) + U.T) - #print(A) - #print(t, n) - E = np.matrix(np.eye(n) + 2**(-t)*U) - Y = A.T*Xref*E + E.T*Xref*A + A = 2.0**(-t) - np.eye(n) + np.diag(range(1,n+1)) + U.T + E = np.eye(n) + 2**(-t)*U + Y = A.T.dot(Xref).dot(E) + E.T.dot(Xref).dot(A) Q = np.zeros((n,n)) Z = np.zeros((n,n)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ @@ -35,20 +32,20 @@ def test_sg03ad_a(self): def test_sg03ad_3(self): n = 3 - A = np.matrix([[3.0, 1.0, 1.0], + A = np.array([[3.0, 1.0, 1.0], [1.0, 3.0, 0.0], [1.0, 0.0, 2.0]]) - E = np.matrix([[1.0, 3.0, 0.0], + E = np.array([[1.0, 3.0, 0.0], [3.0, 2.0, 1.0], [1.0, 0.0, 1.0]]) - Y = np.matrix([[64.0, 73.0, 28.0], + Y = np.array([[64.0, 73.0, 28.0], [73.0, 70.0, 25.0], [28.0, 25.0, 18.0]]) Xref = np.array([[-2.0000, -1.0000, 0.0000], [-1.0000, -3.0000, -1.0000], [0.0000, -1.0000, -3.0000]]) - Q = np.matrix(np.zeros((3,3))) - Z = np.matrix(np.zeros((3,3))) + Q = np.zeros((3,3)) + Z = np.zeros((3,3)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, -Y) #print(A, E, Q, Z, X, scale, sep) From e07c497488a78277564157a09e27d43be44f33b8 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Fri, 18 Jan 2019 21:19:12 +0200 Subject: [PATCH 046/405] New: add Python 3.7 to configs tested on Travis CI Travis doesn't support Python 3.7 on the current default Ubuntu 14.04 image, so manage via our own build matrix. --- .travis.yml | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index 542aa8ac..45a0506e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,14 +1,25 @@ # Travis configuration file for slycot -language: python +matrix: + include: + - name: "Python 2.7, TEST_CONDA=0" + env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=0 + - name: "Python 2.7, TEST_CONDA=1" + env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 -python: - - "2.7" - - "3.5" - - "3.6" + - name: "Python 3.5, TEST_CONDA=0" + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 + - name: "Python 3.5, TEST_CONDA=1" + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 -env: - - TEST_CONDA=0 - - TEST_CONDA=1 + - name: "Python 3.6, TEST_CONDA=0" + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 + - name: "Python 3.6, TEST_CONDA=1" + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 + + - name: "Python 3.7, TEST_CONDA=0" + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 + - name: "Python 3.7, TEST_CONDA=1" + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 before_install: # @@ -27,7 +38,7 @@ install: # Install miniconda to allow quicker installation of dependencies # See https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html # - - if [[ "$TRAVIS_PYTHON_VERSION" == "2.7" ]]; then + - if [[ "$SLYCOT_PYTHON_VERSION" == "2.7" ]]; then wget http://repo.continuum.io/miniconda/Miniconda2-latest-Linux-x86_64.sh -O miniconda.sh; else wget http://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh; @@ -41,7 +52,7 @@ install: - conda info -a # # Set up a test environment for testing everything out - - conda create -q -n test-environment python="$TRAVIS_PYTHON_VERSION" pip coverage nose numpy openblas + - conda create -q -n test-environment python="$SLYCOT_PYTHON_VERSION" pip coverage nose numpy openblas - source activate test-environment # @@ -64,7 +75,7 @@ install: # - if [[ $TEST_CONDA == 1 ]]; then conda config --append channels conda-forge; - conda build --python "$TRAVIS_PYTHON_VERSION" conda-recipe-openblas; + conda build --python "$SLYCOT_PYTHON_VERSION" conda-recipe-openblas; conda install conda-forge::openblas>=0.3.0; conda install local::slycot; else From 6d1415b64800a028a1ff59f6be4bd6eb96d54cb7 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sat, 16 Mar 2019 18:45:46 +0100 Subject: [PATCH 047/405] td04ad: testcase for issue #6 --- slycot/tests/test_td04ad.py | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index 7d97a512..fd763c70 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -129,6 +129,21 @@ def test_toandfrom(self): n, At, Bt, Ct, Dt = transform.td04ad('R', 2, 2, idxc, den, num) np.testing.assert_array_almost_equal(D, Dt) np.testing.assert_array_almost_equal(A, At) + + def test_tfm2ss_6(self): + """Python version of Fortran test program from + -- Bug in TD04AD when ROWCOL='C' #6""" + m = 1 + p = 1 + index = np.array([0]) + dcoeff = np.array([[0.5]]) + ucoeff = np.array([[[32]]]) + n, A, B, C, D = transform.td04ad('R', m, p, index, dcoeff, ucoeff) + self.assertEqual(n, 0) + np.testing.assert_array_almost_equal(D, np.array([[64]])) + n, A, B, C, D = transform.td04ad('C', m, p, index, dcoeff, ucoeff) + self.assertEqual(n, 0) + np.testing.assert_array_almost_equal(D, np.array([[64]])) def suite(): return unittest.TestLoader().loadTestsFromTestCase(TestTF2SS) From 8a5b02d0d7c7448139ffa7b04ae4ad990fb5836b Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sat, 16 Mar 2019 22:17:54 +0100 Subject: [PATCH 048/405] README.rst update for new buildsystem, issues #48, #47, #15 --- README.rst | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/README.rst b/README.rst index 5e5f27a0..08f23df2 100644 --- a/README.rst +++ b/README.rst @@ -21,18 +21,20 @@ Dependencies ------------ Slycot depends on Numpy and, if you are installing a binary distribution, -Numpy should be the only prerequisite (though you may need the LAPACK +Numpy should be the only prerequisite (though you may need LAPACK libraries as well, depending on your particular system configuration). If you are installing Slycot from source, you will need a FORTRAN -compiler, such as gfortran, and BLAS/LAPACK libraries. The build -system uses skbuild (scikit-buildsystem >= 0.8.1) and cmake. +compiler, such as gfortran, and BLAS/LAPACK libraries. Openblas is +also supported. The build system uses skbuild (scikit-buildsystem >= +0.8.1) and cmake. -On Debian derivatives you should be able to install all the above with a -single command:: +On Debian derivatives you should be able to install OpenBLAS using:: - sudo apt-get build-dep python-scipy + sudo apt-get install libopenblas-dev +Additionally install cmake and install scikit-build with pip or conda. + On Mac, you will first need to install the `developer tools `_. You can then install gfortran using `homebrew `_ with:: @@ -43,6 +45,8 @@ On Windows, the BLAS and LAPACK libraries can be obtained from: http://icl.cs.utk.edu/lapack-for-windows/libraries/VisualStudio/3.4.1/Dynamic-MINGW/Win32/ +Alternatively, use conda to install BLAS and LAPACK or OpenBLAS + Installing ----------- @@ -84,10 +88,14 @@ e.g. ``/path/to/slycot_src/``, and execute:: Where # is for commands that needs to be executed as root/administrator. -If the build fails and you are on a 64bit OS you may want to try:: +If you need to specify a specific compiler, set the environment +variable FC before running the install:: - python setup.py config_fc --arch="-march=x86-64" build - python setup.py install + # Linux/OSX: + export FC=/path/to/my/fortran + + # Windows: + set FC=D:\path\to\my\fortran.exe You can also use conda to build and install slycot from source:: @@ -101,7 +109,9 @@ Additional tips for how to install slycot from source can be found in the .travis.yml (commands used for Travis CI) and conda-recipe/ (conda pre-requisities). The hardest part about installing from source is getting a working version of FORTRAN and LAPACK installed on your system and working -properly with Python. If you are using conda, you can also get working +properly with Python. On Windows, the build system currently uses +flang, which can be installed from conda-forge. +If you are using conda, you can also get working (binary) copies of LAPACK from conda-forge using the command:: conda install -c conda-forge lapack From 72282f79ac4fe48b422eed3faff3a1867dd6cf52 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Thu, 11 Apr 2019 21:46:43 +0200 Subject: [PATCH 049/405] Update README to indicate Python2.7 and flang are not compatible --- README.rst | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/README.rst b/README.rst index 08f23df2..8aa7658f 100644 --- a/README.rst +++ b/README.rst @@ -107,10 +107,14 @@ If you prefer to use the OpenBLAS library, a conda recipe is available in Additional tips for how to install slycot from source can be found in the .travis.yml (commands used for Travis CI) and conda-recipe/ (conda -pre-requisities). The hardest part about installing from source is getting +pre-requisities). + +The hardest part about installing from source is getting a working version of FORTRAN and LAPACK installed on your system and working properly with Python. On Windows, the build system currently uses -flang, which can be installed from conda-forge. +flang, which can be installed from conda-forge. Note that flang is +incompatible with Python 2.7. + If you are using conda, you can also get working (binary) copies of LAPACK from conda-forge using the command:: From b30b0c284b6c9346434b83611a8530b313106a64 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Thu, 11 Apr 2019 21:52:42 +0200 Subject: [PATCH 050/405] Clarify comment, indicating bug has been fixed --- slycot/tests/test_td04ad.py | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index fd763c70..ab2aa3ee 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -131,8 +131,9 @@ def test_toandfrom(self): np.testing.assert_array_almost_equal(A, At) def test_tfm2ss_6(self): - """Python version of Fortran test program from - -- Bug in TD04AD when ROWCOL='C' #6""" + """Python version of Fortran test program from + -- Bug in TD04AD when ROWCOL='C' #6 + This bug was fixed in PR #27""" m = 1 p = 1 index = np.array([0]) From 95355fd473e2218ebbae2649c89fd16243698db7 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sat, 13 Apr 2019 15:49:09 +0200 Subject: [PATCH 051/405] fix building for conda * update recipes to follow developments in conda-build * fix cmakelists.txt and setup.py * base version calculation on git data * do not detect or require cxx from scikit-build/cmake --- CMakeLists.txt | 6 +- conda-recipe-openblas/bld.bat | 70 ++-------------------- conda-recipe-openblas/build.sh | 9 ++- conda-recipe-openblas/meta.yaml | 50 +++++++++------- conda-recipe/bld.bat | 10 +++- conda-recipe/build.sh | 13 +++++ conda-recipe/meta.yaml | 52 ++++++++++------- setup.py | 100 +++++++++++++++++--------------- slycot/setup.py | 75 ------------------------ 9 files changed, 150 insertions(+), 235 deletions(-) delete mode 100644 slycot/setup.py diff --git a/CMakeLists.txt b/CMakeLists.txt index 12d61a67..63b32e03 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,16 +6,16 @@ if (CMAKE_VERSION VERSION_GREATER "3.11.99") cmake_policy(SET CMP0074 NEW) endif() -project(slycot VERSION ${SLYCOT_VERSION}) +project(slycot VERSION ${SLYCOT_VERSION} LANGUAGES NONE) # Fortran detection fails on windows, use the CMAKE_C_SIMULATE flag to # force success if(WIN32) set(CMAKE_Fortran_SIMULATE_VERSION 19.0) -# set(CMAKE_Fortran_COMPILER_FORCED TRUE) -# set(CMAKE_C_COMPILER_VERSION 19.0) endif() +# this does not seem to work, maybe scikit-build's doing? the cxx compiler is +# still tested enable_language(C) enable_language(Fortran) diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index 372501cb..f5218f4a 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -2,71 +2,13 @@ cd %RECIPE_DIR% cd .. -:: indicating fortran compiler is essential -set FC=%BUILD_PREFIX%\Library\bin\flang.exe +:: Clear old build attempts +RD /S /Q _skbuild -:: The batch file created by conda-build sets a load of environment variables -:: Building worked fine without conda; apparently one or more of these -:: variables produce test & link failures. Resetting most of these here -set ARCH= -set BUILD= -set BUILD_PREFIX= -set CMAKE_GENERATOR= -set CommandPromptType= -set CPU_COUNT= -set DISTUTILS_USE_SDK= -set folder= -set cpu_optimization_target= -set fortran_compiler= -set Framework40Version= -set FrameworkDir= -set FrameworkDIR64= -set FrameworkVersion= -set FrameworkVersion64= -set ignore_build_only_deps= -set CFLAGS= -set CXXFLAGS= -set cxx_compiler= -set c_compiler= -set INCLUDE= -set LDFLAGS_SHARED= -set LIBPATH= -set LIB=;%LIB% -set MSSdk= -set MSYS2_ARG_CONV_EXCL= -set MSYS2_ENV_CONV_EXCL= -set NETFSXDIR= -set PIP_IGNORE_INSTALLED= -set platform= -set WindowsLibPath= -set WindowsSdkDir= -set CYGWIN_PREFIX= -set SRC_DIR= -set STDLIB_DIR= -set SUBDIR= -set SYS_PREFIX= -set target_platform= -set UCRTVersion= -set UniversalCRTSdkDir= -set VCINSTALLDIR= -set vc= -set win= -set VisualStudioVersion= -set VSINSTALLDIR= -set VSREGKEY= -set VS_MAJOR= -set VS_VERSION= -set VS_YEAR= -set WindowsSDKLibVersion= -set WindowsSDKVersion= -set WindowsSDKExecutablePath_x64= -set WindowsSDKExecutablePath_x86= - -:: information on remaining variables -set - -set BLAS_ROOT=%CONDA_PREFIX% -set LAPACK_ROOT=%CONDA_PREFIX% +set BLAS_ROOT=%PREFIX% +set LAPACK_ROOT=%PREFIX% +set NUMPY_INCLUDE=%PREFIX%\Include +set F2PY=%PREFIX%\Scripts\f2py.exe "%PYTHON%" setup.py install diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index 6868b900..fad66798 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -3,7 +3,12 @@ cd $RECIPE_DIR/.. # specify where CMAKE will search for lapack and blas # needs recent cmake (conda's 3.12) and policy CMP0074 NEW -export BLAS_ROOT=${CONDA_PREFIX} -export LAPACK_ROOT=${CONDA_PREFIX} +# the ${PREFIX} points to conda-build's host environment +export BLAS_ROOT=${PREFIX} +export LAPACK_ROOT=${PREFIX} +# ensure we are not building with old cmake files +rm -rf _skbuild + +# do the build $PYTHON setup.py install diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 020c0f01..cd90047a 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -1,41 +1,47 @@ package: name: slycot - version: "0.3.3" + version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} + +source: + git_url: ../ build: - number: 0 + number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_obl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: - host: - - python {{PY_VER}} - - flang # [win] - - {{ compiler('c') }} # [win] - - {{ compiler('fortran') }} # [not win] - - numpy - - scikit-build >=0.8.0 - build: - - numpy - - libflang # [win] - - libgfortran # [not win] + - python {{ PY_VER }} + - numpy >=1.16 + - openblas >=0.3.0 + - {{ compiler('c') }} # [not osx] + - gcc # [osx] + - {{ compiler('fortran') }} # [linux] + - scikit-build >=0.8.0 + + host: + - python {{ PY_VER }} + - flang # [win] + - numpy >=1.16 - openblas >=0.3.0 + - libgfortran-ng # [not-win] + - libgcc-ng # [linux] + - scikit-build >=0.8.0 # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 run: - - numpy + - python {{ PY_VER }} + - numpy >=1.16 - openblas >=0.3.0 - - libgfortran # [not win] - - libflang # [win] + - libgfortran-ng # [not win] + - libgcc-ng # [linux] + - libflang # [win] test: requires: - - numpy - - openblas - python {{PY_VER}} - - libgfortran # [not win] - - libflang # [win] imports: - slycot @@ -43,3 +49,7 @@ about: home: https://github.com/python-control/slycot license: GPLv2 summary: 'A wrapper for the SLICOT control and systems library' + +# on OSX, the SDK for 10.9 is currently needed +# download the 10.9 sdk from https://github.com/phracker/MacOSX-SDKs/releases +# unpack and set environment variable CONDA_BUILD_SYSROOT to that location diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index c5294765..01aab363 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -2,10 +2,14 @@ cd %RECIPE_DIR% cd .. -set F77=%BUILD_PREFIX%\Library\bin\flang.exe -set F90=%BUILD_PREFIX%\Library\bin\flang.exe +:: clean old build attempts +RD /S /Q _skbuild + +set BLAS_ROOT=%PREFIX% +set LAPACK_ROOT=%PREFIX% +set NUMPY_INCLUDE=%PREFIX%\Include +set F2PY=%PREFIX%\Scripts\f2py.exe -"%PYTHON%" setup.py build "%PYTHON%" setup.py install if errorlevel 1 exit 1 diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index abebc130..fd92a091 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,2 +1,15 @@ cd $RECIPE_DIR/.. + +# specify where CMAKE will search for lapack and blas +# needs recent cmake (conda's 3.12) and policy CMP0074 NEW +# the ${PREFIX} points to conda-build's host environment +export BLAS_ROOT=${PREFIX} +export LAPACK_ROOT=${PREFIX} + +# ensure we are not building with old cmake files +rm -rf _skbuild + +env + +# do the build $PYTHON setup.py install diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index d72239b1..6f62c3c6 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -1,41 +1,51 @@ package: name: slycot - version: "0.3.3" + version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} + +source: + git_url: ../ build: - number: 0 + number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_mkl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: - host: + # note: the osx build is with gcc for now, due to problems with the + # conda-supplied clang and library linking see e.g. + # https://github.com/conda-forge/mpi-feedstock issue #4 + # conda-forge might have the configuration in place for clang build and link? + build: - python {{PY_VER}} - - numpy - - flang # [win] - - {{ compiler('c') }} # [win] - - {{ compiler('fortran') }} # [not win] - - scikit-build >=0.8.0 + - numpy >=1.16 + - {{ compiler('c') }} # [not osx] + - gcc # [osx] + - {{ compiler('fortran') }} # [linux] + - scikit-build >=0.8.0 - build: - - numpy - - libflang # [win] - - libgfortran # [not win] - - lapack + host: + - python {{ PY_VER }} + - flang # [win] + - numpy >=1.16 + - mkl + - libgfortran-ng # [not win] + - libgcc-ng # [linux] + - libflang # [win] + - scikit-build >=0.8.0 # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 run: - - numpy - - lapack - - libgfortran # [not win] - - libflang # [win] + - python {{ PY_VER }} + - numpy >=1.16 + - mkl + - libgfortran-ng # [not win] + - libgcc-ng # [linux] + - libflang # [win] test: requires: - - numpy - - lapack - python {{PY_VER}} - - libgfortran # [not win] - - libflang # [win] imports: - slycot diff --git a/setup.py b/setup.py index d015cddd..9d50bd33 100644 --- a/setup.py +++ b/setup.py @@ -42,14 +42,11 @@ Operating System :: MacOS """ -MAJOR = 0 -MINOR = 3 -MICRO = 4 -POST = 0 +# defaults ISRELEASED = False -VERSION = '%d.%d.%d' % (MAJOR, MINOR, MICRO) -if POST != 0: - VERSION += '-post{:d}'.format(POST) +# assume a version set by conda, next update with git, +# otherwise count on default +VERSION = '0.3.3' # Return the git revision as a string def git_version(srcdir=None): @@ -72,12 +69,19 @@ def _minimal_ext_cmd(cmd, srcdir): return out try: + GIT_VERSION = VERSION + GIT_REVISION = 'Unknown' + CIT_CYCLE = 0 out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD'], srcdir) GIT_REVISION = out.strip().decode('ascii') + out = _minimal_ext_cmd(['git', 'tag'], srcdir) + GIT_VERSION = out.strip().decode('ascii').split('\n')[-1][1:] + out = _minimal_ext_cmd(['git', 'describe', '--tags'], srcdir) + GIT_CYCLE = out.strip().decode('ascii').split('-')[1] except OSError: - GIT_REVISION = "Unknown" + pass - return GIT_REVISION + return GIT_VERSION, GIT_REVISION, GIT_CYCLE # BEFORE importing distutils, remove MANIFEST. distutils doesn't properly # update it when the contents of directories change. @@ -91,13 +95,19 @@ def _minimal_ext_cmd(cmd, srcdir): builtins.__SLYCOT_SETUP__ = True -def get_version_info(): +def get_version_info(srcdir=None): + global ISRELEASED + # Adding the git rev number needs to be done inside write_version_py(), # otherwise the import of slycot.version messes up # the build under Python 3. - FULLVERSION = VERSION - if os.path.exists('.git'): - GIT_REVISION = git_version() + if os.environ.get('CONDA_BUILD', False): + FULLVERSION = os.environ.get('PKG_VERSION', '???') + GIT_REVISION = '' + GIT_CYCLE = 0 + ISRELEASED = True + elif os.path.exists('.git'): + FULLVERSION, GIT_REVISION, GIT_CYCLE = git_version(srcdir) elif os.path.exists('slycot/version.py'): # must be a source distribution, use existing version file try: @@ -107,38 +117,14 @@ def get_version_info(): "slycot/version.py and the build directory " "before building.") else: + FULLVERSION = VERSION GIT_REVISION = "Unknown" if not ISRELEASED: - FULLVERSION += '.dev-' + GIT_REVISION[:7] + FULLVERSION += '.' + str(GIT_CYCLE) return FULLVERSION, GIT_REVISION - -def write_version_py(filename='slycot/version.py'): - cnt = """ -# THIS FILE IS GENERATED FROM SLYCOT SETUP.PY -short_version = '%(version)s' -version = '%(version)s' -full_version = '%(full_version)s' -git_revision = '%(git_revision)s' -release = %(isrelease)s - -if not release: - version = full_version -""" - FULLVERSION, GIT_REVISION = get_version_info() - - a = open(filename, 'w') - try: - a.write(cnt % {'version': VERSION, - 'full_version': FULLVERSION, - 'git_revision': GIT_REVISION, - 'isrelease': str(ISRELEASED)}) - finally: - a.close() - - def configuration(parent_package='', top_path=None): from numpy.distutils.misc_util import Configuration config = Configuration(None, parent_package, top_path) @@ -190,11 +176,11 @@ def setup_package(): sys.path.insert(0, src_path) # Rewrite the version file everytime - #write_version_py(src_path+'/slycot/version.py') - gitrevision = git_version(src_path) + VERSION, gitrevision = get_version_info(src_path) metadata = dict( name='slycot', + cmake_languages=('C', 'Fortran'), version=VERSION, maintainer="Slycot developers", maintainer_email="python-control-discuss@lists.sourceforge.net", @@ -220,16 +206,36 @@ def setup_package(): # tools have improved, most of this might be removed? import platform if platform.system() == 'Windows': + pbase = r'/'.join(sys.executable.split(os.sep)[:-1]) + env2cmakearg = { + 'FC': ('-DCMAKE_Fortran_COMPILER=', + pbase + r'/Library/bin/flang.exe'), + 'F2PY': ('-DF2PY_EXECUTABLE=', + pbase + r'/Scripts/f2py.exe'), + 'NUMPY_INCLUDE': ('-DNumPy_INCLUDE_DIR=', + pbase + r'/Include') + } + + metadata['cmake_args'].extend([ + '-GNMake Makefiles']) + + for k, v in env2cmakearg.items(): + print(k, v, os.environ.get(k, '')) + envval = os.environ.get(k, None) + if envval: + # get from environment + metadata['cmake_args'].append( + v[0] + envval.replace('\\', '/')) + else: + # default + metadata['cmake_args'].append(v[0] + v[1]) + metadata['cmake_args'].extend([ - '-GNMake Makefiles', - '-DF2PY_EXECUTABLE=' + pbase + r'/Scripts/f2py.bat', - '-DCMAKE_Fortran_COMPILER=' + pbase + r'/Library/bin/flang.exe', + '-DCMAKE_Fortran_SIMULATE_VERSION=5.0.0', '-DCMAKE_Fortran_COMPILER_ID=Flang', - '-DCMAKE_C_COMPILER_ID=MSVC', - '-DCMAKE_C_COMPILER_VERSION=19.0.0', - '-DNumPy_INCLUDE_DIR=' + pbase + r'/Include', '-DCMAKE_VERBOSE_MAKEFILE:BOOL=ON' ]) + print(metadata['cmake_args']) try: setup(**metadata) finally: diff --git a/slycot/setup.py b/slycot/setup.py deleted file mode 100644 index e8a1010d..00000000 --- a/slycot/setup.py +++ /dev/null @@ -1,75 +0,0 @@ -#!/usr/bin/env python -from __future__ import division, print_function -import glob -import os -import sys -import sysconfig - -def configuration(parent_package='', top_path=None): - from numpy.distutils.misc_util import Configuration - config = Configuration('slycot', parent_package, top_path) - - # can disable building extension to test packaging - build_fortran = True - - if build_fortran: - fortran_sources = glob.glob( - os.path.join('slycot', 'src', '*.f')) - else: - print('WARNING FORTRAN BUILD DISABLED') - fortran_sources = [] - - f2py_sources = ['src/_wrapper.pyf'] - - pyver = sysconfig.get_config_var('VERSION') - - if sys.platform == 'win32': - liblist = [ 'openblas', 'flang' ] - extra_objects = [ ] - ppath = os.sep.join(sys.executable.split(os.sep)[:-1]) - - library_dirs = [r'\Library\lib', ] - library_dirs = [ppath + l for l in library_dirs] - extra_link_args = [ ] - extra_compile_args = [ ] - else: - # this is needed on Py 3.x, and fails on Py 2.7 - try: - abiflags = sys.abiflags - except AttributeError: - abiflags = '' - extra_objects = [] - ppath = os.sep.join(sys.executable.split(os.sep)[:-2]) - library_dirs = [r'/lib', ] - library_dirs = [ppath + l for l in library_dirs] - if sys.platform == 'darwin': - liblist = ['openblas' ] - extra_link_args = [ '-Wl,-dylib,-undefined,dynamic_lookup' ] - extra_compile_args = [ '-fPIC' ] - else: - liblist = ['openblas'] - extra_link_args = [ '-shared', '-Wl,--allow-shlib-undefined' ] - extra_compile_args = [ '-fPIC' ] - - # override when libraries have been specified - if os.environ.get("LAPACKLIBS", None): - liblist = os.environ.get("LAPACKLIBS").split(':') - print("Overriding library list with", liblist) - - config.add_extension( - name='_wrapper', - libraries=liblist, - extra_objects=extra_objects, - extra_link_args=extra_link_args, - library_dirs=library_dirs, - extra_compile_args=extra_compile_args, - sources=fortran_sources + f2py_sources) - - config.make_config_py() # installs __config__.py - - config.add_subpackage('tests') - - return config - -if __name__ == '__main__': - print('This is the wrong setup.py file to run') From 864f093d5d1c5e2216b7721887011070b8091e1d Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Tue, 23 Apr 2019 18:06:00 +0200 Subject: [PATCH 052/405] Fix: allow conda builds with Python 3.5 (#56) Use f2py.exe for F2PY if it exists; this is the case for Numpy 1.16, which has been packaged for Python 3.6 and 3.7 in conda or conda-forge. If f2py.exe is not found, use f2py.bat; this is the case for Numpy 1.15, which has been pacakge for Python 3.5. Use pin_compatible for numpy version requirements; at time of this check-in, this builds against Numpy 1.9.3 on Linux, but tests against 1.16. --- conda-recipe-openblas/bld.bat | 8 +++++++- conda-recipe-openblas/meta.yaml | 6 +++--- conda-recipe/bld.bat | 8 +++++++- conda-recipe/meta.yaml | 6 +++--- 4 files changed, 20 insertions(+), 8 deletions(-) diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index f5218f4a..dfccb158 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -8,7 +8,13 @@ RD /S /Q _skbuild set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% set NUMPY_INCLUDE=%PREFIX%\Include -set F2PY=%PREFIX%\Scripts\f2py.exe +:: Prefer f2py.exe, if it exists; this is provided by numpy 1.16 (and, we assume, later) +if EXIST "%PREFIX%\Scripts\f2py.exe" ( + set F2PY=%PREFIX%\Scripts\f2py.exe +) ELSE ( +:: Otherwise use f2py.bat, which is provided by numpy 1.15 and earlier + set F2PY=%PREFIX%\Scripts\f2py.bat +) "%PYTHON%" setup.py install diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index cd90047a..8dcc1056 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -12,7 +12,7 @@ build: requirements: build: - python {{ PY_VER }} - - numpy >=1.16 + - numpy - openblas >=0.3.0 - {{ compiler('c') }} # [not osx] - gcc # [osx] @@ -22,7 +22,7 @@ requirements: host: - python {{ PY_VER }} - flang # [win] - - numpy >=1.16 + - numpy - openblas >=0.3.0 - libgfortran-ng # [not-win] - libgcc-ng # [linux] @@ -33,7 +33,7 @@ requirements: run: - python {{ PY_VER }} - - numpy >=1.16 + - {{ pin_compatible('numpy') }} - openblas >=0.3.0 - libgfortran-ng # [not win] - libgcc-ng # [linux] diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 01aab363..23e8a339 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -8,7 +8,13 @@ RD /S /Q _skbuild set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% set NUMPY_INCLUDE=%PREFIX%\Include -set F2PY=%PREFIX%\Scripts\f2py.exe +:: Prefer f2py.exe, if it exists; this is provided by numpy 1.16 (and, we assume, later) +if EXIST "%PREFIX%\Scripts\f2py.exe" ( + set F2PY=%PREFIX%\Scripts\f2py.exe +) ELSE ( +:: Otherwise use f2py.bat, which is provided by numpy 1.15 and earlier + set F2PY=%PREFIX%\Scripts\f2py.bat +) "%PYTHON%" setup.py install diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 6f62c3c6..45605775 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -16,7 +16,7 @@ requirements: # conda-forge might have the configuration in place for clang build and link? build: - python {{PY_VER}} - - numpy >=1.16 + - numpy - {{ compiler('c') }} # [not osx] - gcc # [osx] - {{ compiler('fortran') }} # [linux] @@ -25,7 +25,7 @@ requirements: host: - python {{ PY_VER }} - flang # [win] - - numpy >=1.16 + - numpy - mkl - libgfortran-ng # [not win] - libgcc-ng # [linux] @@ -37,7 +37,7 @@ requirements: run: - python {{ PY_VER }} - - numpy >=1.16 + - {{ pin_compatible('numpy') }} - mkl - libgfortran-ng # [not win] - libgcc-ng # [linux] From 9dc7e7a7728c232b4834ba97df5529c850314c82 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Tue, 23 Apr 2019 21:21:23 +0200 Subject: [PATCH 053/405] Fix-ups for release Add Python, Fortran, and CMakeLists to MANIFEST.in for source packaging. In setup.py, generate a setup.cfg to record version information in source package. Fix git interfacing used to find out version; in the absence of git, fall back to directory name for version name. --- MANIFEST.in | 7 +++++ setup.cfg.in | 6 ++++ setup.py | 85 +++++++++++++++++++++++++++++++--------------------- 3 files changed, 64 insertions(+), 34 deletions(-) create mode 100644 setup.cfg.in diff --git a/MANIFEST.in b/MANIFEST.in index eb4698f8..6b812bc3 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -4,3 +4,10 @@ include CREDITS include gpl-2.0.txt include README.rst include MANIFEST.in +include CMakeLists.txt +include slycot/CMakeLists.txt +include slycot/tests/CMakeLists.txt +include slycot/*.py +include slycot/version.py.in +include slycot/src/*.f +include slycot/tests/*.py diff --git a/setup.cfg.in b/setup.cfg.in new file mode 100644 index 00000000..9067d0c0 --- /dev/null +++ b/setup.cfg.in @@ -0,0 +1,6 @@ +[metadata] + +name = slycot +version = @version@ +gitrevision = @gitrevision@ +release = @release@ diff --git a/setup.py b/setup.py index 9d50bd33..e96946ce 100644 --- a/setup.py +++ b/setup.py @@ -12,7 +12,10 @@ import os import sys import subprocess - +try: + import configparser +except ImportError: + import ConfigParser as configparser if sys.version_info[:2] < (2, 6) or (3, 0) <= sys.version_info[0:2] < (3, 2): raise RuntimeError("Python version 2.6, 2.7 or >= 3.2 required.") @@ -43,12 +46,16 @@ """ # defaults -ISRELEASED = False +ISRELEASED = True # assume a version set by conda, next update with git, # otherwise count on default -VERSION = '0.3.3' +VERSION = 'Unkown' -# Return the git revision as a string +# Return the git version, revision and cycle +# +# Uses rev-parse to get the revision +# tag to get the version number from the latest tag +# and detects (approximate) revision cycles def git_version(srcdir=None): def _minimal_ext_cmd(cmd, srcdir): # construct minimal environment @@ -71,12 +78,12 @@ def _minimal_ext_cmd(cmd, srcdir): try: GIT_VERSION = VERSION GIT_REVISION = 'Unknown' - CIT_CYCLE = 0 + GIT_CYCLE = 0 out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD'], srcdir) GIT_REVISION = out.strip().decode('ascii') out = _minimal_ext_cmd(['git', 'tag'], srcdir) GIT_VERSION = out.strip().decode('ascii').split('\n')[-1][1:] - out = _minimal_ext_cmd(['git', 'describe', '--tags'], srcdir) + out = _minimal_ext_cmd(['git', 'describe', '--tags', '--long'], srcdir) GIT_CYCLE = out.strip().decode('ascii').split('-')[1] except OSError: pass @@ -94,49 +101,60 @@ def _minimal_ext_cmd(cmd, srcdir): # a lot more robust than what was previously being used. builtins.__SLYCOT_SETUP__ = True +def rewrite_setup_cfg(version, gitrevision, release): + toreplace = dict(locals()) + data = ''.join(open('setup.cfg.in', 'r').readlines()).split('@') + for k, v in toreplace.items(): + idx = data.index(k) + data[idx] = v + cfg = open('setup.cfg', 'w') + cfg.write(''.join(data)) + cfg.close() def get_version_info(srcdir=None): global ISRELEASED + GIT_CYCLE = 0 # Adding the git rev number needs to be done inside write_version_py(), # otherwise the import of slycot.version messes up # the build under Python 3. if os.environ.get('CONDA_BUILD', False): FULLVERSION = os.environ.get('PKG_VERSION', '???') - GIT_REVISION = '' - GIT_CYCLE = 0 + GIT_REVISION = os.environ.get('GIT_DESCRIBE_HASH', '') ISRELEASED = True + rewrite_setup_cfg(FULLVERSION, GIT_REVISION, 'yes') elif os.path.exists('.git'): - FULLVERSION, GIT_REVISION, GIT_CYCLE = git_version(srcdir) - elif os.path.exists('slycot/version.py'): - # must be a source distribution, use existing version file - try: - from slycot.version import git_revision as GIT_REVISION - except ImportError: - raise ImportError("Unable to import git_revision. Try removing " - "slycot/version.py and the build directory " - "before building.") + FULLVERSION, GIT_REVISION, GIT_CYCLE = git_version(srcdir) + ISRELEASED = (GIT_CYCLE == 0) + rewrite_setup_cfg(FULLVERSION, GIT_REVISION, + (ISRELEASED and 'yes') or 'no') + elif os.path.exists('setup.cfg'): + # valid distribution + setupcfg = configparser.ConfigParser() + setupcfg.read('setup.cfg') + FULLVERSION = setupcfg['metadata'].get('version', 'Unknown') + GIT_REVISION = setupcfg['metadata'].get('gitrevision', '') + return FULLVERSION, GIT_REVISION else: - FULLVERSION = VERSION - GIT_REVISION = "Unknown" + + # try to find a version number from the dir name + dname = os.getcwd().split(os.sep)[-1] + import re + + m = re.search(r'[0-9.]+', dname) + if m: + FULLVERSION = m.group() + GIT_REVISION = '' + + else: + FULLVERSION = VERSION + GIT_REVISION = "Unknown" if not ISRELEASED: FULLVERSION += '.' + str(GIT_CYCLE) return FULLVERSION, GIT_REVISION -def configuration(parent_package='', top_path=None): - from numpy.distutils.misc_util import Configuration - config = Configuration(None, parent_package, top_path) - config.set_options(ignore_setup_xxx_py=True, - assume_default_configuration=True, - delegate_options_to_subpackages=True, - quiet=True) - config.add_subpackage('slycot') - config.get_version('slycot/version.py') # sets config.version - return config - - def check_submodules(): """ verify that the submodules are checked out and clean use `git submodule update --init`; on failure @@ -158,8 +176,7 @@ def check_submodules(): if line.startswith('-') or line.startswith('+'): raise ValueError('Submodule not clean: %s' % line) -from distutils.command.sdist import sdist - +from skbuild.command.sdist import sdist class sdist_checked(sdist): """ check submodules on sdist to prevent incomplete tarballs """ @@ -188,7 +205,7 @@ def setup_package(): long_description="\n".join(DOCLINES[2:]), url='https://github.com/python-control/Slycot', author='Enrico Avventi et al.', - license='GPLv2', + license='GPL-2.0', classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], cmdclass={"sdist": sdist_checked}, From f0f07c6ef2b9eca1eb682c607369983bce32710b Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 28 Apr 2019 11:46:25 +0200 Subject: [PATCH 054/405] Build: report Git errors; handle shallow clones in 'git describe' --- setup.py | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/setup.py b/setup.py index e96946ce..7754dc0e 100644 --- a/setup.py +++ b/setup.py @@ -49,7 +49,11 @@ ISRELEASED = True # assume a version set by conda, next update with git, # otherwise count on default -VERSION = 'Unkown' +VERSION = 'Unknown' + +class GitError(RuntimeError): + """Exception for git errors occuring in in git_version""" + pass # Return the git version, revision and cycle # @@ -68,11 +72,17 @@ def _minimal_ext_cmd(cmd, srcdir): env['LANGUAGE'] = 'C' env['LANG'] = 'C' env['LC_ALL'] = 'C' - out = subprocess.Popen( + proc = subprocess.Popen( cmd, cwd=srcdir, stdout=subprocess.PIPE, - env=env).communicate()[0] + stderr=subprocess.PIPE, + env=env) + out, err = proc.communicate() + if proc.returncode: + errmsg = err.decode('ascii',errors='ignore').strip() + raise GitError("git err; return code %d, error message:\n '%s'" + % (proc.returncode, errmsg)) return out try: @@ -83,8 +93,12 @@ def _minimal_ext_cmd(cmd, srcdir): GIT_REVISION = out.strip().decode('ascii') out = _minimal_ext_cmd(['git', 'tag'], srcdir) GIT_VERSION = out.strip().decode('ascii').split('\n')[-1][1:] - out = _minimal_ext_cmd(['git', 'describe', '--tags', '--long'], srcdir) - GIT_CYCLE = out.strip().decode('ascii').split('-')[1] + out = _minimal_ext_cmd(['git', 'describe', '--tags', '--long','--always'], srcdir) + try: + # don't get a good description with shallow clones, e.g., on Travis + GIT_CYCLE = out.strip().decode('ascii').split('-')[1] + except IndexError: + pass except OSError: pass From 894245a4b9296e2cb7bf3606649d221b99e7790f Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Wed, 1 May 2019 07:51:23 +0200 Subject: [PATCH 055/405] Include setup.cfg.in in source distribution --- MANIFEST.in | 1 + 1 file changed, 1 insertion(+) diff --git a/MANIFEST.in b/MANIFEST.in index 6b812bc3..631e5327 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -4,6 +4,7 @@ include CREDITS include gpl-2.0.txt include README.rst include MANIFEST.in +include setup.cfg.in include CMakeLists.txt include slycot/CMakeLists.txt include slycot/tests/CMakeLists.txt From f9161be5fd1d076e487c184664e44c2c7e842cf9 Mon Sep 17 00:00:00 2001 From: "Jason K. Moore" Date: Fri, 3 May 2019 11:47:36 -0700 Subject: [PATCH 056/405] Use the readme as the long description in setup.py. --- setup.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/setup.py b/setup.py index 7754dc0e..411f6f24 100644 --- a/setup.py +++ b/setup.py @@ -216,7 +216,7 @@ def setup_package(): maintainer="Slycot developers", maintainer_email="python-control-discuss@lists.sourceforge.net", description=DOCLINES[0], - long_description="\n".join(DOCLINES[2:]), + long_description=open('README.rst').read(), url='https://github.com/python-control/Slycot', author='Enrico Avventi et al.', license='GPL-2.0', From eaf556eb271dc554c7542d658e07cd50475a8255 Mon Sep 17 00:00:00 2001 From: "Jason K. Moore" Date: Fri, 3 May 2019 11:53:48 -0700 Subject: [PATCH 057/405] Organization and PEP8 of setup.py. --- setup.py | 75 +++++++++++++++++++++++++++++--------------------------- 1 file changed, 39 insertions(+), 36 deletions(-) diff --git a/setup.py b/setup.py index 411f6f24..e290a14e 100644 --- a/setup.py +++ b/setup.py @@ -5,30 +5,34 @@ Slycot wraps the SLICOT library which is used for control and systems analysis. """ -from skbuild import setup - -DOCLINES = __doc__.split("\n") import os import sys import subprocess +import re +import platform try: import configparser except ImportError: import ConfigParser as configparser -if sys.version_info[:2] < (2, 6) or (3, 0) <= sys.version_info[0:2] < (3, 2): - raise RuntimeError("Python version 2.6, 2.7 or >= 3.2 required.") - if sys.version_info[0] >= 3: import builtins else: import __builtin__ as builtins +from skbuild import setup +from skbuild.command.sdist import sdist + # Fix a bug in python v3.4 installation -if (sys.version_info[0:2] == (3,4)): +if (sys.version_info[0:2] == (3, 4)): import importlib.machinery +if sys.version_info[:2] < (2, 6) or (3, 0) <= sys.version_info[0:2] < (3, 2): + raise RuntimeError("Python version 2.6, 2.7 or >= 3.2 required.") + +DOCLINES = __doc__.split("\n") + CLASSIFIERS = """\ Development Status :: 3 - Alpha Intended Audience :: Science/Research @@ -51,16 +55,19 @@ # otherwise count on default VERSION = 'Unknown' + class GitError(RuntimeError): """Exception for git errors occuring in in git_version""" pass -# Return the git version, revision and cycle -# -# Uses rev-parse to get the revision -# tag to get the version number from the latest tag -# and detects (approximate) revision cycles + def git_version(srcdir=None): + """Return the git version, revision and cycle + + Uses rev-parse to get the revision tag to get the version number from the + latest tag and detects (approximate) revision cycles + + """ def _minimal_ext_cmd(cmd, srcdir): # construct minimal environment env = {} @@ -80,7 +87,7 @@ def _minimal_ext_cmd(cmd, srcdir): env=env) out, err = proc.communicate() if proc.returncode: - errmsg = err.decode('ascii',errors='ignore').strip() + errmsg = err.decode('ascii', errors='ignore').strip() raise GitError("git err; return code %d, error message:\n '%s'" % (proc.returncode, errmsg)) return out @@ -93,7 +100,8 @@ def _minimal_ext_cmd(cmd, srcdir): GIT_REVISION = out.strip().decode('ascii') out = _minimal_ext_cmd(['git', 'tag'], srcdir) GIT_VERSION = out.strip().decode('ascii').split('\n')[-1][1:] - out = _minimal_ext_cmd(['git', 'describe', '--tags', '--long','--always'], srcdir) + out = _minimal_ext_cmd(['git', 'describe', '--tags', + '--long', '--always'], srcdir) try: # don't get a good description with shallow clones, e.g., on Travis GIT_CYCLE = out.strip().decode('ascii').split('-')[1] @@ -115,6 +123,7 @@ def _minimal_ext_cmd(cmd, srcdir): # a lot more robust than what was previously being used. builtins.__SLYCOT_SETUP__ = True + def rewrite_setup_cfg(version, gitrevision, release): toreplace = dict(locals()) data = ''.join(open('setup.cfg.in', 'r').readlines()).split('@') @@ -125,10 +134,11 @@ def rewrite_setup_cfg(version, gitrevision, release): cfg.write(''.join(data)) cfg.close() + def get_version_info(srcdir=None): global ISRELEASED GIT_CYCLE = 0 - + # Adding the git rev number needs to be done inside write_version_py(), # otherwise the import of slycot.version messes up # the build under Python 3. @@ -136,7 +146,7 @@ def get_version_info(srcdir=None): FULLVERSION = os.environ.get('PKG_VERSION', '???') GIT_REVISION = os.environ.get('GIT_DESCRIBE_HASH', '') ISRELEASED = True - rewrite_setup_cfg(FULLVERSION, GIT_REVISION, 'yes') + rewrite_setup_cfg(FULLVERSION, GIT_REVISION, 'yes') elif os.path.exists('.git'): FULLVERSION, GIT_REVISION, GIT_CYCLE = git_version(srcdir) ISRELEASED = (GIT_CYCLE == 0) @@ -153,13 +163,12 @@ def get_version_info(srcdir=None): # try to find a version number from the dir name dname = os.getcwd().split(os.sep)[-1] - import re m = re.search(r'[0-9.]+', dname) if m: FULLVERSION = m.group() GIT_REVISION = '' - + else: FULLVERSION = VERSION GIT_REVISION = "Unknown" @@ -169,6 +178,7 @@ def get_version_info(srcdir=None): return FULLVERSION, GIT_REVISION + def check_submodules(): """ verify that the submodules are checked out and clean use `git submodule update --init`; on failure @@ -190,7 +200,6 @@ def check_submodules(): if line.startswith('-') or line.startswith('+'): raise ValueError('Submodule not clean: %s' % line) -from skbuild.command.sdist import sdist class sdist_checked(sdist): """ check submodules on sdist to prevent incomplete tarballs """ @@ -202,13 +211,11 @@ def run(self): def setup_package(): src_path = os.path.dirname(os.path.abspath(sys.argv[0])) - old_path = os.getcwd() - #os.chdir(src_path) sys.path.insert(0, src_path) # Rewrite the version file everytime VERSION, gitrevision = get_version_info(src_path) - + metadata = dict( name='slycot', cmake_languages=('C', 'Fortran'), @@ -223,11 +230,10 @@ def setup_package(): classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], cmdclass={"sdist": sdist_checked}, - cmake_args=[ '-DSLYCOT_VERSION:STRING=' + VERSION, - '-DGIT_REVISION:STRING=' + gitrevision, - '-DISRELEASE:STRING=' + str(ISRELEASED), - '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7] ], - #cmake_source_dir=src_path, + cmake_args=['-DSLYCOT_VERSION:STRING=' + VERSION, + '-DGIT_REVISION:STRING=' + gitrevision, + '-DISRELEASE:STRING=' + str(ISRELEASED), + '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7]], zip_safe=False, ) @@ -235,9 +241,8 @@ def setup_package(): # Flang detection and configuration is not automatic yet; the CMAKE # settings below are to circumvent that; when scikit-build and cmake # tools have improved, most of this might be removed? - import platform if platform.system() == 'Windows': - + pbase = r'/'.join(sys.executable.split(os.sep)[:-1]) env2cmakearg = { 'FC': ('-DCMAKE_Fortran_COMPILER=', @@ -247,9 +252,8 @@ def setup_package(): 'NUMPY_INCLUDE': ('-DNumPy_INCLUDE_DIR=', pbase + r'/Include') } - - metadata['cmake_args'].extend([ - '-GNMake Makefiles']) + + metadata['cmake_args'].extend(['-GNMake Makefiles']) for k, v in env2cmakearg.items(): print(k, v, os.environ.get(k, '')) @@ -262,16 +266,15 @@ def setup_package(): # default metadata['cmake_args'].append(v[0] + v[1]) - metadata['cmake_args'].extend([ + metadata['cmake_args'].extend([ '-DCMAKE_Fortran_SIMULATE_VERSION=5.0.0', - '-DCMAKE_Fortran_COMPILER_ID=Flang', - '-DCMAKE_VERBOSE_MAKEFILE:BOOL=ON' ]) + '-DCMAKE_Fortran_COMPILER_ID=Flang', + '-DCMAKE_VERBOSE_MAKEFILE:BOOL=ON']) print(metadata['cmake_args']) try: setup(**metadata) finally: del sys.path[0] - #os.chdir(old_path) return From 3bccc5d3bb75ed9ac984455ffb44a2bdc4917f5d Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 4 May 2019 15:14:20 +0200 Subject: [PATCH 058/405] Remove support for Python versions 2.6, 3.2, 3.3, and 3.4. --- setup.py | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/setup.py b/setup.py index e290a14e..a4a259a2 100644 --- a/setup.py +++ b/setup.py @@ -24,12 +24,8 @@ from skbuild import setup from skbuild.command.sdist import sdist -# Fix a bug in python v3.4 installation -if (sys.version_info[0:2] == (3, 4)): - import importlib.machinery - -if sys.version_info[:2] < (2, 6) or (3, 0) <= sys.version_info[0:2] < (3, 2): - raise RuntimeError("Python version 2.6, 2.7 or >= 3.2 required.") +if sys.version_info[:2] < (2, 7) or (3, 0) <= sys.version_info[0:2] < (3, 5): + raise RuntimeError("Python version 2.7 or >= 3.5 required.") DOCLINES = __doc__.split("\n") From 1cc767858783a0a026e657a90744aef70229bdbc Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 4 May 2019 16:19:17 +0200 Subject: [PATCH 059/405] Note supported Python versions in README.rst [skip ci] --- README.rst | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.rst b/README.rst index 8aa7658f..afb61157 100644 --- a/README.rst +++ b/README.rst @@ -20,6 +20,8 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ +Supported Python versions are 2.7, and 3.5 and later. + Slycot depends on Numpy and, if you are installing a binary distribution, Numpy should be the only prerequisite (though you may need LAPACK libraries as well, depending on your particular system configuration). From 272aaf728db12e282d418b65cb48748ea881750e Mon Sep 17 00:00:00 2001 From: Joris Geysens Date: Mon, 13 May 2019 13:51:34 +0200 Subject: [PATCH 060/405] Fix Python 2.7 install --- setup.py | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/setup.py b/setup.py index a4a259a2..de222e11 100644 --- a/setup.py +++ b/setup.py @@ -150,10 +150,19 @@ def get_version_info(srcdir=None): (ISRELEASED and 'yes') or 'no') elif os.path.exists('setup.cfg'): # valid distribution - setupcfg = configparser.ConfigParser() + setupcfg = configparser.ConfigParser(allow_no_value=True) setupcfg.read('setup.cfg') - FULLVERSION = setupcfg['metadata'].get('version', 'Unknown') - GIT_REVISION = setupcfg['metadata'].get('gitrevision', '') + + FULLVERSION = setupcfg.get(section='metadata', option='version') + + if FULLVERSION is None: + FULLVERSION = "Unknown" + + GIT_REVISION = setupcfg.get(section='metadata', option='gitrevision') + + if GIT_REVISION is None: + GIT_REVISION = "" + return FULLVERSION, GIT_REVISION else: From ec3aed1983361cdb0d9ab3932ceb8362b95d67c8 Mon Sep 17 00:00:00 2001 From: Joris Geysens Date: Mon, 13 May 2019 16:42:21 +0200 Subject: [PATCH 061/405] Fix travis config file (python 3.5 and 3.6 environments configured as python 3.7) --- .travis.yml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index 45a0506e..55275922 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,22 +3,22 @@ matrix: include: - name: "Python 2.7, TEST_CONDA=0" env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=0 - - name: "Python 2.7, TEST_CONDA=1" + - name: "Python 2.7, TEST_CONDA=1" env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 - name: "Python 3.5, TEST_CONDA=0" - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 - - name: "Python 3.5, TEST_CONDA=1" - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 + env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=0 + - name: "Python 3.5, TEST_CONDA=1" + env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 - name: "Python 3.6, TEST_CONDA=0" - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 - - name: "Python 3.6, TEST_CONDA=1" - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 + env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=0 + - name: "Python 3.6, TEST_CONDA=1" + env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 - name: "Python 3.7, TEST_CONDA=0" env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 - - name: "Python 3.7, TEST_CONDA=1" + - name: "Python 3.7, TEST_CONDA=1" env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 before_install: @@ -54,7 +54,7 @@ install: # Set up a test environment for testing everything out - conda create -q -n test-environment python="$SLYCOT_PYTHON_VERSION" pip coverage nose numpy openblas - source activate test-environment - + # # Make sure that fortran compiler can find conda libraries # @@ -66,8 +66,8 @@ install: conda install -c conda-forge scikit-build >=0.8.0 ; fi # - # Install the slycot package (two ways, to improve robustness). For the - # conda version, need to install lapack from conda-forge (no way to specify + # Install the slycot package (two ways, to improve robustness). For the + # conda version, need to install lapack from conda-forge (no way to specify # this in the recipe). # add the conda-forge channel to the config, otherwise openblas or # lapack cannot be found in the check From e036f2a6143ff770d6ba14054f6ff1256f196c2c Mon Sep 17 00:00:00 2001 From: "Jason K. Moore" Date: Thu, 23 May 2019 07:48:32 -0700 Subject: [PATCH 062/405] Better handling of missing dependencies on install. - Raise an ImportError with informative message if scikit-build is not installed prior to executing setup.py. - Include numpy in the install_requires of the setup function so that it will be installed if not present. --- setup.py | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/setup.py b/setup.py index de222e11..cdbbc18c 100644 --- a/setup.py +++ b/setup.py @@ -21,8 +21,11 @@ else: import __builtin__ as builtins -from skbuild import setup -from skbuild.command.sdist import sdist +try: + from skbuild import setup + from skbuild.command.sdist import sdist +except ImportError: + raise ImportError('sckit-build must be installed before running setup.py') if sys.version_info[:2] < (2, 7) or (3, 0) <= sys.version_info[0:2] < (3, 5): raise RuntimeError("Python version 2.7 or >= 3.5 required.") @@ -240,6 +243,7 @@ def setup_package(): '-DISRELEASE:STRING=' + str(ISRELEASED), '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7]], zip_safe=False, + install_requires=['numpy'], ) # Windows builds use Flang. From 4c8961110223f0ccbda103b058d2ab8f94512088 Mon Sep 17 00:00:00 2001 From: "Jason K. Moore" Date: Thu, 23 May 2019 07:52:44 -0700 Subject: [PATCH 063/405] Updated trove classifiers. --- setup.py | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/setup.py b/setup.py index cdbbc18c..19ee1555 100644 --- a/setup.py +++ b/setup.py @@ -33,12 +33,15 @@ DOCLINES = __doc__.split("\n") CLASSIFIERS = """\ -Development Status :: 3 - Alpha +Development Status :: 4 - Beta Intended Audience :: Science/Research Intended Audience :: Developers License :: OSI Approved +License :: OSI Approved :: GNU General Public License v2 (GPLv2) Programming Language :: C +Programming Language :: Fortran Programming Language :: Python +Programming Language :: Python :: 2 Programming Language :: Python :: 3 Topic :: Software Development Topic :: Scientific/Engineering From 3a40b21697d1547345be166cb5988373605205a6 Mon Sep 17 00:00:00 2001 From: "Jason K. Moore" Date: Thu, 23 May 2019 07:54:49 -0700 Subject: [PATCH 064/405] README whitespace cleanup. --- README.rst | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/README.rst b/README.rst index afb61157..7dfa978d 100644 --- a/README.rst +++ b/README.rst @@ -16,7 +16,6 @@ Slycot Python wrapper for selected SLICOT routines, notably including solvers for Riccati, Lyapunov, and Sylvester equations. - Dependencies ------------ @@ -36,20 +35,19 @@ On Debian derivatives you should be able to install OpenBLAS using:: sudo apt-get install libopenblas-dev Additionally install cmake and install scikit-build with pip or conda. - + On Mac, you will first need to install the `developer tools `_. You can then install gfortran using `homebrew `_ with:: brew install gcc -On Windows, the BLAS and LAPACK libraries can be obtained from: +On Windows, the BLAS and LAPACK libraries can be obtained from: http://icl.cs.utk.edu/lapack-for-windows/libraries/VisualStudio/3.4.1/Dynamic-MINGW/Win32/ Alternatively, use conda to install BLAS and LAPACK or OpenBLAS - Installing ----------- @@ -88,7 +86,7 @@ e.g. ``/path/to/slycot_src/``, and execute:: cd /path/to/slycot_src/ python setup.py install -Where # is for commands that needs to be executed as root/administrator. +Where # is for commands that needs to be executed as root/administrator. If you need to specify a specific compiler, set the environment variable FC before running the install:: @@ -120,7 +118,7 @@ incompatible with Python 2.7. If you are using conda, you can also get working (binary) copies of LAPACK from conda-forge using the command:: - conda install -c conda-forge lapack + conda install -c conda-forge lapack Slycot will also work with the OpenBLAS libraries. From 352270b512608ea1857a48122a4d77d340197487 Mon Sep 17 00:00:00 2001 From: "Jason K. Moore" Date: Thu, 23 May 2019 08:23:32 -0700 Subject: [PATCH 065/405] Simplified and added clarity to the README. --- README.rst | 114 +++++++++++++++++++++++++---------------------------- 1 file changed, 54 insertions(+), 60 deletions(-) diff --git a/README.rst b/README.rst index 7dfa978d..fdd64cf2 100644 --- a/README.rst +++ b/README.rst @@ -19,77 +19,67 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ -Supported Python versions are 2.7, and 3.5 and later. +Slycot supports Python versions 2.7 and >=3.5. -Slycot depends on Numpy and, if you are installing a binary distribution, -Numpy should be the only prerequisite (though you may need LAPACK -libraries as well, depending on your particular system configuration). +To run the compiled Slycot package, the following must be installed as +dependencies: -If you are installing Slycot from source, you will need a FORTRAN -compiler, such as gfortran, and BLAS/LAPACK libraries. Openblas is -also supported. The build system uses skbuild (scikit-buildsystem >= -0.8.1) and cmake. +- Python 2.7, 3.5+ +- NumPy -On Debian derivatives you should be able to install OpenBLAS using:: +If you are compiling and installing Slycot from source, you will need the +following dependencies: - sudo apt-get install libopenblas-dev +- Python 2.7, 3.5+ +- NumPy +- scikit-build >=0.8.1 +- cmake +- C compiler (e.g. gcc, MS Visual C++) +- FORTRAN compiler (e.g. gfortran, ifort, flang) +- BLAS/LAPACK (e.g. OpenBLAS, ATLAS, MKL) -Additionally install cmake and install scikit-build with pip or conda. +There are a variety of ways to install these dependencies on different +operating systems. See the individual packages' documentation for options. -On Mac, you will first need to install the `developer tools -`_. You can then install gfortran using -`homebrew `_ with:: - - brew install gcc +Installing +----------- -On Windows, the BLAS and LAPACK libraries can be obtained from: +In general Slycot requires non-trivial compilation to install on a given +system. The easiest way to get started using Slycot is by installing +pre-compiled binaries. The Slycot team provides pre-compiled binaries via the +conda package manager and conda forge package hosting channel for Linux, OSX, +and Windows. -http://icl.cs.utk.edu/lapack-for-windows/libraries/VisualStudio/3.4.1/Dynamic-MINGW/Win32/ +Using conda +~~~~~~~~~~~ -Alternatively, use conda to install BLAS and LAPACK or OpenBLAS +Install Miniconda or Anaconda and then Slycot can be installed via the conda +package manager from the conda-forge channel with the following command:: -Installing ------------ + conda install -c conda-forge slycot Using pip ~~~~~~~~~ -Slycot supports the pip packaging system. You must first have pip installed. - -On Debian Linux based systems you can install pip with the command:: - - sudo apt-get install pip +Slycot can also be installed via the pip package manager. Install pip as per +recommendations in pip's documentation. At a minimum, Python and pip must be +installed. If a pre-complied binary (i.e. "wheel") is available it will be +installed with no need for compilation. If not, pip will attempt to compile the +package from source and thus the compilation dependencies will be required +(scikit-build, gfortran, BLAS, etc.). Pip can then be used to install Slycot with the command:: pip install slycot -Note that installing with pip may or may not require having the build -dependencies installed. There are some binary "wheels" available on PyPI, -so if those versions match with your system, you may be able to avoid -installing from source. - -Using conda -~~~~~~~~~~~ - -Slycot can be installed via the conda package manager from the conda-forge -channel with the following command:: - - conda install -c conda-forge slycot - From source ~~~~~~~~~~~ Unpack the course code to a directory of your choice, -e.g. ``/path/to/slycot_src/``, and execute:: - - cd /path/to/slycot_src/ - python setup.py install - -Where # is for commands that needs to be executed as root/administrator. +e.g. ``/path/to/slycot_src/`` -If you need to specify a specific compiler, set the environment -variable FC before running the install:: +If you need to specify a specific compiler, set the environment variable FC +before running the install:: # Linux/OSX: export FC=/path/to/my/fortran @@ -97,7 +87,12 @@ variable FC before running the install:: # Windows: set FC=D:\path\to\my\fortran.exe -You can also use conda to build and install slycot from source:: +To build and install execute:: + + cd /path/to/slycot_src/ + python setup.py install + +You can also use conda to build and install Slycot from source:: conda build conda-recipe conda install --use-local slycot @@ -105,23 +100,22 @@ You can also use conda to build and install slycot from source:: If you prefer to use the OpenBLAS library, a conda recipe is available in ``conda-recipe-openblas``. -Additional tips for how to install slycot from source can be found in the -.travis.yml (commands used for Travis CI) and conda-recipe/ (conda -pre-requisities). +Additional tips for how to install Slycot from source can be found in the +``.travis.yml`` (commands used for Travis CI) and conda-recipe/ (conda +pre-requisites) both which are included in the source code repository. -The hardest part about installing from source is getting -a working version of FORTRAN and LAPACK installed on your system and working -properly with Python. On Windows, the build system currently uses -flang, which can be installed from conda-forge. Note that flang is -incompatible with Python 2.7. +The hardest part about installing from source is getting a working version of +FORTRAN and LAPACK installed on your system and working properly with Python. +On Windows, the build system currently uses flang, which can be installed from +conda-forge. Note that flang is incompatible with Python 2.7. -If you are using conda, you can also get working -(binary) copies of LAPACK from conda-forge using the command:: +If you are using conda, you can also get working (binary) copies of LAPACK from +conda-forge using the command:: conda install -c conda-forge lapack Slycot will also work with the OpenBLAS libraries. -Note that in some cases you may need to set the LIBRARY_PATH environment -variable to pick up dependencies such as -lpythonN.m (where N.m is the +Note that in some cases you may need to set the ``LIBRARY_PATH`` environment +variable to pick up dependencies such as ``-lpythonN.m`` (where N.m is the version of python you are using). From 2e41c2fe9e54a7063afe40ea13121dcb42dc45f2 Mon Sep 17 00:00:00 2001 From: Jake Vanderplas Date: Tue, 18 Jun 2019 09:11:35 -0700 Subject: [PATCH 066/405] Add packages entry to setup.py metadata Without this entry, pip install fails to add the package to the Python path. --- setup.py | 1 + 1 file changed, 1 insertion(+) diff --git a/setup.py b/setup.py index 19ee1555..2289989e 100644 --- a/setup.py +++ b/setup.py @@ -229,6 +229,7 @@ def setup_package(): metadata = dict( name='slycot', + packages=['slycot', 'slycot.tests'], cmake_languages=('C', 'Fortran'), version=VERSION, maintainer="Slycot developers", From 64c6df3c9b13ece24b5b3ee2eb92d8f20b993037 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Tue, 18 Jun 2019 19:12:21 +0200 Subject: [PATCH 067/405] Modify Travis CI config to get python-control tests to pass --- .travis.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 55275922..be1c4dd2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,9 @@ # Travis configuration file for slycot +dist: xenial + +services: + - xvfb + matrix: include: - name: "Python 2.7, TEST_CONDA=0" @@ -95,9 +100,6 @@ script: # # Additional packages required for python-control - conda install scipy matplotlib - # Install display manager to allow testing of plotting functions - - export DISPLAY=:99.0 - - sh -e /etc/init.d/xvfb start # Get python-control from source and install - git clone https://github.com/python-control/python-control.git control - cd control; python setup.py test From 11061c1a4d348a1473327538bc3cd57b7db93f4e Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Tue, 18 Jun 2019 21:18:58 +0200 Subject: [PATCH 068/405] Build fixes: query numpy path directly; setup pyproject.toml for pip --- CMakeLists.txt | 2 +- MANIFEST.in | 1 + pyproject.toml | 2 ++ 3 files changed, 4 insertions(+), 1 deletion(-) create mode 100644 pyproject.toml diff --git a/CMakeLists.txt b/CMakeLists.txt index 63b32e03..6667eaeb 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -39,7 +39,7 @@ endif() # base site dir, use python installation for location specific includes execute_process( COMMAND "${PYTHON_EXECUTABLE}" -c - "from distutils.sysconfig import get_python_lib as pl; print(pl())" + "import os,numpy; print(os.path.dirname(numpy.__path__[0]))" OUTPUT_VARIABLE PYTHON_SITE OUTPUT_STRIP_TRAILING_WHITESPACE) if(WIN32) diff --git a/MANIFEST.in b/MANIFEST.in index 631e5327..c48269b2 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -6,6 +6,7 @@ include README.rst include MANIFEST.in include setup.cfg.in include CMakeLists.txt +include pyproject.toml include slycot/CMakeLists.txt include slycot/tests/CMakeLists.txt include slycot/*.py diff --git a/pyproject.toml b/pyproject.toml new file mode 100644 index 00000000..3df57213 --- /dev/null +++ b/pyproject.toml @@ -0,0 +1,2 @@ +[build-system] +requires = ["setuptools", "wheel", "scikit-build", "cmake", "numpy"] From 96e18768e8a27186131ed9de22813ff089cdff42 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Wed, 19 Jun 2019 20:32:01 +0200 Subject: [PATCH 069/405] src_path is path to directory containing setup.py --- setup.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/setup.py b/setup.py index 2289989e..db53bfd5 100644 --- a/setup.py +++ b/setup.py @@ -221,7 +221,7 @@ def run(self): def setup_package(): - src_path = os.path.dirname(os.path.abspath(sys.argv[0])) + src_path = os.path.dirname(os.path.abspath(__file__)) sys.path.insert(0, src_path) # Rewrite the version file everytime From ff7c808f8ac0b8e4950b5d8d3f1ea22cbccc21e5 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Fri, 21 Jun 2019 21:02:56 +0200 Subject: [PATCH 070/405] Build fix: Add runtests.py to MANIFEST.in Allows "python setup.py test" to run from sdist, and so from PyPI. Fixes #68. --- MANIFEST.in | 1 + 1 file changed, 1 insertion(+) diff --git a/MANIFEST.in b/MANIFEST.in index c48269b2..fa02bd06 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -13,3 +13,4 @@ include slycot/*.py include slycot/version.py.in include slycot/src/*.f include slycot/tests/*.py +include runtests.py From f5c35e3435fbc16d466e0f1ffcb671da8171950e Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Fri, 21 Jun 2019 21:03:45 +0200 Subject: [PATCH 071/405] Ignore build artefacts _skbuild and setup.cfg --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 036c0bc2..080718f9 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ build.log *.egg-info/ .coverage *~ +setup.cfg +_skbuild From 2894c98160d2ad06781fde4dcfcfbe31d86a7954 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 22 Jun 2019 09:40:12 +0200 Subject: [PATCH 072/405] Use `pip install` in conda-build recipes This is recommended by conda-forge; see [1]. It also tests "pip installability". [1] http://conda-forge.org/docs/maintainer/adding_pkgs.html#use-pip --- conda-recipe-openblas/bld.bat | 2 +- conda-recipe-openblas/build.sh | 3 ++- conda-recipe-openblas/meta.yaml | 2 ++ conda-recipe/bld.bat | 2 +- conda-recipe/build.sh | 2 +- conda-recipe/meta.yaml | 2 ++ 6 files changed, 9 insertions(+), 4 deletions(-) diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat index dfccb158..cc819308 100644 --- a/conda-recipe-openblas/bld.bat +++ b/conda-recipe-openblas/bld.bat @@ -16,7 +16,7 @@ if EXIST "%PREFIX%\Scripts\f2py.exe" ( set F2PY=%PREFIX%\Scripts\f2py.bat ) -"%PYTHON%" setup.py install +"%PYTHON%" -m pip install . --no-deps --ignore-installed -vv if errorlevel 1 exit 1 diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index fad66798..a124b743 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -11,4 +11,5 @@ export LAPACK_ROOT=${PREFIX} rm -rf _skbuild # do the build -$PYTHON setup.py install +$PYTHON -m pip install . --no-deps --ignore-installed -vv + diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 8dcc1056..0ea376ce 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -10,6 +10,7 @@ build: string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_obl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: + # TODO: pip possibly required in only *one* of build and host, but which? build: - python {{ PY_VER }} - numpy @@ -21,6 +22,7 @@ requirements: host: - python {{ PY_VER }} + - pip - flang # [win] - numpy - openblas >=0.3.0 diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 23e8a339..be6bdd74 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -16,7 +16,7 @@ if EXIST "%PREFIX%\Scripts\f2py.exe" ( set F2PY=%PREFIX%\Scripts\f2py.bat ) -"%PYTHON%" setup.py install +"%PYTHON%" -m pip install . --no-deps --ignore-installed -vv if errorlevel 1 exit 1 diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index fd92a091..670972f0 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -12,4 +12,4 @@ rm -rf _skbuild env # do the build -$PYTHON setup.py install +$PYTHON -m pip install . --no-deps --ignore-installed -vv diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 45605775..2e7646f5 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -14,6 +14,7 @@ requirements: # conda-supplied clang and library linking see e.g. # https://github.com/conda-forge/mpi-feedstock issue #4 # conda-forge might have the configuration in place for clang build and link? + # TODO: pip possibly required in only *one* of build and host, but which? build: - python {{PY_VER}} - numpy @@ -24,6 +25,7 @@ requirements: host: - python {{ PY_VER }} + - pip - flang # [win] - numpy - mkl From 4db6255ae78154da1ab9b3c0bfa2c1cb98680e78 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 22 Jun 2019 12:00:50 +0200 Subject: [PATCH 073/405] Added OSX to Travis build matrix Only "conda build" is tested in OSX. OSX Python 2.7 is allowed to fail; it currently fails due to what looks like an error in Conda dependencies. Linux-specific settings (dist, services) have been moved into build matrix settings. Other minor changes: - always download Miniconda3; use SLYCOT_PYTHON_VERSION to build and test Python 2.7 - install conda-verify - only clone python-control to depth 1 --- .travis.yml | 104 ++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 81 insertions(+), 23 deletions(-) diff --git a/.travis.yml b/.travis.yml index be1c4dd2..e976b7c6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,59 +1,114 @@ -# Travis configuration file for slycot -dist: xenial +# The test matrix includes OSX and Linux -services: - - xvfb +# Don't know how to do non-Conda builds on OSX + +# Linux builds needs extra settings (see "dist" and "services" below) matrix: + allow_failures: + - name: "OSX, Python 2.7, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 + include: - - name: "Python 2.7, TEST_CONDA=0" + - name: "OSX, Python 2.7, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 + + - name: "OSX, Python 3.5, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 + + - name: "OSX, Python 3.6, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 + + - name: "OSX, Python 3.7, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 + + - name: "Ubuntu 16.04, Python 2.7, TEST_CONDA=0" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=0 - - name: "Python 2.7, TEST_CONDA=1" + + - name: "Ubuntu 16.04, Python 2.7, TEST_CONDA=1" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 - - name: "Python 3.5, TEST_CONDA=0" + - name: "Ubuntu 16.04, Python 3.5, TEST_CONDA=0" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=0 - - name: "Python 3.5, TEST_CONDA=1" + + - name: "Ubuntu 16.04, Python 3.5, TEST_CONDA=1" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 - - name: "Python 3.6, TEST_CONDA=0" + - name: "Ubuntu 16.04, Python 3.6, TEST_CONDA=0" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=0 - - name: "Python 3.6, TEST_CONDA=1" + + - name: "Ubuntu 16.04, Python 3.6, TEST_CONDA=1" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 - - name: "Python 3.7, TEST_CONDA=0" + - name: "Ubuntu 16.04, Python 3.7, TEST_CONDA=0" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 - - name: "Python 3.7, TEST_CONDA=1" + + - name: "Ubuntu 16.04, Python 3.7, TEST_CONDA=1" + os: linux + dist: xenial + services: xvfb env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 + before_install: - # - # Install fortran compiler, if not using Conda's - # If not using conda, then install liblapack here (conda version - # will handle this through the build recipe) - # + - if [[ $TEST_CONDA == 0 && $TRAVIS_OS_NAME != linux ]]; then + echo "Only Linux supported for non-Conda builds"; + exit 1; + fi + # from here on assume $TEST_CONDA == 0 implies $TRAVIS_OS_NAME == linux + - if [[ $TEST_CONDA == 0 ]]; then sudo apt-get install liblapack-dev libblas-dev; sudo apt-get install gfortran; sudo apt-get install cmake; fi + install: # # Install miniconda to allow quicker installation of dependencies # See https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html # - - if [[ "$SLYCOT_PYTHON_VERSION" == "2.7" ]]; then - wget http://repo.continuum.io/miniconda/Miniconda2-latest-Linux-x86_64.sh -O miniconda.sh; - else + - if [[ $TRAVIS_OS_NAME == linux ]]; then wget http://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh; + else + wget https://repo.anaconda.com/miniconda/Miniconda3-latest-MacOSX-x86_64.sh -O miniconda.sh; fi - bash miniconda.sh -b -p $HOME/miniconda - export PATH="$HOME/miniconda/bin:$PATH" - hash -r - conda config --set always_yes yes --set changeps1 no - conda update -q --all - - if [[ $TEST_CONDA == 1 ]]; then conda install conda-build; fi + - if [[ $TEST_CONDA == 1 ]]; then + conda install conda-build; + conda install conda-verify; + fi - conda info -a # # Set up a test environment for testing everything out @@ -90,6 +145,7 @@ install: # coveralls not in conda repos :-( - pip install coveralls + script: # Local unit tests # TODO: replace with nose? @@ -101,8 +157,10 @@ script: # Additional packages required for python-control - conda install scipy matplotlib # Get python-control from source and install - - git clone https://github.com/python-control/python-control.git control - - cd control; python setup.py test + - git clone --depth 1 https://github.com/python-control/python-control.git control + - cd control + - python setup.py test + after_success: - coveralls From 429e1d6229bf8d8c0b9e7faf5d485f9828a040d8 Mon Sep 17 00:00:00 2001 From: arnold Date: Sat, 27 Jul 2019 12:05:32 -0600 Subject: [PATCH 074/405] Make the .pyf signature files a dependency of the wrapper generation. The goal is to allow faster re-compilation after editing one of the pyf signature files. --- slycot/CMakeLists.txt | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 3207d92c..2046c4a2 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -103,6 +103,9 @@ set(FSOURCES src/NF01BV.f src/SB10JD.f src/UE01MD.f) set(F2PYSOURCE src/_wrapper.pyf) +set(F2PYSOURCE_DEPS + src/analysis.pyf src/math.pyf src/mathematical.pyf + src/transform.pyf src/synthesis.pyf) configure_file(version.py.in version.py @ONLY) @@ -123,7 +126,8 @@ add_custom_command( OUTPUT SLYCOTmodule.c _wrappermodule.c _wrapper-f2pywrappers.f COMMAND ${F2PY_EXECUTABLE} -m SLYCOT ${CMAKE_CURRENT_SOURCE_DIR}/${F2PYSOURCE} - ) + DEPENDS ${F2PYSOURCE_DEPS} ${F2PYSOURCE} +) add_library( ${SLYCOT_MODULE} SHARED From 3b9ebd0ccfdfb0cb34f66b460e87dbcee3ddc6ca Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 10 Aug 2019 10:31:48 +0200 Subject: [PATCH 075/405] CI: put all OSX builds in allow_failure category The OSX builds are all failing due to environment or build setup, not Slycot-specific code. Allow them to fail until we can find a fix. --- .travis.yml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/.travis.yml b/.travis.yml index e976b7c6..bf781ccf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,6 +10,18 @@ matrix: os: osx env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 + - name: "OSX, Python 3.5, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 + + - name: "OSX, Python 3.6, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 + + - name: "OSX, Python 3.7, TEST_CONDA=1" + os: osx + env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 + include: - name: "OSX, Python 2.7, TEST_CONDA=1" os: osx From f9f4a951476feead8cb88000a436fb9ab5a4fef0 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 12:52:26 +0200 Subject: [PATCH 076/405] remove shebang in source files without main execution path --- slycot/analysis.py | 1 - slycot/examples.py | 1 - slycot/math.py | 1 - slycot/synthesis.py | 1 - slycot/transform.py | 1 - 5 files changed, 5 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index eb18f35e..1b496d69 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # analysis.py # diff --git a/slycot/examples.py b/slycot/examples.py index 90ee67e9..0207fb39 100644 --- a/slycot/examples.py +++ b/slycot/examples.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # examples.py # diff --git a/slycot/math.py b/slycot/math.py index b0825e7d..7044e2bb 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # math.py # diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 2c0e442f..b197c3b7 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # synthesis.py # diff --git a/slycot/transform.py b/slycot/transform.py index 80a1d79d..77b31715 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # transform.py # From 5896144d75c33c4cef9f55f3703d88f518008fd5 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 13:42:04 +0200 Subject: [PATCH 077/405] fix invalid variable usages from wrapper outputs --- slycot/math.py | 9 ++++++--- slycot/synthesis.py | 8 ++++---- slycot/transform.py | 4 ++-- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index b0825e7d..956a741b 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -19,6 +19,7 @@ # MA 02110-1301, USA. from . import _wrapper +import warnings def mc01td(dico,dp,p): """ dp,stable,nz = mc01td(dico,dp,p) @@ -62,11 +63,11 @@ def mc01td(dico,dp,p): e.info = out[-1] raise e if out[-1] == 1: - warings.warn('entry P(x) is the zero polynomial.') + warnings.warn('entry P(x) is the zero polynomial.') if out[-1] == 2: - warings.warn('P(x) may have zeros very close to stability boundary.') + warnings.warn('P(x) may have zeros very close to stability boundary.') if out[-2] > 0: - warnings.warn('The degree of P(x) has been reduced to %i' %(dp-k)) + warnings.warn('The degree of P(x) has been reduced to %i' %(dp-out[-2])) return out[:-2] @@ -138,6 +139,7 @@ def mb05md(a, delta, balanc='N'): 'y','ldy'+hidden,'valr','vali', 'iwork'+hidden,'dwork'+hidden,'ldwork'+hidden,'info'+hidden] out = _wrapper.mb05md(balanc=balanc,n=min(a.shape),delta=delta,a=a) + n = out[-4] if out[-1] == 0: return out[:-1] elif out[-1] < 0: @@ -187,6 +189,7 @@ def mb05nd(a, delta, tol=1e-7): 'exint', 'ldexin'+hidden, 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork'+hidden] out = _wrapper.mb05nd(n=min(a.shape), delta=delta, a=a, tol=tol) + n = out[-4] if out[-1] == 0: return out[:-1] elif out[-1] < 0: diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 2c0e442f..cfc89519 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -690,20 +690,20 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw out = _wrapper.sb02od_n(dico,n,m,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) if fact == 'C': if p is None: - p = shape(Q)[0] + p = _np.shape(Q)[0] out = _wrapper.sb02od_c(dico,n,m,p,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) if fact == 'D': if p is None: - p = shape(R)[0] + p = _np.shape(R)[0] out = _wrapper.sb02od_d(dico,n,m,p,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) if fact == 'B': if p is None: - p = shape(Q)[0] + p = _np.shape(Q)[0] out = _wrapper.sb02od_b(dico,n,m,p,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) if out[-1] < 0: error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] e = ValueError(error_text) - e.info = info + e.info = out[-1] raise e if out[-1] == 1: e = ValueError('the computed extended matrix pencil is singular, possibly due to rounding errors') diff --git a/slycot/transform.py b/slycot/transform.py index 80a1d79d..f615f89b 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -650,7 +650,7 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): kdcoef = max(index)+1 if rowcol == 'R': - porm = p + # porm = p if ucoeff.ndim != 3: e = ValueError("The numerator is not a 3D array!") e.info = -7 @@ -665,7 +665,7 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): raise e out = _wrapper.td04ad_r(m,p,index,dcoeff,ucoeff,n,tol,ldwork) elif rowcol == 'C': - porm = m + # porm = m if ucoeff.ndim != 3: e = ValueError("The numerator is not a 3D array!") e.info = -7 From 594b3db64a50d39fc39c7dde6366e29de1340592 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 14:26:39 +0200 Subject: [PATCH 078/405] delete unused mathematical.pyf --- slycot/src/mathematical.pyf | 23 ----------------------- 1 file changed, 23 deletions(-) delete mode 100644 slycot/src/mathematical.pyf diff --git a/slycot/src/mathematical.pyf b/slycot/src/mathematical.pyf deleted file mode 100644 index ab318846..00000000 --- a/slycot/src/mathematical.pyf +++ /dev/null @@ -1,23 +0,0 @@ -! -*- f90 -*- -! Note: the context of this file is case sensitive. - -subroutine mb05md(balanc,n,delta,a,lda,v,ldv,y,ldy,valr,vali,iwork,dwork,ldwork,info) ! in MB05MD.f - character check(balanc=='N' || balanc=='S'):: balanc - integer check(n>=0) :: n - double precision check(delta>=0.0):: delta - double precision intent(in,out,copy),dimension(lda,*) :: a - integer, intent(hide),depend(a) :: lda=shape(a,0) - double precision intent(out,copy),dimension(ldv,*) :: v - integer, intent(hide),check(ldv),depend(v) :: ldv=shape(v,0) - double precision dimension(ldy,*) :: y - integer, optional,check(shape(y,0)==ldy),depend(y) :: ldy=shape(y,0) - double precision dimension(*) :: valr - double precision dimension(*) :: vali - integer dimension(*) :: iwork - double precision dimension(*) :: dwork - integer :: ldwork - integer :: info -end subroutine mb05md - -! This file was auto-generated with f2py (version:2). -! See http://cens.ioc.ee/projects/f2py2e/ From abb9f79acced2e2353c9fdd36f1de5871e793d21 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 14:27:42 +0200 Subject: [PATCH 079/405] fix math --- slycot/math.py | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 956a741b..5a7c4e5c 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -128,7 +128,7 @@ def mb05md(a, delta, balanc='N'): the (right) eigenvector matrix of A, where Lambda is the diagonal matrix of eigenvalues. - VALr : output rank-1 array('c') with bounds (n) + VAL : output rank-1 array('c') with bounds (n) Contains the eigenvalues of the matrix A. The eigenvalues are unordered except that complex conjugate pairs of values appear consecutively with the eigenvalue having positive @@ -138,20 +138,21 @@ def mb05md(a, delta, balanc='N'): arg_list = [ 'balanc', 'n', 'delta', 'a', 'lda'+hidden, 'v', 'ldv'+hidden, 'y','ldy'+hidden,'valr','vali', 'iwork'+hidden,'dwork'+hidden,'ldwork'+hidden,'info'+hidden] - out = _wrapper.mb05md(balanc=balanc,n=min(a.shape),delta=delta,a=a) - n = out[-4] - if out[-1] == 0: - return out[:-1] - elif out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - elif out[-1] > 0 and out[-1] <= n: - error_text = "Incomplete eigenvalue calculation, missing %i eigenvalues" % out[-1] - elif out[-1] == n+1: + n=min(a.shape) + (Ar,Vr,Yr,VALr,VALi,INFO) = _wrapper.mb05md(balanc=balanc,n=n,delta=delta,a=a) + if INFO == 0: + VAL=VALr+1J*VALi + return (Ar,Vr,Yr,VAL) + elif INFO < 0: + error_text = "The following argument had an illegal value: "+arg_list[-INFO-1] + elif INFO > 0 and INFO <= n: + error_text = "Incomplete eigenvalue calculation, missing %i eigenvalues" % INFO + elif INFO == n+1: error_text = "Eigenvector matrix singular" - elif out[-1] == n+2: + elif INFO == n+2: error_text = "A matrix defective" e = ValueError(error_text) - e.info = out[-1] + e.info = INFO raise e """ From af8927f0b29ac5d30b4f69c86f1a93a0730b4cee Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 16:02:05 +0200 Subject: [PATCH 080/405] only return complex list when necessary, add unittest for mb05md --- slycot/math.py | 5 +++- slycot/tests/CMakeLists.txt | 19 +++++++++++-- slycot/tests/test_mb.py | 56 +++++++++++++++++++++++++++++++++++++ 3 files changed, 76 insertions(+), 4 deletions(-) create mode 100644 slycot/tests/test_mb.py diff --git a/slycot/math.py b/slycot/math.py index 5a7c4e5c..962344b6 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -141,7 +141,10 @@ def mb05md(a, delta, balanc='N'): n=min(a.shape) (Ar,Vr,Yr,VALr,VALi,INFO) = _wrapper.mb05md(balanc=balanc,n=n,delta=delta,a=a) if INFO == 0: - VAL=VALr+1J*VALi + if not all(VALi==0): + VAL=VALr+1J*VALi + else: + VAL=VALr return (Ar,Vr,Yr,VAL) elif INFO < 0: error_text = "The following argument had an illegal value: "+arg_list[-INFO-1] diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index c97cb500..25abbf90 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -1,6 +1,19 @@ set(PYSOURCE - __init__.py test.py test_sg02ad.py test_sg03ad.py test_tb05ad.py - test_td04ad.py) + __init__.py + test.py + test_ag08bd.py + test_mb.py + test_sb10jd.py + test_sg02ad.py + test_sg03ad.py + test_tb05ad.py + test_td04ad.py + test_tg01ad.py + test_tg01fd.py) -install(FILES ${PYSOURCE} DESTINATION slycot/tests) +install(FILES ${PYSOURCE} + PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE + GROUP_READ GROUP_EXECUTE + OTHER_READ OTHER_EXECUTE + DESTINATION slycot/tests) diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py new file mode 100644 index 00000000..c52f69aa --- /dev/null +++ b/slycot/tests/test_mb.py @@ -0,0 +1,56 @@ +#!/usr/bin/env python +# +# test_mb.py - test suite for linear algebra commands +# bnavigator , Aug 2019 + +import unittest +import numpy as np + +from slycot import mb05md + +from numpy.testing import assert_allclose + + +class test_mb(unittest.TestCase): + + def test_mb05md(self): + """ test_mb05md: verify Matrix exponential with slicot doc example + data from http://slicot.org/objects/software/shared/doc/MB05MD.html + """ + A = np.array([[ 0.5, 0., 2.3, -2.6], + [ 0., 0.5, -1.4, -0.7], + [ 2.3, -1.4, 0.5, 0.0], + [-2.6, -0.7, 0.0, 0.5]]) + delta = 1.0 + Ar_ref = np.array([[ 26.8551, -3.2824, 18.7409, -19.4430], + [ -3.2824, 4.3474, -5.1848, 0.2700], + [ 18.7409, -5.1848, 15.6012, -11.7228], + [ -19.4430, 0.2700, -11.7228, 15.6012]]) + Vr_ref = np.array([[-0.7, 0.7, 0.1, -0.1], + [ 0.1, -0.1, 0.7, -0.7], + [ 0.5, 0.5, 0.5, 0.5], + [-0.5, -0.5, 0.5, 0.5]]) + Yr_ref = np.array([[ -0.0349, 0.0050, 0.0249, -0.0249], + [ 38.2187, -5.4598, 27.2991, -27.2991], + [ 0.0368, 0.2575, 0.1839, 0.1839], + [ -0.7389, -5.1723, 3.6945, 3.6945]]) + VAL_ref = np.array([-3., 4., -1., 2.]) + (Ar, Vr, Yr, VAL) = mb05md(A, delta) + + assert_allclose(Ar, Ar_ref, atol=0.0001) + + # Order of eigenvalues is not guaranteed, so we check them one by one. + for i, e in enumerate(VAL): + erow = np.ones(VAL.shape)*e + i_ref = np.isclose(erow, VAL_ref) + self.assertTrue(any(i_ref), + msg="eigenvalue {} not expetced".format(e)) + # Eigenvectors can have different scaling. + vr_ref = Vr_ref[:, i_ref]*Vr[0, i]/Vr_ref[0, i_ref][0] + assert_allclose(Vr[:, (i,)], vr_ref, atol=0.0001) + + assert_allclose(np.dot(Vr, Yr), np.dot(Vr_ref, Yr_ref), atol=0.0001) + + +if __name__ == "__main__": + unittest.main() From 93c34db7e057362d833c6035d9435047ad190aa2 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 16:33:31 +0200 Subject: [PATCH 081/405] remove var porm --- slycot/transform.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/slycot/transform.py b/slycot/transform.py index f615f89b..2ac1aae0 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -650,7 +650,6 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): kdcoef = max(index)+1 if rowcol == 'R': - # porm = p if ucoeff.ndim != 3: e = ValueError("The numerator is not a 3D array!") e.info = -7 @@ -665,7 +664,6 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): raise e out = _wrapper.td04ad_r(m,p,index,dcoeff,ucoeff,n,tol,ldwork) elif rowcol == 'C': - # porm = m if ucoeff.ndim != 3: e = ValueError("The numerator is not a 3D array!") e.info = -7 From 961f172f977a82ef7f750c3fbcbac82f37806801 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 16:39:50 +0200 Subject: [PATCH 082/405] fix docstring of mb05md() --- slycot/math.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/math.py b/slycot/math.py index 962344b6..6a7165d6 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -72,7 +72,7 @@ def mc01td(dico,dp,p): def mb05md(a, delta, balanc='N'): - """Ar, Vr, Yr, VALRr, VALDr = mb05md(a, delta, balanc='N') + """Ar, Vr, Yr, VAL = mb05md(a, delta, balanc='N') Matrix exponential for a real non-defective matrix From 6572201b9de869c090acbad1d6685e9a1a7fbe9e Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 16:50:56 +0200 Subject: [PATCH 083/405] clean up pep8 issues in mb05md --- slycot/math.py | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 6a7165d6..8be35789 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -90,7 +90,7 @@ def mb05md(a, delta, balanc='N'): Square matrix delta : input 'd' The scalar value delta of the problem. - + Optional arguments: balanc : input char*1 Indicates how the input matrix should be diagonally scaled @@ -116,7 +116,7 @@ def mb05md(a, delta, balanc='N'): (k+1)-th columns of the eigenvector matrix, respectively, then the eigenvector corresponding to the complex eigenvalue with positive (negative) imaginary value is - given by + given by p + q*j (p - q*j), where j^2 = -1. Yr : output rank-2 array('d') with bounds (n,n) contains an intermediate result for computing the matrix @@ -135,17 +135,21 @@ def mb05md(a, delta, balanc='N'): imaginary part first. """ hidden = ' (hidden by the wrapper)' - arg_list = [ 'balanc', 'n', 'delta', 'a', 'lda'+hidden, 'v', 'ldv'+hidden, - 'y','ldy'+hidden,'valr','vali', - 'iwork'+hidden,'dwork'+hidden,'ldwork'+hidden,'info'+hidden] - n=min(a.shape) - (Ar,Vr,Yr,VALr,VALi,INFO) = _wrapper.mb05md(balanc=balanc,n=n,delta=delta,a=a) + arg_list = ['balanc', 'n', 'delta', 'a', 'lda'+hidden, 'v', 'ldv'+hidden, + 'y', 'ldy'+hidden, 'valr', 'vali', + 'iwork'+hidden, 'dwork'+hidden, 'ldwork'+hidden, + 'info'+hidden] + n = min(a.shape) + (Ar, Vr, Yr, VALr, VALi, INFO) = _wrapper.mb05md(balanc=balanc, + n=n, + delta=delta, + a=a) if INFO == 0: - if not all(VALi==0): - VAL=VALr+1J*VALi + if not all(VALi == 0): + VAL = VALr + 1J*VALi else: - VAL=VALr - return (Ar,Vr,Yr,VAL) + VAL = VALr + return (Ar, Vr, Yr, VAL) elif INFO < 0: error_text = "The following argument had an illegal value: "+arg_list[-INFO-1] elif INFO > 0 and INFO <= n: From ae14a6b28e5a9bab4505ed384716b2816dfafee7 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 17:13:23 +0200 Subject: [PATCH 084/405] clean more pep8 issues, fix mb05nd, add unittest for mb05nd --- slycot/math.py | 16 ++++++++-------- slycot/tests/test_mb.py | 28 +++++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 9 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 8be35789..b7415a0a 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -151,7 +151,8 @@ def mb05md(a, delta, balanc='N'): VAL = VALr return (Ar, Vr, Yr, VAL) elif INFO < 0: - error_text = "The following argument had an illegal value: "+arg_list[-INFO-1] + error_text = "The following argument had an illegal value: " \ + + arg_list[-INFO-1] elif INFO > 0 and INFO <= n: error_text = "Incomplete eigenvalue calculation, missing %i eigenvalues" % INFO elif INFO == n+1: @@ -193,22 +194,21 @@ def mb05nd(a, delta, tol=1e-7): H : Int[F(s) ds] from s = 0 to s = delta, """ hidden = ' (hidden by the wrapper)' - arg_list = [ 'n', 'delta', 'a', 'lda'+hidden, 'ex', 'ldex'+hidden, - 'exint', 'ldexin'+hidden, 'tol', 'iwork'+hidden, - 'dwork'+hidden, 'ldwork'+hidden] - out = _wrapper.mb05nd(n=min(a.shape), delta=delta, a=a, tol=tol) - n = out[-4] + arg_list = ['n', 'delta', 'a', 'lda'+hidden, 'ex', 'ldex'+hidden, + 'exint', 'ldexin'+hidden, 'tol', 'iwork'+hidden, + 'dwork'+hidden, 'ldwork'+hidden] + n = min(a.shape) + out = _wrapper.mb05nd(n=n, delta=delta, a=a, tol=tol) if out[-1] == 0: return out[:-1] elif out[-1] < 0: error_text = "The following argument had an illegal value: " \ - +arg_list[-out[-1]-1] + + arg_list[-out[-1]-1] elif out[-1] == n+1: error_text = "Delta too large" e = ValueError(error_text) e.info = out[-1] raise e - # to be replaced by python wrappers diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index c52f69aa..dd46b98f 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -6,7 +6,7 @@ import unittest import numpy as np -from slycot import mb05md +from slycot import mb05md, mb05nd from numpy.testing import assert_allclose @@ -51,6 +51,32 @@ def test_mb05md(self): assert_allclose(np.dot(Vr, Yr), np.dot(Vr_ref, Yr_ref), atol=0.0001) + def test_mb05nd(self): + """ test_mb05nd: verify Matrix exponential and integral + data from http://slicot.org/objects/software/shared/doc/MB05ND.html + """ + A = np.array([[5.0, 4.0, 3.0, 2.0, 1.0], + [1.0, 6.0, 0.0, 4.0, 3.0], + [2.0, 0.0, 7.0, 6.0, 5.0], + [1.0, 3.0, 1.0, 8.0, 7.0], + [2.0, 5.0, 7.0, 1.0, 9.0]]) + delta = 0.1 + F_ref = np.array([[1.8391, 0.9476, 0.7920, 0.8216, 0.7811], + [0.3359, 2.2262, 0.4013, 1.0078, 1.0957], + [0.6335, 0.6776, 2.6933, 1.6155, 1.8502], + [0.4804, 1.1561, 0.9110, 2.7461, 2.0854], + [0.7105, 1.4244, 1.8835, 1.0966, 3.4134]]) + H_ref = np.array([[0.1347, 0.0352, 0.0284, 0.0272, 0.0231], + [0.0114, 0.1477, 0.0104, 0.0369, 0.0368], + [0.0218, 0.0178, 0.1624, 0.0580, 0.0619], + [0.0152, 0.0385, 0.0267, 0.1660, 0.0732], + [0.0240, 0.0503, 0.0679, 0.0317, 0.1863]]) + + (F, H) = mb05nd(A, delta) + + assert_allclose(F, F_ref, atol=0.0001) + assert_allclose(H, H_ref, atol=0.0001) + if __name__ == "__main__": unittest.main() From 2bac74ee0f38dccd2a178cd7f2cd70edab703641 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 17:48:04 +0200 Subject: [PATCH 085/405] fix CMakeLists, remove stub test_2 --- slycot/CMakeLists.txt | 2 +- slycot/tests/CMakeLists.txt | 2 +- slycot/tests/test.py | 10 ---------- 3 files changed, 2 insertions(+), 12 deletions(-) diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 2046c4a2..c006985e 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -104,7 +104,7 @@ set(FSOURCES set(F2PYSOURCE src/_wrapper.pyf) set(F2PYSOURCE_DEPS - src/analysis.pyf src/math.pyf src/mathematical.pyf + src/analysis.pyf src/math.pyf src/transform.pyf src/synthesis.pyf) configure_file(version.py.in version.py @ONLY) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 25abbf90..35819198 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -15,5 +15,5 @@ set(PYSOURCE install(FILES ${PYSOURCE} PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE - OTHER_READ OTHER_EXECUTE + WORLD_READ WORLD_EXECUTE DESTINATION slycot/tests) diff --git a/slycot/tests/test.py b/slycot/tests/test.py index ec0b0720..19f7dfc8 100644 --- a/slycot/tests/test.py +++ b/slycot/tests/test.py @@ -1,6 +1,5 @@ import unittest from slycot import synthesis -from slycot import math from slycot import transform class Test(unittest.TestCase): @@ -11,11 +10,6 @@ def setUp(self): def test_1(self): synthesis.sb02mt(1,1,1,1) - def test_2(self): - from numpy import array - a = array([[-2, 0.5], [-1.6, -5]]) - Ar, Vr, Yr, VALRr, VALDr = math.mb05md(a, 0.1) - def test_sb02ad(self): "Test sb10ad, Hinf synthesis" import numpy as np @@ -64,9 +58,5 @@ def test_td04ad_static(self): nr,a,b,c,d = transform.td04ad(rc,nin,nout,index,den,num) -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) - - if __name__ == "__main__": unittest.main() From 2a3c98cf83ac2bc1b7c36cf5e061a1dc19dd2904 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 10 Aug 2019 21:22:42 +0200 Subject: [PATCH 086/405] make test_mb.py executable --- slycot/tests/test_mb.py | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 slycot/tests/test_mb.py diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py old mode 100644 new mode 100755 From 8bc7a4effaaa4a2c9494930df4270021b4ddaf12 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 11 Aug 2019 00:08:10 +0200 Subject: [PATCH 087/405] add unittests for mc01td, fix dp constraint --- slycot/src/math.pyf | 2 +- slycot/tests/CMakeLists.txt | 1 + slycot/tests/test_mc.py | 46 +++++++++++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 slycot/tests/test_mc.py diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index 2a290939..101e20e2 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -3,7 +3,7 @@ subroutine mc01td(dico,dp,p,stable,nz,dwork,iwarn,info) ! in :new:MC01TD.f character :: dico - integer intent(in,out),check(dp>0) :: dp + integer intent(in,out),check(dp>=0) :: dp double precision intent(in),check(shape(p,0)==dp+1),dimension(dp+1),depend(dp) :: p logical intent(out) :: stable integer intent(out) :: nz diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 35819198..0611a1e3 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -4,6 +4,7 @@ set(PYSOURCE test.py test_ag08bd.py test_mb.py + test_mc.py test_sb10jd.py test_sg02ad.py test_sg03ad.py diff --git a/slycot/tests/test_mc.py b/slycot/tests/test_mc.py new file mode 100644 index 00000000..5e703f87 --- /dev/null +++ b/slycot/tests/test_mc.py @@ -0,0 +1,46 @@ +#!/usr/bin/env python +# +# test_mc.py - test suite for polynomial and rational function manipulation +# bnavigator , Aug 2019 + +import unittest +import warnings + +from slycot import mc01td + + +class test_mc(unittest.TestCase): + + def test_mc01td(self): + """ test_mc01td: doc example + data from http://slicot.org/objects/software/shared/doc/MC01TD.html + """ + (dp, stable, nz) = mc01td('C', 4, [2, 0, 1, -1, 1]) + self.assertEqual(dp, 4) + self.assertEqual(stable, 0) + self.assertEqual(nz, 2) + + def test_mc01td_D(self): + """ test_mc01td_D: test discrete option """ + (dp, stable, nz) = mc01td('D', 3, [1, 2, 3, 4]) + self.assertEqual(dp, 3) + self.assertEqual(stable, 1) + self.assertEqual(nz, 0) + (dp, stable, nz) = mc01td('D', 3, [4, 3, 2, 1]) + self.assertEqual(dp, 3) + self.assertEqual(stable, 0) + self.assertEqual(nz, 3) + + def test_mc01td_warnings(self): + """ test_mc01td_warnings: Test warnings """ + T = [([0, 0], "entry P(x) is the zero polynomial."), + ([0, 1], "P(x) may have zeros very close to stability boundary."), + ([1, 0], "The degree of P(x) has been reduced to 0")] + for P, m in T: + with warnings.catch_warnings(record=True) as w: + (dp, stable, nz) = mc01td('C', len(P)-1, P) + self.assertEqual(str(w[0].message), m) + + +if __name__ == "__main__": + unittest.main() From b1205d46b687764bfe69bacdb046e312fddbd1d6 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 11 Aug 2019 12:01:30 +0200 Subject: [PATCH 088/405] fix typo in test_mb --- slycot/tests/test_mb.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index dd46b98f..2f8e3750 100755 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -44,7 +44,7 @@ def test_mb05md(self): erow = np.ones(VAL.shape)*e i_ref = np.isclose(erow, VAL_ref) self.assertTrue(any(i_ref), - msg="eigenvalue {} not expetced".format(e)) + msg="eigenvalue {} not expected".format(e)) # Eigenvectors can have different scaling. vr_ref = Vr_ref[:, i_ref]*Vr[0, i]/Vr_ref[0, i_ref][0] assert_allclose(Vr[:, (i,)], vr_ref, atol=0.0001) From 2cafe1db900cbf3d36db644017297abb87fece46 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sat, 25 Jan 2020 18:25:16 -0500 Subject: [PATCH 089/405] simplified conda build files --- conda-recipe/build.sh | 3 ++- conda-recipe/meta.yaml | 41 ++++++++++++++++------------------------- 2 files changed, 18 insertions(+), 26 deletions(-) diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index 670972f0..17ef0171 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -12,4 +12,5 @@ rm -rf _skbuild env # do the build -$PYTHON -m pip install . --no-deps --ignore-installed -vv +#$PYTHON -m pip install . --no-deps --ignore-installed -vv +$PYTHON setup.py build_ext -llapack -lblas install diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 2e7646f5..c8f381cf 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -16,42 +16,33 @@ requirements: # conda-forge might have the configuration in place for clang build and link? # TODO: pip possibly required in only *one* of build and host, but which? build: - - python {{PY_VER}} - - numpy - - {{ compiler('c') }} # [not osx] - - gcc # [osx] - - {{ compiler('fortran') }} # [linux] - - scikit-build >=0.8.0 + - {{ compiler('c') }} + - {{ compiler('fortran') }} # [unix] + - flang # [win] host: - - python {{ PY_VER }} - - pip - - flang # [win] - numpy - - mkl - - libgfortran-ng # [not win] - - libgcc-ng # [linux] - - libflang # [win] - - scikit-build >=0.8.0 + - libblas + - liblapack + - python + - scikit-build + # on Windows, this relies on having visual studio CE 2015 # this link needed quite some searching, please do not delete! # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 run: - - python {{ PY_VER }} + - python - {{ pin_compatible('numpy') }} - - mkl - - libgfortran-ng # [not win] - - libgcc-ng # [linux] - - libflang # [win] - + test: - requires: - - python {{PY_VER}} imports: - slycot about: - home: https://github.com/python-control/slycot - license: GPLv2 - summary: 'A wrapper for the SLICOT control and systems library' + home: https://github.com/python-control/Slycot + dev_url: https://github.com/python-control/Slycot + license: GPL-2.0 + license_family: GPL + license_file: COPYING + summary: 'Slycot: A wrapper for the SLICOT control and systems library' From f6cedefe174f16aab49669d2a73549edc539daa8 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sat, 25 Jan 2020 21:33:47 -0500 Subject: [PATCH 090/405] build system simpler --- CMakeLists.txt | 1 - conda-recipe/bld.bat | 3 ++- conda-recipe/build.sh | 5 +---- conda-recipe/meta.yaml | 4 ---- slycot/CMakeLists.txt | 24 ++++++------------------ 5 files changed, 9 insertions(+), 28 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 6667eaeb..bc415fb5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -21,7 +21,6 @@ enable_language(Fortran) find_package(PythonLibs REQUIRED) find_package(NumPy REQUIRED) -#set(BLA_VENDOR "OpenBLAS") find_package(LAPACK REQUIRED) message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") message(STATUS "Slycot version: ${SLYCOT_VERSION}") diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index be6bdd74..ab0f7372 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -5,6 +5,7 @@ cd .. :: clean old build attempts RD /S /Q _skbuild +set FC=%BUILD_PREFIX%\Library\bin\flang.exe set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% set NUMPY_INCLUDE=%PREFIX%\Include @@ -16,7 +17,7 @@ if EXIST "%PREFIX%\Scripts\f2py.exe" ( set F2PY=%PREFIX%\Scripts\f2py.bat ) -"%PYTHON%" -m pip install . --no-deps --ignore-installed -vv +"%PYTHON%" setup.py build_ext install if errorlevel 1 exit 1 diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index 17ef0171..c2abd37d 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -9,8 +9,5 @@ export LAPACK_ROOT=${PREFIX} # ensure we are not building with old cmake files rm -rf _skbuild -env - # do the build -#$PYTHON -m pip install . --no-deps --ignore-installed -vv -$PYTHON setup.py build_ext -llapack -lblas install +$PYTHON setup.py build_ext install diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index c8f381cf..61c82629 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -26,10 +26,6 @@ requirements: - liblapack - python - scikit-build - - # on Windows, this relies on having visual studio CE 2015 - # this link needed quite some searching, please do not delete! - # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 run: - python diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 2046c4a2..892e16de 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -115,6 +115,8 @@ set(PYSOURCE transform.py ${CMAKE_CURRENT_BINARY_DIR}/version.py) set(SLYCOT_MODULE "_wrapper") +find_package(PythonExtensions REQUIRED) + set(GENERATED_MODULE ${CMAKE_CURRENT_BINARY_DIR}/${SLYCOT_MODULE}${PYTHON_EXTENSION_MODULE_SUFFIX}) @@ -130,33 +132,18 @@ add_custom_command( ) add_library( - ${SLYCOT_MODULE} SHARED + ${SLYCOT_MODULE} MODULE SLYCOTmodule.c _wrappermodule.c _wrapper-f2pywrappers.f "${PYTHON_SITE}/numpy/f2py/src/fortranobject.c" ${FSOURCES}) -set(CMAKE_SHARED_LIBRARY_PREFIX "") -if (WIN32) - set(CMAKE_SHARED_LIBRARY_SUFFIX ".pyd") -endif() -set_target_properties(${SLYCOT_MODULE} PROPERTIES - OUTPUT_NAME "_wrapper") -if (WIN32) - target_link_libraries(${SLYCOT_MODULE} PUBLIC - ${PYTHON_LIBRARIES} ${LAPACK_LIBRARIES}) -endif() +target_link_libraries(${SLYCOT_MODULE} + ${LAPACK_LIBRARIES}) if (UNIX) - target_link_libraries(${SLYCOT_MODULE} PUBLIC - ${LAPACK_LIBRARIES}) - if (APPLE) set_target_properties(${SLYCOT_MODULE} PROPERTIES LINK_FLAGS '-Wl,-dylib,-undefined,dynamic_lookup') - string(REGEX REPLACE "^([0-9]+)\.([0-9]+)\.[0-9]+$" "\\1\\2" - PYMAJORMINOR ${PYTHON_VERSION_STRING}) - set(CMAKE_SHARED_LIBRARY_SUFFIX ".cpython-${PYMAJORMINOR}m-darwin.so") - message(STATUS "binary module suffix ${CMAKE_SHARED_LIBRARY_SUFFIX}") else() set_target_properties(${SLYCOT_MODULE} PROPERTIES LINK_FLAGS '-Wl,--allow-shlib-undefined') @@ -170,6 +157,7 @@ target_include_directories( ${PYTHON_INCLUDE_DIRS} ) +python_extension_module(${SLYCOT_MODULE}) install(TARGETS ${SLYCOT_MODULE} DESTINATION slycot) install(FILES ${PYSOURCE} DESTINATION slycot) From 0bdf823f3675e572e6b92444377fbd15bef2de78 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Fri, 31 Jan 2020 09:03:24 -0500 Subject: [PATCH 091/405] do not use pip for building the recipe; pip may install missing dependencies, defeating the purpopse of a clean conda recipe --- conda-recipe/build.sh | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index c2abd37d..bb8cbe16 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,13 +1,10 @@ cd $RECIPE_DIR/.. -# specify where CMAKE will search for lapack and blas -# needs recent cmake (conda's 3.12) and policy CMP0074 NEW -# the ${PREFIX} points to conda-build's host environment -export BLAS_ROOT=${PREFIX} -export LAPACK_ROOT=${PREFIX} +# specify blas vendor should be MKL +export CMAKE_EXTRA_ARGS="-DBLA_VENDOR=MKL" # ensure we are not building with old cmake files rm -rf _skbuild # do the build -$PYTHON setup.py build_ext install +$PYTHON setup.py build_ext install From b3b1dd8eb0371def6571296d40849afb947e576d Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Fri, 31 Jan 2020 09:05:04 -0500 Subject: [PATCH 092/405] simplify recipe, remove pip --- conda-recipe-openblas/meta.yaml | 42 ++++++++++----------------------- 1 file changed, 12 insertions(+), 30 deletions(-) diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 0ea376ce..6a574dd5 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -12,46 +12,28 @@ build: requirements: # TODO: pip possibly required in only *one* of build and host, but which? build: - - python {{ PY_VER }} - - numpy - - openblas >=0.3.0 - - {{ compiler('c') }} # [not osx] - - gcc # [osx] - - {{ compiler('fortran') }} # [linux] - - scikit-build >=0.8.0 + - {{ compiler('c') }} + - {{ compiler('fortran') }} # [unix] + - flang # [win] host: - - python {{ PY_VER }} - - pip - - flang # [win] - numpy - - openblas >=0.3.0 - - libgfortran-ng # [not-win] - - libgcc-ng # [linux] - - scikit-build >=0.8.0 - # on Windows, this relies on having visual studio CE 2015 - # this link needed quite some searching, please do not delete! - # https://go.microsoft.com/fwlink/?LinkId=532606&clcid=0x409 + - libopenblas + - python + - scikit-build run: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} - - openblas >=0.3.0 - - libgfortran-ng # [not win] - - libgcc-ng # [linux] - - libflang # [win] test: - requires: - - python {{PY_VER}} imports: - slycot about: - home: https://github.com/python-control/slycot - license: GPLv2 - summary: 'A wrapper for the SLICOT control and systems library' - -# on OSX, the SDK for 10.9 is currently needed -# download the 10.9 sdk from https://github.com/phracker/MacOSX-SDKs/releases -# unpack and set environment variable CONDA_BUILD_SYSROOT to that location + home: https://github.com/python-control/Slycot + dev_url: https://github.com/python-control/Slycot + license: GPL-2.0 + license_family: GPL + license_file: COPYING + summary: 'Slycot: A wrapper for the SLICOT control and systems library' From 3996637b49116ab881ee12653615d9a8659e58b4 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Fri, 31 Jan 2020 12:01:43 -0500 Subject: [PATCH 093/405] bring two conda recipes in line, one with openblas, one with mkl --- CMakeLists.txt | 1 + conda-recipe-openblas/build.sh | 8 ++------ conda-recipe-openblas/meta.yaml | 4 ++-- conda-recipe/bld.bat | 14 +++----------- conda-recipe/build.sh | 4 ++-- conda-recipe/meta.yaml | 10 +++------- 6 files changed, 13 insertions(+), 28 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bc415fb5..a1038751 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -21,6 +21,7 @@ enable_language(Fortran) find_package(PythonLibs REQUIRED) find_package(NumPy REQUIRED) +find_package(BLAS REQUIRED) find_package(LAPACK REQUIRED) message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") message(STATUS "Slycot version: ${SLYCOT_VERSION}") diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index a124b743..71a0d6c4 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -1,11 +1,7 @@ - cd $RECIPE_DIR/.. -# specify where CMAKE will search for lapack and blas -# needs recent cmake (conda's 3.12) and policy CMP0074 NEW -# the ${PREFIX} points to conda-build's host environment -export BLAS_ROOT=${PREFIX} -export LAPACK_ROOT=${PREFIX} +# specify blas vendor should be OpenBLAS +export BLA_VENDOR=OpenBLAS # ensure we are not building with old cmake files rm -rf _skbuild diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 6a574dd5..c6aaa2a6 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -10,7 +10,6 @@ build: string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_obl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: - # TODO: pip possibly required in only *one* of build and host, but which? build: - {{ compiler('c') }} - {{ compiler('fortran') }} # [unix] @@ -21,7 +20,8 @@ requirements: - libopenblas - python - scikit-build - + - pip + run: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index ab0f7372..1b0a25e6 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -2,13 +2,11 @@ cd %RECIPE_DIR% cd .. -:: clean old build attempts +:: Clean old build attempts RD /S /Q _skbuild set FC=%BUILD_PREFIX%\Library\bin\flang.exe -set BLAS_ROOT=%PREFIX% -set LAPACK_ROOT=%PREFIX% -set NUMPY_INCLUDE=%PREFIX%\Include +set BLA_VENDOR=Intel10_64lp :: Prefer f2py.exe, if it exists; this is provided by numpy 1.16 (and, we assume, later) if EXIST "%PREFIX%\Scripts\f2py.exe" ( set F2PY=%PREFIX%\Scripts\f2py.exe @@ -17,12 +15,6 @@ if EXIST "%PREFIX%\Scripts\f2py.exe" ( set F2PY=%PREFIX%\Scripts\f2py.bat ) -"%PYTHON%" setup.py build_ext install +"%PYTHON%" -m pip install . --no-deps --ignore-installed -vv if errorlevel 1 exit 1 - -:: Add more build steps here, if they are necessary. - -:: See -:: http://docs.continuum.io/conda/build.html -:: for a list of environment variables that are set during the build process. diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index bb8cbe16..0ebacbcb 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -1,10 +1,10 @@ cd $RECIPE_DIR/.. # specify blas vendor should be MKL -export CMAKE_EXTRA_ARGS="-DBLA_VENDOR=MKL" +export DBLA_VENDOR=Intel10_64lp # ensure we are not building with old cmake files rm -rf _skbuild # do the build -$PYTHON setup.py build_ext install +$PYTHON -m pip install . --no-deps --ignore-installed -vv diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 61c82629..6cace7fc 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -10,11 +10,6 @@ build: string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_mkl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: - # note: the osx build is with gcc for now, due to problems with the - # conda-supplied clang and library linking see e.g. - # https://github.com/conda-forge/mpi-feedstock issue #4 - # conda-forge might have the configuration in place for clang build and link? - # TODO: pip possibly required in only *one* of build and host, but which? build: - {{ compiler('c') }} - {{ compiler('fortran') }} # [unix] @@ -22,14 +17,15 @@ requirements: host: - numpy - - libblas - - liblapack + - mkl - python - scikit-build + - pip run: - python - {{ pin_compatible('numpy') }} + - mkl test: imports: From 93075e2eaf5b31229379b0de46570bcdf8aa21ac Mon Sep 17 00:00:00 2001 From: Ben Date: Sun, 2 Feb 2020 00:52:15 +0100 Subject: [PATCH 094/405] add libopenblas to run section --- conda-recipe-openblas/meta.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index c6aaa2a6..a584562b 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -25,6 +25,7 @@ requirements: run: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} + - libopenblas test: imports: From ae20794a9472a06bdbe8eaeb18f86f9b51da579b Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 2 Feb 2020 01:04:26 +0100 Subject: [PATCH 095/405] bla_vendor openblas on CONDA=0 --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index bf781ccf..0041d505 100644 --- a/.travis.yml +++ b/.travis.yml @@ -151,7 +151,7 @@ install: conda install conda-forge::openblas>=0.3.0; conda install local::slycot; else - CMAKE_GENERATOR="Unix Makefiles" python setup.py install; + CMAKE_GENERATOR="Unix Makefiles" BLA_VENDOR="OpenBLAS" python setup.py install; fi # # coveralls not in conda repos :-( From 49055a360ebeb82501e5a035652290c9fac20bf9 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 2 Feb 2020 00:19:38 +0100 Subject: [PATCH 096/405] reorganize travis configuration, remove runtests.py Linux builds: conda builds based on pip and Ubuntu 18.04 packages python versions 2.7 to 3.8 OSX builds: CONDA with custom SDK (not functional) osx / pip packages replaced old runtests.py with direct pytest call --- .coveragerc | 1 + .travis.yml | 276 +++++++------- conda-recipe-apple/build.sh | 6 + conda-recipe-apple/conda_build_config.yaml | 2 + conda-recipe-apple/meta.yaml | 39 ++ {conda-recipe => conda-recipe-mkl}/bld.bat | 0 {conda-recipe => conda-recipe-mkl}/build.sh | 2 +- {conda-recipe => conda-recipe-mkl}/meta.yaml | 2 +- runtests.py | 379 ------------------- 9 files changed, 179 insertions(+), 528 deletions(-) create mode 100644 conda-recipe-apple/build.sh create mode 100644 conda-recipe-apple/conda_build_config.yaml create mode 100644 conda-recipe-apple/meta.yaml rename {conda-recipe => conda-recipe-mkl}/bld.bat (100%) rename {conda-recipe => conda-recipe-mkl}/build.sh (85%) rename {conda-recipe => conda-recipe-mkl}/meta.yaml (97%) delete mode 100644 runtests.py diff --git a/.coveragerc b/.coveragerc index be3a6de2..5841bd04 100644 --- a/.coveragerc +++ b/.coveragerc @@ -1,2 +1,3 @@ [run] source = slycot +omit = */tests/* diff --git a/.travis.yml b/.travis.yml index 0041d505..a5091671 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,173 +1,155 @@ -# The test matrix includes OSX and Linux - -# Don't know how to do non-Conda builds on OSX - -# Linux builds needs extra settings (see "dist" and "services" below) - -matrix: - allow_failures: - - name: "OSX, Python 2.7, TEST_CONDA=1" - os: osx - env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 - - - name: "OSX, Python 3.5, TEST_CONDA=1" - os: osx - env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 - - - name: "OSX, Python 3.6, TEST_CONDA=1" - os: osx - env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 - - - name: "OSX, Python 3.7, TEST_CONDA=1" - os: osx - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 - +# Default entries for matrix jobs +os: linux +language: python +dist: bionic +services: xvfb # needed for the python-control tests + +# Start with a 2x4 matrix of Linux builds +python: + - "3.7" + - "3.8" +env: + - TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + - TEST_PKG="conda" BLA_VENDOR="Intel10_64lp" # MKL + - TEST_PKG="dist" BLA_VENDOR="OpenBLAS" + - TEST_PKG="dist" BLA_VENDOR="Generic" # reference BLAS/LAPACK + +jobs: + # additional single OSX and Linux jobs include: - - name: "OSX, Python 2.7, TEST_CONDA=1" + - name: "MacOSX, Conda Python 3" os: osx - env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 - - - name: "OSX, Python 3.5, TEST_CONDA=1" + language: shell + env: TEST_PKG="conda" BLA_VENDOR="Apple" + - name: "MacOSX, default Python 3" os: osx - env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 - - - name: "OSX, Python 3.6, TEST_CONDA=1" + language: shell + env: TEST_PKG="dist" BLA_VENDOR="Apple" + - name: "MacOSX, pyenv 2.7" os: osx - env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 - - - name: "OSX, Python 3.7, TEST_CONDA=1" + language: shell + env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=2.7.17 + - name: "MacOSX, pyenv 3.8" os: osx - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 - - - name: "Ubuntu 16.04, Python 2.7, TEST_CONDA=0" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=0 - - - name: "Ubuntu 16.04, Python 2.7, TEST_CONDA=1" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=2.7 TEST_CONDA=1 - - - name: "Ubuntu 16.04, Python 3.5, TEST_CONDA=0" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=0 - - - name: "Ubuntu 16.04, Python 3.5, TEST_CONDA=1" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=3.5 TEST_CONDA=1 - - - name: "Ubuntu 16.04, Python 3.6, TEST_CONDA=0" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=0 - - - name: "Ubuntu 16.04, Python 3.6, TEST_CONDA=1" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=3.6 TEST_CONDA=1 - - - name: "Ubuntu 16.04, Python 3.7, TEST_CONDA=0" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=0 - - - name: "Ubuntu 16.04, Python 3.7, TEST_CONDA=1" - os: linux - dist: xenial - services: xvfb - env: SLYCOT_PYTHON_VERSION=3.7 TEST_CONDA=1 - + language: shell + env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 + # additional Linux builds using defaults from above + # only one build per old python version + - name: "Linux, Py2.7" + python: "2.7" + env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + - name: "Linux, Py3.5" + python: "3.5" + env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + - name: "Linux, Py3.6" + python: "3.6" + env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + allowed_failures: + - os: osx + env: TEST_PKG="conda" BLA_VENDOR="Apple" before_install: - - if [[ $TEST_CONDA == 0 && $TRAVIS_OS_NAME != linux ]]; then - echo "Only Linux supported for non-Conda builds"; - exit 1; + - | + # Install Ubuntu packages + if [[ $TEST_PKG == "dist" && $TRAVIS_OS_NAME == linux ]]; then + sudo apt-get update + sudo apt-get -y install gfortran cmake + if [[ $BLA_VENDOR == "OpenBLAS" ]]; then + sudo apt-get -y install libopenblas-dev + elif [[ $BLA_VENDOR == "Generic" ]]; then + sudo apt-get -y install libblas-dev liblapack-dev + else + echo "Unsupported BLAS Vendor: '$BLA_VENDOR'" + exit 2 + fi fi - # from here on assume $TEST_CONDA == 0 implies $TRAVIS_OS_NAME == linux - - - if [[ $TEST_CONDA == 0 ]]; then - sudo apt-get install liblapack-dev libblas-dev; - sudo apt-get install gfortran; - sudo apt-get install cmake; + - | + # Install MacOSX packages + if [[ $TEST_PKG == "dist" && $TRAVIS_OS_NAME == osx ]]; then + if [ -n "$SLYCOT_PYTHON_VERSION" ]; then + pyenv install $SLYCOT_PYTHON_VERSION + pyenv global $SLYCOT_PYTHON_VERSION + eval "$(pyenv init -)" + export MPLBACKEND="TkAgg" + else + mkdir -p ~/.local/bin + ln -s $(which python3) ~/.local/bin/python + ln -s $(which pip3) ~/.local/bin/pip + fi fi - - install: - # - # Install miniconda to allow quicker installation of dependencies - # See https://conda.io/docs/user-guide/tasks/use-conda-with-travis-ci.html - # - if [[ $TRAVIS_OS_NAME == linux ]]; then - wget http://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh; - else - wget https://repo.anaconda.com/miniconda/Miniconda3-latest-MacOSX-x86_64.sh -O miniconda.sh; - fi - - bash miniconda.sh -b -p $HOME/miniconda - - export PATH="$HOME/miniconda/bin:$PATH" - - hash -r - - conda config --set always_yes yes --set changeps1 no - - conda update -q --all - - if [[ $TEST_CONDA == 1 ]]; then - conda install conda-build; - conda install conda-verify; + export SLYCOT_PYTHON_VERSION="$TRAVIS_PYTHON_VERSION"; fi - - conda info -a - # - # Set up a test environment for testing everything out - - conda create -q -n test-environment python="$SLYCOT_PYTHON_VERSION" pip coverage nose numpy openblas - - source activate test-environment - # - # Make sure that fortran compiler can find conda libraries - # - - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib"; - - # install scikit-build - - if [[ $TEST_CONDA == 0 ]]; then + - | + # compile using conda environment or distribution libraries + if [[ $TEST_PKG == conda ]]; then + # + # Install miniconda to allow quicker installation of dependencies + # See https://conda.io/projects/conda/en/latest/user-guide/tasks/use-conda-with-travis-ci.html + # + if [[ $TRAVIS_OS_NAME == linux ]]; then + wget http://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh + elif [[ $TRAVIS_OS_NAME == osx ]]; then + wget http://repo.continuum.io/miniconda/Miniconda3-latest-MacOSX-x86_64.sh -O miniconda.sh + wget https://github.com/phracker/MacOSX-SDKs/releases/download/10.15/MacOSX10.9.sdk.tar.xz + sudo mkdir -p /opt/MacOSX10.9.sdk + sudo tar -C /opt/MacOSX10.9.sdk -xJf MacOSX10.9.sdk.tar.xz + else + echo "Unsupported OS for conda builds: TRAVIS_OS_NAME" + exit 4 + fi + bash miniconda.sh -b -p $HOME/miniconda + source "$HOME/miniconda/etc/profile.d/conda.sh" + hash -r + conda config --set always_yes yes --set changeps1 no + conda update -q --all + conda install conda-build + conda install conda-verify conda config --append channels conda-forge; - conda install -c conda-forge scikit-build >=0.8.0 ; - fi - # - # Install the slycot package (two ways, to improve robustness). For the - # conda version, need to install lapack from conda-forge (no way to specify - # this in the recipe). - # add the conda-forge channel to the config, otherwise openblas or - # lapack cannot be found in the check - # with --override-channels to make sure the locally built slycot is installed - # - - if [[ $TEST_CONDA == 1 ]]; then - conda config --append channels conda-forge; - conda build --python "$SLYCOT_PYTHON_VERSION" conda-recipe-openblas; - conda install conda-forge::openblas>=0.3.0; - conda install local::slycot; + conda info -a; + if [[ $BLA_VENDOR == "OpenBLAS" ]]; then + conda_blas=openblas + conda_recipe=conda-recipe-openblas + elif [[ $BLA_VENDOR == "Intel10_64lp" ]]; then + conda_blas=mkl + conda_recipe=conda-recipe-mkl + elif [[ $BLA_VENDOR == "Apple" ]]; then + conda_blas= + conda_recipe=conda-recipe-apple + else + echo "Unsupported BLA_VENDOR for conda builds: $BLA_VENDOR" + exit 3 + fi + conda create -q -n test-environment \ + python="$SLYCOT_PYTHON_VERSION" \ + pip coverage pytest-cov \ + numpy scipy matplotlib \ + $conda_blas + conda activate test-environment + export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib" + conda build --python "$SLYCOT_PYTHON_VERSION" $conda_recipe + conda install local::slycot + elif [[ $TEST_PKG == dist ]]; then + pip install scikit-build pytest-cov matplotlib scipy; + CMAKE_GENERATOR="Unix Makefiles" python setup.py install; else - CMAKE_GENERATOR="Unix Makefiles" BLA_VENDOR="OpenBLAS" python setup.py install; + echo "Wrong TEST_PKG '$TEST_PKG'" + exit 1 fi - # - # coveralls not in conda repos :-( - - pip install coveralls + # coveralls not in ubuntu or conda repos + pip install coveralls script: - # Local unit tests - # TODO: replace with nose? + # slycots own unit tests as installed, not from source dir - cd .. - - python Slycot/runtests.py --coverage --no-build + - slycot_dir=$(python -c "import slycot; print(slycot.__path__[0])") + - pytest --pyargs slycot --cov=$slycot_dir --cov-config=Slycot/.coveragerc # # As a deeper set of tests, get test against python-control as well # - # Additional packages required for python-control - - conda install scipy matplotlib # Get python-control from source and install - git clone --depth 1 https://github.com/python-control/python-control.git control - cd control diff --git a/conda-recipe-apple/build.sh b/conda-recipe-apple/build.sh new file mode 100644 index 00000000..9e868bc8 --- /dev/null +++ b/conda-recipe-apple/build.sh @@ -0,0 +1,6 @@ +export LDFLAGS="$LDFLAGS -v" +if [[ "$target_platform" == osx-64 ]]; then + export LDFLAGS="${LDFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" + export CFLAGS="${CFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" +fi +$PYTHON setup.py build_ext install -- -DCMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} diff --git a/conda-recipe-apple/conda_build_config.yaml b/conda-recipe-apple/conda_build_config.yaml new file mode 100644 index 00000000..34222a64 --- /dev/null +++ b/conda-recipe-apple/conda_build_config.yaml @@ -0,0 +1,2 @@ +CONDA_BUILD_SYSROOT: + - /opt/MacOSX10.9.sdk diff --git a/conda-recipe-apple/meta.yaml b/conda-recipe-apple/meta.yaml new file mode 100644 index 00000000..b36461a1 --- /dev/null +++ b/conda-recipe-apple/meta.yaml @@ -0,0 +1,39 @@ +package: + name: slycot + version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} + +source: + git_url: ../ + +build: + number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_mkl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + +requirements: + build: + - {{ compiler('c') }} + - {{ compiler('fortran') }} # [unix] + - flang # [win] + + host: + - numpy + - python + # conda-forge::scikit-build>=0.10.0 includes MACOSX_DEPLOYMENT_TARGET + # patches from https://github.com/scikit-build/scikit-build/pull/441 + - scikit-build >=0.10.0 + + run: + - python + - {{ pin_compatible('numpy') }} + +test: + imports: + - slycot + +about: + home: https://github.com/python-control/Slycot + dev_url: https://github.com/python-control/Slycot + license: GPL-2.0 + license_family: GPL + license_file: COPYING + summary: 'Slycot: A wrapper for the SLICOT control and systems library' diff --git a/conda-recipe/bld.bat b/conda-recipe-mkl/bld.bat similarity index 100% rename from conda-recipe/bld.bat rename to conda-recipe-mkl/bld.bat diff --git a/conda-recipe/build.sh b/conda-recipe-mkl/build.sh similarity index 85% rename from conda-recipe/build.sh rename to conda-recipe-mkl/build.sh index 0ebacbcb..a122f8b1 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe-mkl/build.sh @@ -1,7 +1,7 @@ cd $RECIPE_DIR/.. # specify blas vendor should be MKL -export DBLA_VENDOR=Intel10_64lp +export BLA_VENDOR=Intel10_64lp # ensure we are not building with old cmake files rm -rf _skbuild diff --git a/conda-recipe/meta.yaml b/conda-recipe-mkl/meta.yaml similarity index 97% rename from conda-recipe/meta.yaml rename to conda-recipe-mkl/meta.yaml index 6cace7fc..2b19e938 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe-mkl/meta.yaml @@ -23,7 +23,7 @@ requirements: - pip run: - - python + - python {{ PY_VER }} - {{ pin_compatible('numpy') }} - mkl diff --git a/runtests.py b/runtests.py deleted file mode 100644 index a0b91c70..00000000 --- a/runtests.py +++ /dev/null @@ -1,379 +0,0 @@ -#!/usr/bin/env python -""" -runtests.py [OPTIONS] [-- ARGS] - -Run tests, building the project first. - -Examples:: - - $ python runtests.py - $ python runtests.py -s {SAMPLE_SUBMODULE} - $ python runtests.py -t {SAMPLE_TEST} - $ python runtests.py --ipython - $ python runtests.py --python somescript.py - -Run a debugger: - - $ gdb --args python runtests.py [...other args...] - -Generate C code coverage listing under build/lcov/: -(requires http://ltp.sourceforge.net/coverage/lcov.php) - - $ python runtests.py --gcov [...other args...] - $ python runtests.py --lcov-html - -""" - -# -# This is a generic test runner script for projects using Numpy's test -# framework. Change the following values to adapt to your project: -# - -PROJECT_MODULE = "slycot" -PROJECT_ROOT_FILES = ['slycot', 'setup.py'] -SAMPLE_TEST = "numpy/linalg/tests/test_linalg.py:test_byteorder_check" -SAMPLE_SUBMODULE = "linalg" - -EXTRA_PATH = ['/usr/lib/ccache', '/usr/lib/f90cache', - '/usr/local/lib/ccache', '/usr/local/lib/f90cache'] - -# --------------------------------------------------------------------- - - -if __doc__ is None: - __doc__ = "Run without -OO if you want usage info" -else: - __doc__ = __doc__.format(**globals()) - - -import sys -import os - -# In case we are run from the source directory, we don't want to import the -# project from there: -sys.path.pop(0) - -import shutil -import subprocess -import time -import imp -from argparse import ArgumentParser, REMAINDER - -ROOT_DIR = os.path.abspath(os.path.join(os.path.dirname(__file__))) - -def main(argv): - parser = ArgumentParser(usage=__doc__.lstrip()) - parser.add_argument("--verbose", "-v", action="count", default=1, - help="more verbosity") - parser.add_argument("--no-build", "-n", action="store_true", default=False, - help="do not build the project (use system installed version)") - parser.add_argument("--build-only", "-b", action="store_true", default=False, - help="just build, do not run any tests") - parser.add_argument("--doctests", action="store_true", default=False, - help="Run doctests in module") - parser.add_argument("--coverage_html", action="store_true", default=False, - help=("report coverage of project code. HTML output goes " - "under build/coverage")) - parser.add_argument("--coverage", action="store_true", default=False, - help=("report coverage of project code.")) - parser.add_argument("--gcov", action="store_true", default=False, - help=("enable C code coverage via gcov (requires GCC). " - "gcov output goes to build/**/*.gc*")) - parser.add_argument("--lcov-html", action="store_true", default=False, - help=("produce HTML for C code coverage information " - "from a previous run with --gcov. " - "HTML output goes to build/lcov/")) - parser.add_argument("--mode", "-m", default="fast", - help="'fast', 'full', or something that could be " - "passed to nosetests -A [default: fast]") - parser.add_argument("--submodule", "-s", default=None, - help="Submodule whose tests to run (cluster, constants, ...)") - parser.add_argument("--pythonpath", "-p", default=None, - help="Paths to prepend to PYTHONPATH") - parser.add_argument("--tests", "-t", action='append', - help="Specify tests to run") - parser.add_argument("--python", action="store_true", - help="Start a Python shell with PYTHONPATH set") - parser.add_argument("--ipython", "-i", action="store_true", - help="Start IPython shell with PYTHONPATH set") - parser.add_argument("--shell", action="store_true", - help="Start Unix shell with PYTHONPATH set") - parser.add_argument("--debug", "-g", action="store_true", - help="Debug build") - parser.add_argument("--show-build-log", action="store_true", - help="Show build output rather than using a log file") - parser.add_argument("args", metavar="ARGS", default=[], nargs=REMAINDER, - help="Arguments to pass to Nose, Python or shell") - args = parser.parse_args(argv) - - if args.lcov_html: - # generate C code coverage output - lcov_generate() - sys.exit(0) - - if args.pythonpath: - for p in reversed(args.pythonpath.split(os.pathsep)): - sys.path.insert(0, p) - - if args.gcov: - gcov_reset_counters() - - if not args.no_build: - site_dir = build_project(args) - sys.path.insert(0, site_dir) - os.environ['PYTHONPATH'] = site_dir - - extra_argv = args.args[:] - if extra_argv and extra_argv[0] == '--': - extra_argv = extra_argv[1:] - - if args.python: - if extra_argv: - # Don't use subprocess, since we don't want to include the - # current path in PYTHONPATH. - sys.argv = extra_argv - with open(extra_argv[0], 'r') as f: - script = f.read() - sys.modules['__main__'] = imp.new_module('__main__') - ns = dict(__name__='__main__', - __file__=extra_argv[0]) - exec_(script, ns) - sys.exit(0) - else: - import code - code.interact() - sys.exit(0) - - if args.ipython: - import IPython - IPython.embed(user_ns={}) - sys.exit(0) - - if args.shell: - shell = os.environ.get('SHELL', 'sh') - print("Spawning a Unix shell...") - os.execv(shell, [shell] + extra_argv) - sys.exit(1) - - if args.coverage_html: - dst_dir = os.path.join(ROOT_DIR, 'build', 'coverage') - fn = os.path.join(dst_dir, 'coverage_html.js') - if os.path.isdir(dst_dir) and os.path.isfile(fn): - shutil.rmtree(dst_dir) - extra_argv += ['--cover-html', - '--cover-html-dir='+dst_dir] - - if args.coverage: - extra_argv += ['--cover-erase', '--with-coverage', - '--cover-package=slycot'] - - test_dir = os.path.join(ROOT_DIR, 'build', 'test') - - if args.build_only: - sys.exit(0) - elif args.submodule: - modname = PROJECT_MODULE + '.' + args.submodule - try: - __import__(modname) - test = sys.modules[modname].test - except (ImportError, KeyError, AttributeError): - print("Cannot run tests for %s" % modname) - sys.exit(2) - elif args.tests: - def fix_test_path(x): - # fix up test path - p = x.split(':') - p[0] = os.path.relpath(os.path.abspath(p[0]), - test_dir) - return ':'.join(p) - - tests = [fix_test_path(x) for x in args.tests] - - def test(*a, **kw): - extra_argv = kw.pop('extra_argv', ()) - extra_argv = extra_argv + tests[1:] - kw['extra_argv'] = extra_argv - from numpy.testing import Tester - return Tester(tests[0]).test(*a, **kw) - else: - __import__(PROJECT_MODULE) - test = sys.modules[PROJECT_MODULE].test - - # Run the tests under build/test - try: - shutil.rmtree(test_dir) - except OSError: - pass - try: - os.makedirs(test_dir) - except OSError: - pass - - cwd = os.getcwd() - try: - os.chdir(test_dir) - result = test(args.mode, - verbose=args.verbose, - extra_argv=extra_argv, - doctests=args.doctests, - coverage=args.coverage) - finally: - os.chdir(cwd) - - if result.wasSuccessful(): - sys.exit(0) - else: - sys.exit(1) - - -def build_project(args): - """ - Build a dev version of the project. - - Returns - ------- - site_dir - site-packages directory where it was installed - - """ - - root_ok = [os.path.exists(os.path.join(ROOT_DIR, fn)) - for fn in PROJECT_ROOT_FILES] - if not all(root_ok): - print("To build the project, run runtests.py in " - "git checkout or unpacked source") - sys.exit(1) - - dst_dir = os.path.join(ROOT_DIR, 'build', 'testenv') - - env = dict(os.environ) - cmd = [sys.executable, 'setup.py'] - - # Always use ccache, if installed - env['PATH'] = os.pathsep.join(EXTRA_PATH + env.get('PATH', '').split(os.pathsep)) - - if args.debug or args.gcov: - # assume everyone uses gcc/gfortran - env['OPT'] = '-O0 -ggdb' - env['FOPT'] = '-O0 -ggdb' - if args.gcov: - import distutils.sysconfig - cvars = distutils.sysconfig.get_config_vars() - env['OPT'] = '-O0 -ggdb' - env['FOPT'] = '-O0 -ggdb' - env['CC'] = cvars['CC'] + ' --coverage' - env['CXX'] = cvars['CXX'] + ' --coverage' - env['F77'] = 'gfortran --coverage ' - env['F90'] = 'gfortran --coverage ' - env['LDSHARED'] = cvars['LDSHARED'] + ' --coverage' - env['LDFLAGS'] = " ".join(cvars['LDSHARED'].split()[1:]) + ' --coverage' - cmd += ["build"] - - cmd += ['install', '--prefix=' + dst_dir] - - log_filename = os.path.join(ROOT_DIR, 'build.log') - - if args.show_build_log: - ret = subprocess.call(cmd, env=env, cwd=ROOT_DIR) - else: - log_filename = os.path.join(ROOT_DIR, 'build.log') - print("Building, see build.log...") - with open(log_filename, 'w') as log: - p = subprocess.Popen(cmd, env=env, stdout=log, stderr=log, - cwd=ROOT_DIR) - - # Wait for it to finish, and print something to indicate the - # process is alive, but only if the log file has grown (to - # allow continuous integration environments kill a hanging - # process accurately if it produces no output) - last_blip = time.time() - last_log_size = os.stat(log_filename).st_size - while p.poll() is None: - time.sleep(0.5) - if time.time() - last_blip > 60: - log_size = os.stat(log_filename).st_size - if log_size > last_log_size: - print(" ... build in progress") - last_blip = time.time() - last_log_size = log_size - - ret = p.wait() - - if ret == 0: - print("Build OK") - else: - if not args.show_build_log: - with open(log_filename, 'r') as f: - print(f.read()) - print("Build failed!") - sys.exit(1) - - from distutils.sysconfig import get_python_lib - site_dir = get_python_lib(prefix=dst_dir, plat_specific=True) - - return site_dir - - -# -# GCOV support -# -def gcov_reset_counters(): - print("Removing previous GCOV .gcda files...") - build_dir = os.path.join(ROOT_DIR, 'build') - for dirpath, dirnames, filenames in os.walk(build_dir): - for fn in filenames: - if fn.endswith('.gcda') or fn.endswith('.da'): - pth = os.path.join(dirpath, fn) - os.unlink(pth) - -# -# LCOV support -# - -LCOV_OUTPUT_FILE = os.path.join(ROOT_DIR, 'build', 'lcov.out') -LCOV_HTML_DIR = os.path.join(ROOT_DIR, 'build', 'lcov') - -def lcov_generate(): - try: os.unlink(LCOV_OUTPUT_FILE) - except OSError: pass - try: shutil.rmtree(LCOV_HTML_DIR) - except OSError: pass - - print("Capturing lcov info...") - subprocess.call(['lcov', '-q', '-c', - '-d', os.path.join(ROOT_DIR, 'build'), - '-b', ROOT_DIR, - '--output-file', LCOV_OUTPUT_FILE]) - - print("Generating lcov HTML output...") - ret = subprocess.call(['genhtml', '-q', LCOV_OUTPUT_FILE, - '--output-directory', LCOV_HTML_DIR, - '--legend', '--highlight']) - if ret != 0: - print("genhtml failed!") - else: - print("HTML output generated under build/lcov/") - - -# -# Python 3 support -# - -if sys.version_info[0] >= 3: - import builtins - exec_ = getattr(builtins, "exec") -else: - def exec_(code, globs=None, locs=None): - """Execute code in a namespace.""" - if globs is None: - frame = sys._getframe(1) - globs = frame.f_globals - if locs is None: - locs = frame.f_locals - del frame - elif locs is None: - locs = globs - exec("""exec code in globs, locs""") - -if __name__ == "__main__": - main(argv=sys.argv[1:]) From db51c184d30aef921ee8dfe41f22b63f52ebe50a Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 7 Feb 2020 05:35:24 +0100 Subject: [PATCH 097/405] fix SDK dir selection --- .travis.yml | 36 +++++++++++++++--------------------- setup.py | 2 +- 2 files changed, 16 insertions(+), 22 deletions(-) diff --git a/.travis.yml b/.travis.yml index a5091671..42c75687 100644 --- a/.travis.yml +++ b/.travis.yml @@ -21,7 +21,7 @@ jobs: os: osx language: shell env: TEST_PKG="conda" BLA_VENDOR="Apple" - - name: "MacOSX, default Python 3" + - name: "MacOSX, System Python 3" os: osx language: shell env: TEST_PKG="dist" BLA_VENDOR="Apple" @@ -33,20 +33,17 @@ jobs: os: osx language: shell env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 - # additional Linux builds using defaults from above - # only one build per old python version - - name: "Linux, Py2.7" + - name: "Linux, Ubuntu 16.04 Python 2.7" python: "2.7" - env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - name: "Linux, Py3.5" + dist: xenial + env: TEST_PKG="dist" BLA_VENDOR="OpenBLAS" + - name: "Linux, Conda Py3.5" python: "3.5" env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - name: "Linux, Py3.6" + - name: "Linux, Conda Py3.6" python: "3.6" env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - allowed_failures: - - os: osx - env: TEST_PKG="conda" BLA_VENDOR="Apple" + before_install: - | @@ -65,7 +62,7 @@ before_install: fi - | # Install MacOSX packages - if [[ $TEST_PKG == "dist" && $TRAVIS_OS_NAME == osx ]]; then + if [[ $TEST_PKG == "dist" && $TRAVIS_OS_NAME == osx ]]; then if [ -n "$SLYCOT_PYTHON_VERSION" ]; then pyenv install $SLYCOT_PYTHON_VERSION pyenv global $SLYCOT_PYTHON_VERSION @@ -77,25 +74,23 @@ before_install: ln -s $(which pip3) ~/.local/bin/pip fi fi -install: - - if [[ $TRAVIS_OS_NAME == linux ]]; then - export SLYCOT_PYTHON_VERSION="$TRAVIS_PYTHON_VERSION"; - fi +install: - | # compile using conda environment or distribution libraries + echo "Python Version: ${SLYCOT_PYTHON_VERSION:=${TRAVIS_PYTHON_VERSION:-3.8}}" if [[ $TEST_PKG == conda ]]; then # # Install miniconda to allow quicker installation of dependencies # See https://conda.io/projects/conda/en/latest/user-guide/tasks/use-conda-with-travis-ci.html # + pymajor=${SLYCOT_PYTHON_VERSION:0:1} if [[ $TRAVIS_OS_NAME == linux ]]; then - wget http://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh + wget https://repo.continuum.io/miniconda/Miniconda${pymajor}-latest-Linux-x86_64.sh -O miniconda.sh elif [[ $TRAVIS_OS_NAME == osx ]]; then - wget http://repo.continuum.io/miniconda/Miniconda3-latest-MacOSX-x86_64.sh -O miniconda.sh + wget https://repo.continuum.io/miniconda/Miniconda${pymajor}-latest-MacOSX-x86_64.sh -O miniconda.sh wget https://github.com/phracker/MacOSX-SDKs/releases/download/10.15/MacOSX10.9.sdk.tar.xz - sudo mkdir -p /opt/MacOSX10.9.sdk - sudo tar -C /opt/MacOSX10.9.sdk -xJf MacOSX10.9.sdk.tar.xz + sudo tar -C /opt -xJf MacOSX10.9.sdk.tar.xz else echo "Unsupported OS for conda builds: TRAVIS_OS_NAME" exit 4 @@ -141,10 +136,10 @@ install: # coveralls not in ubuntu or conda repos pip install coveralls - script: # slycots own unit tests as installed, not from source dir - cd .. + - python -V # print python version for debugging - slycot_dir=$(python -c "import slycot; print(slycot.__path__[0])") - pytest --pyargs slycot --cov=$slycot_dir --cov-config=Slycot/.coveragerc # @@ -155,6 +150,5 @@ script: - cd control - python setup.py test - after_success: - coveralls diff --git a/setup.py b/setup.py index db53bfd5..9e1e6dfc 100644 --- a/setup.py +++ b/setup.py @@ -25,7 +25,7 @@ from skbuild import setup from skbuild.command.sdist import sdist except ImportError: - raise ImportError('sckit-build must be installed before running setup.py') + raise ImportError('scikit-build must be installed before running setup.py') if sys.version_info[:2] < (2, 7) or (3, 0) <= sys.version_info[0:2] < (3, 5): raise RuntimeError("Python version 2.7 or >= 3.5 required.") From 4ea90b08603fd90da7bf91a82414f599a34e29c4 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 7 Feb 2020 09:12:01 +0100 Subject: [PATCH 098/405] reorganize build matrix --- .travis.yml | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/.travis.yml b/.travis.yml index 42c75687..58774911 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,8 +6,8 @@ services: xvfb # needed for the python-control tests # Start with a 2x4 matrix of Linux builds python: - - "3.7" - "3.8" + - "3.7" env: - TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - TEST_PKG="conda" BLA_VENDOR="Intel10_64lp" # MKL @@ -15,8 +15,19 @@ env: - TEST_PKG="dist" BLA_VENDOR="Generic" # reference BLAS/LAPACK jobs: - # additional single OSX and Linux jobs + # additional single Linux and OSX jobs include: + - name: "Linux, Conda Python 3.6" + python: "3.6" + env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + - name: "Linux, Conda Python 3.5" + python: "3.5" + env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + - name: "Linux, Ubuntu 16.04, System Python 2.7" + python: "2.7" + dist: xenial + env: TEST_PKG="dist" BLA_VENDOR="OpenBLAS" + # (Conda Python 2 is broken due to pytest-cov dependencies) - name: "MacOSX, Conda Python 3" os: osx language: shell @@ -25,24 +36,14 @@ jobs: os: osx language: shell env: TEST_PKG="dist" BLA_VENDOR="Apple" - - name: "MacOSX, pyenv 2.7" + - name: "MacOSX, pyenv 3.8.0" os: osx language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=2.7.17 - - name: "MacOSX, pyenv 3.8" + env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 + - name: "MacOSX, pyenv 2.7.17" os: osx language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 - - name: "Linux, Ubuntu 16.04 Python 2.7" - python: "2.7" - dist: xenial - env: TEST_PKG="dist" BLA_VENDOR="OpenBLAS" - - name: "Linux, Conda Py3.5" - python: "3.5" - env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - name: "Linux, Conda Py3.6" - python: "3.6" - env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" + env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=2.7.17 before_install: @@ -84,15 +85,14 @@ install: # Install miniconda to allow quicker installation of dependencies # See https://conda.io/projects/conda/en/latest/user-guide/tasks/use-conda-with-travis-ci.html # - pymajor=${SLYCOT_PYTHON_VERSION:0:1} if [[ $TRAVIS_OS_NAME == linux ]]; then - wget https://repo.continuum.io/miniconda/Miniconda${pymajor}-latest-Linux-x86_64.sh -O miniconda.sh + wget https://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh elif [[ $TRAVIS_OS_NAME == osx ]]; then - wget https://repo.continuum.io/miniconda/Miniconda${pymajor}-latest-MacOSX-x86_64.sh -O miniconda.sh + wget https://repo.continuum.io/miniconda/Miniconda3-latest-MacOSX-x86_64.sh -O miniconda.sh wget https://github.com/phracker/MacOSX-SDKs/releases/download/10.15/MacOSX10.9.sdk.tar.xz sudo tar -C /opt -xJf MacOSX10.9.sdk.tar.xz else - echo "Unsupported OS for conda builds: TRAVIS_OS_NAME" + echo "Unsupported OS for conda builds: $TRAVIS_OS_NAME" exit 4 fi bash miniconda.sh -b -p $HOME/miniconda @@ -137,9 +137,8 @@ install: pip install coveralls script: - # slycots own unit tests as installed, not from source dir + # slycots own unit tests as installed, not those from source dir - cd .. - - python -V # print python version for debugging - slycot_dir=$(python -c "import slycot; print(slycot.__path__[0])") - pytest --pyargs slycot --cov=$slycot_dir --cov-config=Slycot/.coveragerc # From 4e000955800e20f55610698d1a474b5c41cda7f3 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 7 Feb 2020 10:24:53 +0100 Subject: [PATCH 099/405] install all test files --- slycot/tests/CMakeLists.txt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index c97cb500..7bdd4dc0 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -1,6 +1,14 @@ set(PYSOURCE - __init__.py test.py test_sg02ad.py test_sg03ad.py test_tb05ad.py - test_td04ad.py) + __init__.py + test.py + test_ag08bd.py + test_sb10jd.py + test_sg02ad.py + test_sg03ad.py + test_tb05ad.py + test_td04ad.py + test_tg01ad.py + test_tg01fd.py ) install(FILES ${PYSOURCE} DESTINATION slycot/tests) From 817105e711a0cacc766b4e8b5a780293c49f3c90 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 13:18:28 +0100 Subject: [PATCH 100/405] sg03ad: arange instead of range --- slycot/tests/test_sg03ad.py | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index 7b498d6a..e52172ab 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -18,18 +18,18 @@ class test_sg03ad(unittest.TestCase): def test_sg03ad_a(self): # Example 1 n = 100 - Xref = np.ones((n,n)) + Xref = np.ones((n,n)) U = np.tril(Xref) for t in range(0, 50, 10): - A = 2.0**(-t) - np.eye(n) + np.diag(range(1,n+1)) + U.T - E = np.eye(n) + 2**(-t)*U + A = 2.0**(-t) - np.eye(n) + np.diag(np.arange(1,n+1)) + U.T + E = np.eye(n) + 2.0**(-t)*U Y = A.T.dot(Xref).dot(E) + E.T.dot(Xref).dot(A) Q = np.zeros((n,n)) Z = np.zeros((n,n)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) assert_almost_equal(Xref, X) - + def test_sg03ad_3(self): n = 3 A = np.array([[3.0, 1.0, 1.0], From d10debbd9387356994e5241ba09bdaa0ce7ca5e2 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 14:24:55 +0100 Subject: [PATCH 101/405] remove unused module, clean pep8 warning --- slycot/tests/test_sg03ad.py | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index e52172ab..bc4b0433 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -8,24 +8,25 @@ from slycot import synthesis import numpy as np -from numpy.testing import assert_raises, assert_almost_equal +from numpy.testing import assert_almost_equal # test cases from # http://www.qucosa.de/fileadmin/data/qucosa/documents/4168/data/b002.pdf + class test_sg03ad(unittest.TestCase): def test_sg03ad_a(self): # Example 1 n = 100 - Xref = np.ones((n,n)) + Xref = np.ones((n, n)) U = np.tril(Xref) for t in range(0, 50, 10): - A = 2.0**(-t) - np.eye(n) + np.diag(np.arange(1,n+1)) + U.T + A = 2.0**(-t) - np.eye(n) + np.diag(np.arange(1, n+1)) + U.T E = np.eye(n) + 2.0**(-t)*U Y = A.T.dot(Xref).dot(E) + E.T.dot(Xref).dot(A) - Q = np.zeros((n,n)) - Z = np.zeros((n,n)) + Q = np.zeros((n, n)) + Z = np.zeros((n, n)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) assert_almost_equal(Xref, X) @@ -36,24 +37,21 @@ def test_sg03ad_3(self): [1.0, 3.0, 0.0], [1.0, 0.0, 2.0]]) E = np.array([[1.0, 3.0, 0.0], - [3.0, 2.0, 1.0], - [1.0, 0.0, 1.0]]) + [3.0, 2.0, 1.0], + [1.0, 0.0, 1.0]]) Y = np.array([[64.0, 73.0, 28.0], - [73.0, 70.0, 25.0], - [28.0, 25.0, 18.0]]) + [73.0, 70.0, 25.0], + [28.0, 25.0, 18.0]]) Xref = np.array([[-2.0000, -1.0000, 0.0000], - [-1.0000, -3.0000, -1.0000], - [0.0000, -1.0000, -3.0000]]) - Q = np.zeros((3,3)) - Z = np.zeros((3,3)) + [-1.0000, -3.0000, -1.0000], + [0.0000, -1.0000, -3.0000]]) + Q = np.zeros((3, 3)) + Z = np.zeros((3, 3)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, -Y) - #print(A, E, Q, Z, X, scale, sep) + # print(A, E, Q, Z, X, scale, sep) assert_almost_equal(X, Xref) -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) - if __name__ == "__main__": unittest.main() From 50c9e88c517f81b65b6070a7d8f25ceb85a06168 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 15 Nov 2019 21:05:58 +0100 Subject: [PATCH 102/405] fix sg03ad test for continuos time and add discrete time test --- slycot/tests/test_sg03ad.py | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index bc4b0433..f19ae390 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -16,20 +16,35 @@ class test_sg03ad(unittest.TestCase): - def test_sg03ad_a(self): + def test_sg03ad_1c(self): # Example 1 n = 100 Xref = np.ones((n, n)) U = np.tril(Xref) for t in range(0, 50, 10): - A = 2.0**(-t) - np.eye(n) + np.diag(np.arange(1, n+1)) + U.T - E = np.eye(n) + 2.0**(-t)*U + A = (2**(-t) - 1) * np.eye(n) + np.diag(np.arange(1., n+1.)) + U.T + E = np.eye(n) + 2**(-t) * U Y = A.T.dot(Xref).dot(E) + E.T.dot(Xref).dot(A) Q = np.zeros((n, n)) Z = np.zeros((n, n)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) - assert_almost_equal(Xref, X) + assert_almost_equal(X, Xref) + + def test_sg03ad_1d(self): + # Example 1 + n = 100 + Xref = np.ones((n, n)) + U = np.tril(Xref) + for t in range(0, 50, 10): + A = 2**(-t) * np.eye(n) + np.diag(np.arange(1., n+1.)) + U.T + E = np.eye(n) + 2**(-t) * U + Y = A.T.dot(Xref).dot(A) - E.T.dot(Xref).dot(E) + Q = np.zeros((n, n)) + Z = np.zeros((n, n)) + A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ + synthesis.sg03ad('D', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) + assert_almost_equal(X, Xref) def test_sg03ad_3(self): n = 3 From 9d2bfe39ec2e15d73f432b64c7a9e12e6fb32c01 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 15 Nov 2019 21:15:39 +0100 Subject: [PATCH 103/405] docstrings for sg03ad tests --- slycot/tests/test_sg03ad.py | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index f19ae390..830f3fc3 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -1,6 +1,6 @@ #!/usr/bin/env python # -# test_sg03ad.py - test suit for stability margin commands +# test_sg03ad.py - test suite for stability margin commands # RvP, 15 Jun 2017 from __future__ import print_function @@ -11,13 +11,14 @@ from numpy.testing import assert_almost_equal # test cases from +# Penzl T., Numerical Solution of Generalized Lyapunov Equations # http://www.qucosa.de/fileadmin/data/qucosa/documents/4168/data/b002.pdf class test_sg03ad(unittest.TestCase): - def test_sg03ad_1c(self): - # Example 1 + def test_sg03ad_ex1c(self): + """ Example 1 continuous case""" n = 100 Xref = np.ones((n, n)) U = np.tril(Xref) @@ -31,8 +32,8 @@ def test_sg03ad_1c(self): synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) assert_almost_equal(X, Xref) - def test_sg03ad_1d(self): - # Example 1 + def test_sg03ad_ex1d(self): + """ Example 1 discrete case""" n = 100 Xref = np.ones((n, n)) U = np.tril(Xref) @@ -46,7 +47,8 @@ def test_sg03ad_1d(self): synthesis.sg03ad('D', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) assert_almost_equal(X, Xref) - def test_sg03ad_3(self): + def test_sg03ad_b1(self): + """ SLICOT doc example / Penzl B.1 """ n = 3 A = np.array([[3.0, 1.0, 1.0], [1.0, 3.0, 0.0], From fe24bbb43cb4d0d5faa9825f2579e52aba971b01 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 13:53:40 +0100 Subject: [PATCH 104/405] fix typos, remove obosolete suite function --- slycot/tests/test_td04ad.py | 4 ---- slycot/transform.py | 10 +++++----- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index ab2aa3ee..a1ff94ba 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -146,9 +146,5 @@ def test_tfm2ss_6(self): self.assertEqual(n, 0) np.testing.assert_array_almost_equal(D, np.array([[64]])) -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestTF2SS) - - if __name__ == "__main__": unittest.main() diff --git a/slycot/transform.py b/slycot/transform.py index d492a075..fce15a80 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -288,9 +288,9 @@ def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): Cr : rank-2 array, shape (p,nr) output matri of the controllable subsystem index : rank-1 array, shape (p) - array of orders of the denomenator polynomials + array of orders of the denominator polynomials dcoeff : rank-2 array, shape (p,max(index)+1) - array of denomenator coefficients + array of denominator coefficients ucoeff : rank-3 array, shape (p,m,max(index)+1) array of numerator coefficients @@ -578,7 +578,7 @@ def error_handler(out, arg_list): def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): """ nr,A,B,C,D = td04ad(m,p,index,dcoeff,ucoeff,[tol,ldwork]) - Convert a tranfer function or matrix of transfer functions to + Convert a transfer function or matrix of transfer functions to a minimum state space realization. Required arguments @@ -592,11 +592,11 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): p : integer output dimension index : rank-1 array, shape (p) or (m) - array of orders of the denomenator polynomials. Different + array of orders of the denominator polynomials. Different shapes corresponding to rowcol=='R' and rowcol=='C' respectively. dcoeff : rank-2 array, shape (p,max(index)+1) or (m,max(index)+1) - array of denomenator coefficients. Different shapes + array of denominator coefficients. Different shapes corresponding to rowcol=='R' and rowcol=='C' respectively. ucoeff : rank-3 array, shape (p,m,max(index)+1) or (max(p,m),max(p,m),max(index)+1) array of numerator coefficients. Different shapes From 57bddb4bdff5a532714029b9c6343ff80597ba8f Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 13:58:45 +0100 Subject: [PATCH 105/405] split test td04ad R and C method --- slycot/tests/test_td04ad.py | 100 +++++++++++++++++++++++++++--------- 1 file changed, 75 insertions(+), 25 deletions(-) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index a1ff94ba..91f381fa 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -9,12 +9,11 @@ from slycot import transform import numpy as np -from numpy.testing import assert_raises, assert_almost_equal class TestTf2SS(unittest.TestCase): - def test_td04ad_case1(self): - """td04ad: Convert with both 'C' and 'R' options""" + def test_td04ad_c(self): + """td04ad: Convert with 'C' option""" # for octave: """ @@ -26,40 +25,91 @@ def test_td04ad_case1(self): [1.0, 0.4, 3.0], [ 1.0, 1.0 ]}; """ - # common denominators for the inputs - n = 2 m = 2 p = 3 + d = 3 num = np.array([ - [ [0.0, 0.0, 1.0 ], [ 1.0, 0.0, 0.0 ] ], - [ [3.0, -1.0, 1.0 ], [ 0.0, 1.0, 0.0 ] ], - [ [0.0, 0.0, 1.0], [ 0.0, 2.0, 0.0 ] ] ]) - p, m, d = num.shape + [ [0.0, 0.0, 1.0], [1.0, 0.0, 0.0] ], + [ [3.0, -1.0, 1.0], [0.0, 1.0, 0.0] ], + [ [0.0, 0.0, 1.0], [0.0, 2.0, 0.0] ] ]) + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) numc[:p,:m,:] = num - denc = np.array( [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ] ]) indc = np.array( [ 2, 1 ], dtype=int) - denr = np.array( - [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ], [1.0, 0.0, 0.0] ]) - indr = np.array( - [ 2, 1, 0 ], dtype=int) - - n, A, B, C, D = transform.td04ad('C', 2, 3, indc, denc, numc) + + nref = 3 + Aref = np.array([ [-1, 0, 0], + [ 0, -0.4, -0.3], + [ 0, 10, 0] ]) + Bref = np.array([ [0, -1], + [1, 0], + [0, 0] ]) + Cref = np.array([ [1, 0, 0.1], + [-1, -2.2, -0.8], + [-2, 0, 0.1] ]) + Dref = np.array([ [0, 1], + [3, 0], + [0, 0] ]) + + nr, A, B, C, D = transform.td04ad('C', m, p, indc, denc, numc) #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) - Ac = [ [-1, 0, 0], [ 0, -0.4, -0.3], [ 0, 10, 0]] - Bc = [ [0, -1] ,[ 1 , 0], [ 0, 0]] - Cc = [ [1, 0, 0.1], [-1, -2.2, -0.8], [ -2, 0, 0.1] ] - Dc = [ [0, 1], [ 3, 0], [ 0, 0]] - np.testing.assert_array_almost_equal(A, Ac) - np.testing.assert_array_almost_equal(B, Bc) - np.testing.assert_array_almost_equal(C, Cc) - np.testing.assert_array_almost_equal(D, Dc) + np.testing.assert_equal(nref, nr) + # the returned state space representation is not guaranteed to + # be of one form for all architectures, so we transform back + # to tf and check for equality then + _, _, _, _, _, dcoeff, ucoeff = transform.tb04ad( + nr, m, p, A, B, C, D) + _, _, _, _, _, dcoeffref, ucoeffref = transform.tb04ad( + nref, m, p, Aref, Bref, Cref, Dref) + np.testing.assert_array_almost_equal(dcoeff,dcoeffref) + np.testing.assert_array_almost_equal(ucoeff,ucoeffref) + - resr = transform.td04ad('R', 2, 3, indr, denr, num) + def test_td04ad_r(self): + """td04ad: Convert with 'R' option""" + + """ example program from + http://slicot.org/objects/software/shared/doc/TD04AD.html""" + + m = 2 + p = 2 + rowcol = 'R' + index = [3, 3] + dcoeff = np.array([ [1.0, 6.0, 11.0, 6.0], [1.0, 6.0, 11.0, 6.0] ]) + + ucoeff = np.array([ [[1.0, 6.0, 12.0, 7.0], [0.0, 1.0, 4.0, 3.0]], + [[0.0, 0.0, 1.0, 1.0], [1.0, 8.0, 20.0, 15.0]] ]) + + nref = 3 + + Aref = np.array([ [ 0.5000, -0.8028, 0.9387], + [ 4.4047, -2.3380, 2.5076], + [-5.5541, 1.6872, -4.1620] ]) + Bref = np.array([ [-0.2000, -1.2500], + [ 0.0000, -0.6097], + [ 0.0000, 2.2217] ]) + Cref = np.array([ [0.0000, -0.8679, 0.2119], + [0.0000, 0.0000, 0.9002] ]) + Dref = np.array([ [1.0000, 0.0000], + [0.0000, 1.0000] ]) + + nr, A, B, C, D = transform.td04ad(rowcol, m, p, index, dcoeff, ucoeff) #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + np.testing.assert_equal(nref, nr) + # order of states is not guaranteed, so we reorder the reference + rindex = np.flip(np.argsort(np.diag(A))) + Arref = Aref[rindex, :][:, rindex] + Brref = Bref[rindex, :] + Crref = Cref[:, rindex] + Drref = Dref + np.testing.assert_array_almost_equal(A, Arref,decimal=4) + np.testing.assert_array_almost_equal(B, Brref,decimal=4) + np.testing.assert_array_almost_equal(C, Crref,decimal=4) + np.testing.assert_array_almost_equal(D, Drref,decimal=4) + def test_staticgain(self): """td04ad: Convert a transferfunction to SS with only static gain""" From ef3f2c849070359119f58131599e4fd686b01503 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 13:59:47 +0100 Subject: [PATCH 106/405] correct API call line for td04ad --- slycot/transform.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/transform.py b/slycot/transform.py index fce15a80..b9a72fa3 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -576,7 +576,7 @@ def error_handler(out, arg_list): def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): - """ nr,A,B,C,D = td04ad(m,p,index,dcoeff,ucoeff,[tol,ldwork]) + """ nr,A,B,C,D = td04ad(rowcol,m,p,index,dcoeff,ucoeff,[tol,ldwork]) Convert a transfer function or matrix of transfer functions to a minimum state space realization. From 1cc11a484a83d3484b02db4022e671d068eb4552 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 14:01:59 +0100 Subject: [PATCH 107/405] move td04ad static test --- slycot/tests/test.py | 14 -------------- slycot/tests/test_td04ad.py | 27 +++++++++++++++++++++++++-- 2 files changed, 25 insertions(+), 16 deletions(-) diff --git a/slycot/tests/test.py b/slycot/tests/test.py index 19f7dfc8..c12d8689 100644 --- a/slycot/tests/test.py +++ b/slycot/tests/test.py @@ -43,20 +43,6 @@ def test_sb02ad(self): self.assertAlmostEqual(Ac[1][0], 1) self.assertAlmostEqual(Ac[1][1], -3) - def test_td04ad_static(self): - """Regression: td04ad (TFM -> SS transformation) for static TFM""" - import numpy as np - from itertools import product - # 'C' fails on static TFs - for nout,nin,rc in product(range(1,6),range(1,6),['R']): - num = np.reshape(np.arange(nout*nin),(nout,nin,1)) - if rc == 'R': - den = np.reshape(np.arange(1,1+nout),(nout,1)) - else: - den = np.reshape(np.arange(1,1+nin),(nin,1)) - index = np.tile([0],den.shape[0]) - nr,a,b,c,d = transform.td04ad(rc,nin,nout,index,den,num) - if __name__ == "__main__": unittest.main() diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index 91f381fa..2019ec09 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -3,7 +3,7 @@ # test_td04ad.py - test suite for tf -> ss conversion # RvP, 04 Jun 2018 -from __future__ import print_function +from __future__ import print_function, division import unittest from slycot import transform @@ -148,7 +148,30 @@ def test_staticgain(self): self.assertEqual(B.shape, (0,2)) self.assertEqual(C.shape, (3,0)) np.testing.assert_array_almost_equal(D, Dr) - + + def test_td04ad_static(self): + """Regression: td04ad (TFM -> SS transformation) for static TFM""" + from itertools import product + for nout, nin, rc in product(range(1, 6), range(1, 6), ['R', 'C']): + Dref = np.zeros((nout, nin)) + if rc == 'R': + num = np.reshape(np.arange(nout * nin), (nout, nin, 1)) + den = np.reshape(np.arange(1, 1 + nout), (nout, 1)) + Dref = num[:nout, :nin, 0] / np.broadcast_to(den, (nout, nin)) + else: + maxn = max(nout, nin) + num = np.zeros((maxn, maxn, 1)) + num[:nout, :nin, 0] = np.reshape( + np.arange(nout * nin), (nout, nin)) + den = np.reshape(np.arange(1, 1 + nin), (nin, 1)) + Dref = num[:nout, :nin, 0] / np.broadcast_to(den.T, (nout, nin)) + index = np.tile([0], den.shape[0]) + nr, A, B, C, D = transform.td04ad(rc, nin, nout, index, den, num) + np.testing.assert_equal(nr, 0) + for M in [A, B, C]: + np.testing.assert_equal(M, np.zeros_like(M)) + np.testing.assert_almost_equal(D, Dref) + def test_mixfeedthrough(self): """Test case popping up from control testing""" From 2cf690263a17df21e953956fe800a1740465cfd2 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 14:04:30 +0100 Subject: [PATCH 108/405] replace np.tile with np.repeat wihtout calling np.shape this fixes a fail of the test on powerpc architecture --- slycot/tests/test_td04ad.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index 2019ec09..94a89642 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -157,6 +157,7 @@ def test_td04ad_static(self): if rc == 'R': num = np.reshape(np.arange(nout * nin), (nout, nin, 1)) den = np.reshape(np.arange(1, 1 + nout), (nout, 1)) + index = np.repeat(0, nout) Dref = num[:nout, :nin, 0] / np.broadcast_to(den, (nout, nin)) else: maxn = max(nout, nin) @@ -164,8 +165,8 @@ def test_td04ad_static(self): num[:nout, :nin, 0] = np.reshape( np.arange(nout * nin), (nout, nin)) den = np.reshape(np.arange(1, 1 + nin), (nin, 1)) + index = np.repeat(0, nin) Dref = num[:nout, :nin, 0] / np.broadcast_to(den.T, (nout, nin)) - index = np.tile([0], den.shape[0]) nr, A, B, C, D = transform.td04ad(rc, nin, nout, index, den, num) np.testing.assert_equal(nr, 0) for M in [A, B, C]: From 196e4ec6a5b77e612f8d2ee7082fe1e27a0dfb25 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 8 Nov 2019 14:09:14 +0100 Subject: [PATCH 109/405] whitespace fixes --- slycot/tests/test_td04ad.py | 50 ++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index 94a89642..e442a967 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -14,7 +14,7 @@ class TestTf2SS(unittest.TestCase): def test_td04ad_c(self): """td04ad: Convert with 'C' option""" - + # for octave: """ num = { [0.0, 0.0, 1.0 ], [ 1.0, 0.0 ]; @@ -24,28 +24,28 @@ def test_td04ad_c(self): [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; [1.0, 0.4, 3.0], [ 1.0, 1.0 ]}; """ - + m = 2 p = 3 - d = 3 + d = 3 num = np.array([ [ [0.0, 0.0, 1.0], [1.0, 0.0, 0.0] ], [ [3.0, -1.0, 1.0], [0.0, 1.0, 0.0] ], [ [0.0, 0.0, 1.0], [0.0, 2.0, 0.0] ] ]) - + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) numc[:p,:m,:] = num denc = np.array( [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ] ]) indc = np.array( [ 2, 1 ], dtype=int) - + nref = 3 Aref = np.array([ [-1, 0, 0], [ 0, -0.4, -0.3], [ 0, 10, 0] ]) Bref = np.array([ [0, -1], - [1, 0], + [1, 0], [0, 0] ]) Cref = np.array([ [1, 0, 0.1], [-1, -2.2, -0.8], @@ -53,7 +53,7 @@ def test_td04ad_c(self): Dref = np.array([ [0, 1], [3, 0], [0, 0] ]) - + nr, A, B, C, D = transform.td04ad('C', m, p, indc, denc, numc) #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) np.testing.assert_equal(nref, nr) @@ -70,19 +70,19 @@ def test_td04ad_c(self): def test_td04ad_r(self): """td04ad: Convert with 'R' option""" - + """ example program from http://slicot.org/objects/software/shared/doc/TD04AD.html""" - + m = 2 p = 2 rowcol = 'R' index = [3, 3] dcoeff = np.array([ [1.0, 6.0, 11.0, 6.0], [1.0, 6.0, 11.0, 6.0] ]) - + ucoeff = np.array([ [[1.0, 6.0, 12.0, 7.0], [0.0, 1.0, 4.0, 3.0]], - [[0.0, 0.0, 1.0, 1.0], [1.0, 8.0, 20.0, 15.0]] ]) - + [[0.0, 0.0, 1.0, 1.0], [1.0, 8.0, 20.0, 15.0]] ]) + nref = 3 Aref = np.array([ [ 0.5000, -0.8028, 0.9387], @@ -90,30 +90,30 @@ def test_td04ad_r(self): [-5.5541, 1.6872, -4.1620] ]) Bref = np.array([ [-0.2000, -1.2500], [ 0.0000, -0.6097], - [ 0.0000, 2.2217] ]) + [ 0.0000, 2.2217] ]) Cref = np.array([ [0.0000, -0.8679, 0.2119], [0.0000, 0.0000, 0.9002] ]) Dref = np.array([ [1.0000, 0.0000], [0.0000, 1.0000] ]) - + nr, A, B, C, D = transform.td04ad(rowcol, m, p, index, dcoeff, ucoeff) #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) np.testing.assert_equal(nref, nr) # order of states is not guaranteed, so we reorder the reference rindex = np.flip(np.argsort(np.diag(A))) Arref = Aref[rindex, :][:, rindex] - Brref = Bref[rindex, :] - Crref = Cref[:, rindex] + Brref = Bref[rindex, :] + Crref = Cref[:, rindex] Drref = Dref np.testing.assert_array_almost_equal(A, Arref,decimal=4) np.testing.assert_array_almost_equal(B, Brref,decimal=4) np.testing.assert_array_almost_equal(C, Crref,decimal=4) - np.testing.assert_array_almost_equal(D, Drref,decimal=4) + np.testing.assert_array_almost_equal(D, Drref,decimal=4) def test_staticgain(self): """td04ad: Convert a transferfunction to SS with only static gain""" - + # 2 inputs, 3 outputs? columns share a denominator num = np.array([ [ [1.0], [2.0] ], [ [0.2], [4.3] ], @@ -121,12 +121,12 @@ def test_staticgain(self): p, m, d = num.shape numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) numc[:p,:m,:] = num - + # denc, columns share a common denominator denc = np.array([ [ 1.0], [0.5] ]) Dc = (num / denc).reshape((3,2)) idxc = np.zeros((2,), dtype=int) - + # denr, rows share a common denominator denr = np.array([ [1.0], [0.5], [3.0] ]) idxr = np.zeros((3,), dtype=int) @@ -134,14 +134,14 @@ def test_staticgain(self): # fails with: # On entry to TB01XD parameter number 5 had an illegal value - + n, A, B, C, D = transform.td04ad('C', 2, 3, idxc, denc, numc) #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) self.assertEqual(A.shape, (0,0)) self.assertEqual(B.shape, (0,2)) self.assertEqual(C.shape, (3,0)) np.testing.assert_array_almost_equal(D, Dc) - + n, A, B, C, D = transform.td04ad('R', 2, 3, idxr, denr, num) #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) self.assertEqual(A.shape, (0,0)) @@ -187,7 +187,7 @@ def test_mixfeedthrough(self): idxc = np.array([ 1, 0 ]) n, A, B, C, D = transform.td04ad('C', 2, 2, idxc, denc, numc) np.testing.assert_array_almost_equal(D, np.array([[0, 0],[-0.1, 0]])) - + def test_toandfrom(self): A = np.array([[-3.0]]) @@ -205,7 +205,7 @@ def test_toandfrom(self): np.testing.assert_array_almost_equal(A, At) def test_tfm2ss_6(self): - """Python version of Fortran test program from + """Python version of Fortran test program from -- Bug in TD04AD when ROWCOL='C' #6 This bug was fixed in PR #27""" m = 1 @@ -219,6 +219,6 @@ def test_tfm2ss_6(self): n, A, B, C, D = transform.td04ad('C', m, p, index, dcoeff, ucoeff) self.assertEqual(n, 0) np.testing.assert_array_almost_equal(D, np.array([[64]])) - + if __name__ == "__main__": unittest.main() From b8f3dcac2a5774ab73b7ca7f89fde07896fd98eb Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Fri, 15 Nov 2019 09:59:08 +0100 Subject: [PATCH 110/405] fix python-control#347: missing exception attribute --- slycot/synthesis.py | 46 ++++++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 17 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index f80c22c5..41fc003e 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -489,16 +489,22 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): if fact == 'N': out = _wrapper.sb02mt_n(n,m,B,R,uplo=uplo,ldwork=ldwork) if out is None: - raise ValueError('fact must be either C or N.') + e = ValueError('fact must be either C or N.') + e.info = -3 + raise e else: if A is None or Q is None or L is None: - raise ValueError('matrices A,Q and L are required if jobl is not Z.') + e = ValueError('matrices A,Q and L are required if jobl is not Z.') + e.info = -7 + raise e if fact == 'C': out = _wrapper.sb02mt_cl(n,m,A,B,Q,R,L,uplo=uplo) if fact == 'N': out = _wrapper.sb02mt_nl(n,m,A,B,Q,R,L,uplo=uplo,ldwork=ldwork) if out is None: - raise ValueError('fact must be either C or N.') + e = ValueError('fact must be either C or N.') + e.info = -3 + raise e if out[-1] < 0: error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] e = ValueError(error_text) @@ -850,7 +856,9 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): if ldwork is None: ldwork = max(2*n*n,3*n) if dico != 'C' and dico != 'D': - raise ValueError('dico must be either D or C') + e = ValueError('dico must be either D or C') + e.info = -1 + raise e out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) if out[-1] < 0: error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] @@ -1041,7 +1049,9 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): elif m == 0: ldwork = 1 if dico != 'C' and dico != 'D': - raise ValueError('dico must be either D or C') + e = ValueError('dico must be either D or C') + e.info = -1 + raise e out = _wrapper.sb03od(dico,n,m,A,Q,B,fact=fact,trans=trans,ldwork=ldwork) if out[-1] < 0: error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] @@ -1658,7 +1668,7 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): LW4 = 13*n*n + m*m + (8*n+m+m2+2*np2)*(m2+np2) + 6*n + n*(m+np2) + max(14*n+23,16*n,2*n+m2+np2,3*(m2+np2)) ldwork = max(LW1,LW2,LW3,LW4) out = _wrapper.sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol,ldwork) - + if out[-1] != 0: if out[-1] < 0: error_text = "The following argument had an illegal value: "\ @@ -1837,25 +1847,25 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): raise e return out[:-1] - + def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): """ A,B,C,D = sb10jd(n,m,np,A,B,C,D,E,[ldwork]) - + To convert the descriptor state-space system - + E*dx/dt = A*x + B*u y = C*x + D*u - + into regular state-space form - + dx/dt = Ad*x + Bd*u y = Cd*x + Dd*u . - + Required arguments: n : input int The order of the descriptor system. n >= 0. m : input int - The column size of the matrix B. m >= 0. + The column size of the matrix B. m >= 0. np : input int The row size of the matrix C. np >= 0. A : rank-2 array('d') with bounds (n,n) @@ -1890,7 +1900,7 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): contains the output matrix Cd of the converted system. D : rank-2 array('d') with bounds (np,m) The leading NP-by-M part of this array contains - the matrix Dd of the converted system. + the matrix Dd of the converted system. """ hidden = ' (hidden by the wrapper)' @@ -1900,7 +1910,7 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): ldwork = max(1, 2 * n * n + 2 * n + n * max(5, n + m + np)) A,B,C,D,nsys,info = _wrapper.sb10jd(n,m,np,A,B,C,D,E,ldwork) - + if info < 0: error_text = "The following argument had an illegal value: "+arg_list[-info-1] e = ValueError(error_text) @@ -2694,7 +2704,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): Return objects ______________ - + U : rank-2 array('d'), shape (n,n) The leading n-by-b part of this array contains the Cholesky factor U of the solution matrix X of the @@ -2746,7 +2756,9 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): if ldwork is None: ldwork = max(1,4*n,6*n-6) if dico != 'C' and dico != 'D': - raise ValueError('dico must be either D or C') + e = ValueError('dico must be either D or C') + e.info = -1 + raise e out = _wrapper.sg03bd(dico,n,m,A,E,Q,Z,B,fact=fact,trans=trans,ldwork=ldwork) if out[-1] < 0: error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] From 3062de55a16fe40a8d856439f8208cd9aad7af0a Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 26 Jan 2020 12:35:38 +0100 Subject: [PATCH 111/405] sg03ad N is not hidden --- slycot/synthesis.py | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 41fc003e..8526398e 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1984,6 +1984,8 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): = 'L': Only the lower triangle is needed on input; = 'U': Only the upper triangle is needed on input. + N : The order of the matrix A. N >= 0. + A : input rank-2 array('d') with bounds (n,n) On entry, if FACT = 'F', then the leading N-by-N upper Hessenberg part of this array must contain the @@ -2143,7 +2145,7 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'job', 'fact', 'trans', 'uplo', 'N'+hidden, 'A', 'LDA'+hidden, 'E', + arg_list = ['dico', 'job', 'fact', 'trans', 'uplo', 'N', 'A', 'LDA'+hidden, 'E', 'LDE'+hidden, 'Q', 'LDQ'+hidden, 'Z', 'LDZ'+hidden, 'X', 'LDX'+hidden, 'scale', 'sep', 'ferr', 'alphar', 'alphai', 'beta', 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'info' ] From 32761ea3f15e6a2c433db5dfdf7e93a862707704 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 26 Jan 2020 22:03:06 +0100 Subject: [PATCH 112/405] add schur decomposition wrappers --- CMakeLists.txt | 1 + slycot/__init__.py | 2 +- slycot/math.py | 357 ++++++++++++++++++++++++++++++++- slycot/src/math.pyf | 54 +++++ slycot/tests/CMakeLists.txt | 1 + slycot/tests/test_mb03schur.py | 156 ++++++++++++++ 6 files changed, 569 insertions(+), 2 deletions(-) create mode 100644 slycot/tests/test_mb03schur.py diff --git a/CMakeLists.txt b/CMakeLists.txt index a1038751..be2c0718 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -19,6 +19,7 @@ endif() enable_language(C) enable_language(Fortran) + find_package(PythonLibs REQUIRED) find_package(NumPy REQUIRED) find_package(BLAS REQUIRED) diff --git a/slycot/__init__.py b/slycot/__init__.py index ca429748..22461b62 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -23,7 +23,7 @@ # Identification routines (0/5 wrapped) # Mathematical routines (3/81 wrapped) - from .math import mc01td, mb05md, mb05nd + from .math import mc01td, mb03vd, mb03vy, mb03wd, mb05md, mb05nd # Synthesis routines (14/50 wrapped) from .synthesis import sb01bd,sb02md,sb02mt,sb02od,sb03md,sb03od diff --git a/slycot/math.py b/slycot/math.py index 8ad0b020..5bf2f927 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -70,6 +70,361 @@ def mc01td(dico,dp,p): return out[:-2] +def mb03vd(n, ilo, ihi, A): + """ HQ, Tau = mb03vd(n, ilo, ihi, A) + + To reduce a product of p real general matrices A = A_1*A_2*...*A_p + to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is + upper Hessenberg, and H_2, ..., H_p are upper triangular, by using + orthogonal similarity transformations on A, + + Q_1' * A_1 * Q_2 = H_1, + Q_2' * A_2 * Q_3 = H_2, + ... + Q_p' * A_p * Q_1 = H_p. + + Parameters + ---------- + + n : int + The order of the square matrices A_1, A_2, ..., A_p. + n >= 0. + + ilo, ihi : int + It is assumed that all matrices A_j, j = 2, ..., p, are + already upper triangular in rows and columns [:ilo] and + [ihi:n], and A_1 is upper Hessenberg in rows and columns + [:ilo] and [ihi:n], with A_1[ilo-1,ilo] = 0 (unless + ilo = 1), and A_1[ihi,ihi-1] = 0 (unless ihi = n). + If this is not the case, ilo and ihi should be set to 1 + and n, respectively. + 1 <= ilo <= max(1,n); min(ilo,n) <= ihi <= n. + + A : ndarray + A[:n,:n,:p] must contain the matrices of factors to be reduced; + specifically, A[:,:,j-1] must contain A_j, j = 1, ..., p. + + + Returns + ------- + + HQ : ndarray + The upper triangle and the first + subdiagonal of HQ[:n,:n,0] contain the upper Hessenberg + matrix H_1, and the elements below the first subdiagonal, + with the first column of the array Tau represent the + orthogonal matrix Q_1 as a product of elementary + reflectors. See FURTHER COMMENTS. + For j > 1, the upper triangle of HQ[:n,_n,j-1] + contains the upper triangular matrix H_j, and the elements + below the diagonal, with the j-th column of the array TAU + represent the orthogonal matrix Q_j as a product of + elementary reflectors. See FURTHER COMMENTS. + + Tau : ndarray + The leading n-1 elements in the j-th column contain the + scalar factors of the elementary reflectors used to form + the matrix Q_j, j = 1, ..., p. See FURTHER COMMENTS. + + Raises + ------ + + ValueError : e + e.info contains information about the exact type of exception + + Further Comments + ---------------- + + Each matrix Q_j is represented as a product of (ihi-ilo) + elementary reflectors, + + Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). + + Each H_j(i), i = ilo, ..., ihi-1, has the form + + H_j(i) = I - tau_j * v_j * v_j', + + where tau_j is a real scalar, and v_j is a real vector with + v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi) + is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j). + + The contents of A_1 are illustrated by the following example + for n = 7, ilo = 2, and ihi = 6: + + on entry on exit + + ( a a a a a a a ) ( a h h h h h a ) + ( 0 a a a a a a ) ( 0 h h h h h a ) + ( 0 a a a a a a ) ( 0 h h h h h h ) + ( 0 a a a a a a ) ( 0 v2 h h h h h ) + ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) + ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) + ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) + + where a denotes an element of the original matrix A_1, h denotes + a modified element of the upper Hessenberg matrix H_1, and vi + denotes an element of the vector defining H_1(i). + + The contents of A_j, j > 1, are illustrated by the following + example for n = 7, ilo = 2, and ihi = 6: + + on entry on exit + + ( a a a a a a a ) ( a h h h h h a ) + ( 0 a a a a a a ) ( 0 h h h h h h ) + ( 0 a a a a a a ) ( 0 v2 h h h h h ) + ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) + ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) + ( 0 a a a a a a ) ( 0 v2 v3 v4 v5 h h ) + ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) + + where a denotes an element of the original matrix A_j, h denotes + a modified element of the upper triangular matrix H_j, and vi + denotes an element of the vector defining H_j(i). (The element + (1,2) in A_p is also unchanged for this example.) + + Note that for P = 1, the LAPACK Library routine DGEHRD could be + more efficient on some computer architectures than this routine + (a BLAS 2 version). + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['n', 'p' + hidden, + 'ilo', 'ihi', 'a', + 'lda1' + hidden, 'lda2' + hidden, 'tau', + 'ldtau' + hidden, 'dwork' + hidden, 'info'] + + HQ, Tau, info = _wrapper.mb03vd(n, ilo, ihi, A) + + if info != 0: + e = ValueError( + "Argument '{}' had an illegal value".format(arg_list[-info-1])) + e.info = info + raise e + return (HQ, Tau) + + +def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): + """ Q = mb03vy(n, ilo, ihi, A, Tau, [ldwork]) + + To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p, + which are defined as the product of ihi-ilo elementary reflectors + of order n, as returned by SLICOT Library routine MB03VD: + + Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). + + Parameters + ---------- + + n : int + The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. + + ilo, ihi : int + The values of the indices ilo and ihi, respectively, used + in the previous call of the SLICOT Library routine MB03VD. + 1 <= ilo <= max(1,n); min(ilo,n) <= ihi <= n. + + A : ndarray + A[:n,:n,j-1] must contain the vectors which define the + elementary reflectors used for reducing A_j, as returned + by SLICOT Library routine MB03VD, j = 1, ..., p. + + Tau : ndarray + The leading N-1 elements in the j-th column must contain + the scalar factors of the elementary reflectors used to + form the matrix Q_j, as returned by SLICOT Library routine + MB03VD. + + ldwork : int, optional + The length of the array DWORK. LDWORK >= MAX(1,N). + For optimum performance LDWORK should be larger. + + + Returns + ------- + + Q : ndarray + Q[:n,:n,j-1] contains the + N-by-N orthogonal matrix Q_j, j = 1, ..., p. + + Raises + ------ + + ValueError : + e.info contains the number of the argument that was invalid + + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['n', 'p' + hidden, + 'ilo', 'ihi', 'a', + 'lda1' + hidden, 'lda2' + hidden, 'tau', + 'ldtau' + hidden, 'dwork' + hidden, 'info'] + + if not ldwork: + ldwork = max(1, 2 * n) + + Q, info = _wrapper.mb03vy(n, ilo, ihi, A, Tau, ldwork) + + if info != 0: + e = ValueError( + "Argument '{}' had an illegal value".format(arg_list[-info-1])) + e.info = info + raise e + + return Q + + +def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): + """ T, Z, Wr = mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, [ldwork]) + + To compute the Schur decomposition and the eigenvalues of a + product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper + Hessenberg matrix and H_2, ..., H_p upper triangular matrices, + without evaluating the product. Specifically, the matrices Z_i + are computed, such that + + Z_1' * H_1 * Z_2 = T_1, + Z_2' * H_2 * Z_3 = T_2, + ... + Z_p' * H_p * Z_1 = T_p, + + where T_1 is in real Schur form, and T_2, ..., T_p are upper + triangular. + + The routine works primarily with the Hessenberg and triangular + submatrices in rows and columns ilo to ihi, but optionally applies + the transformations to all the rows and columns of the matrices + H_i, i = 1,...,p. The transformations can be optionally + accumulated. + + Parameters + ---------- + + job : {'E', 'S'} + Indicates whether the user wishes to compute the full + Schur form or the eigenvalues only, as follows: + = 'E': Compute the eigenvalues only; + = 'S': Compute the factors T_1, ..., T_p of the full + Schur form, T = T_1*T_2*...*T_p. + + compz : {'N', 'I', 'V'} + Indicates whether or not the user wishes to accumulate + the matrices Z_1, ..., Z_p, as follows: + = 'N': The matrices Z_1, ..., Z_p are not required; + = 'I': Z_i is initialized to the unit matrix and the + orthogonal transformation matrix Z_i is returned, + i = 1, ..., p; + = 'V': Z_i must contain an orthogonal matrix Q_i on + entry, and the product Q_i*Z_i is returned, + i = 1, ..., p. + + n : int + The order of the matrix H. n >= 0 + + ilo, ihi : int + It is assumed that all matrices H_j, j = 2, ..., p, are + already upper triangular in rows and columns [:ilo] and + [ihi+1:n], and H_1 is upper quasi-triangular in rows and + columns [:ilo] and [ihi+1:n], with H_1[ilo-1,ilo] = 0 + (unless ilo = 1), and H_1[ihi,ihi-1] = 0 (unless ihi = n). + The routine works primarily with the Hessenberg submatrix + in rows and columns ilo to ihi, but applies the + transformations to all the rows and columns of the + matrices H_i, i = 1,...,p, if JOB = 'S'. + 1 <= ilo <= max(1,n); min(ilo,n) <= ihi <= n. + + iloz, ihiz : int + Specify the rows of Z to which the transformations must be + applied if compz = 'I' or compz = 'V'. + 1 <= iloz <= ilo; ihi <= ihiz <= n. + + H : ndarray + H[:n,:n,0] must contain the upper Hessenberg matrix H_1 and + H[:n,:n,j-1] for j > 1 must contain the upper triangular matrix + H_j, j = 2, ..., p. + + Q : ndarray + If compz = 'V', Q[:n,:n,:p] must contain the current matrix Q of + transformations accumulated by SLICOT Library routine + MB03VY. + If compz = 'I', Q is ignored + + ldwork : int, optinal + The length of the cache array. The default value is + ihi-ilo+p-1 + + + + Returns + ------- + + T : ndarray + If JOB = 'S', T[:n,:n,0] s upper quasi-triangular in rows + and columns [ilo-1:ihi], with any 2-by-2 diagonal blocks + corresponding to a pair of complex conjugated eigenvalues, and + T[:n,:n,j-1] for j > 1 contains the resulting upper + triangular matrix T_j. + If job = 'E', T is None + + Z : ndarray + If compz = 'V', or compz = 'I', the leading + N-by-N-by-P part of this array contains the transformation + matrices which produced the Schur form; the + transformations are applied only to the submatrices + Z[iloz-1:ihiz,ilo-1:ihi,j-1], j = 1, ..., P. + If compz = 'N', Z is None + + + W : ndarray (dtype=complex) + The computed eigenvalues ilo to ihi. If two eigenvalues + are computed as a complex conjugate pair, they are stored + in consecutive elements of Wr say the i-th and + (i+1)th, with imag(W][i]) > 0 and imag(W[i+1]) < 0. + If JOB = 'S', the eigenvalues are stored in the same order + as on the diagonal of the Schur form returned in H. + + Raises + ------ + + ValueError : e + e.info contains information about the exact type of exception + + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['job', 'compz', 'n', 'p' + hidden, + 'ilo', 'ihi', 'iloz', 'ihiz', + 'h', 'ldh1' + hidden, 'ldh2' + hidden, + 'z', 'ldz1' + hidden, 'ldz2' + hidden, + 'wr', 'wi', + 'dwork' + hidden, 'ldwork', 'info' + hidden] + + if not ldwork: + p = H.shape[2] + ldwork = max(1, ihi - ilo + p - 1) + + T, Z, Wr, Wi, info = _wrapper.mb03wd( + job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) + + if info < 0: + e = ValueError( + "Argument '{}' had an illegal value".format(arg_list[-info-1])) + e.info = info + raise e + elif info > 0: + warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " + "in a total of 30*({ihi}-{ilo}+1) iterations " + "the elements {i}:{ihi} of Wr contain those " + "eigenvalues which have been successfully computed." + ).format(i=info, ilo=ilo, ihi=ihi)) + if job == 'E': + T = None + if compz == 'N': + Z = None + + W = Wr + Wi*1J + return (T, Z, W) + + def mb05md(a, delta, balanc='N'): """Ar, Vr, Yr, VAL = mb05md(a, delta, balanc='N') @@ -166,7 +521,7 @@ def mb05md(a, delta, balanc='N'): from slycot import mb05nd import numpy as np a = np.mat('[-2. 0; 0.1 -3.]') -mb05nd(a.shape[0], a, 0.1) +mb05nd(a.shape[0], a, 0.1) """ def mb05nd(a, delta, tol=1e-7): diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index 101e20e2..ccedae1d 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -12,6 +12,57 @@ subroutine mc01td(dico,dp,p,stable,nz,dwork,iwarn,info) ! in :new:MC01TD.f integer intent(out) :: info end subroutine mc01td +subroutine mb03vd(n,p,ilo,ihi,a,lda1,lda2,tau,ldtau,dwork,info) ! in MB03VD.f + integer intent(in),check(n>=0) :: n + integer intent(hide),depend(a),check(p>=1) :: p=shape(a,2) + integer intent(in),depend(n),check(1<=ilo && ilo<=max(1,n)) :: ilo + integer intent(in),depend(n,ilo),check(min(ilo,n)<=ihi && ihi<=n) :: ihi + double precision intent(in,out,copy),dimension(lda1,lda2,p) :: a + integer intent(hide),depend(a,n),check(lda1>=max(1,n)) :: lda1=shape(a,0) + integer intent(hide),depend(a,n),check(lda2>=max(1,n)) :: lda2=shape(a,1) + double precision intent(out),depend(n),dimension(max(1,n-1),p) :: tau + integer intent(hide),depend(tau) :: ldtau=shape(tau,0) + double precision intent(hide,cache),dimension(n) :: dwork + integer intent(out) :: info +end subroutine mb03vd + +subroutine mb03vy(n,p,ilo,ihi,a,lda1,lda2,tau,ldtau,dwork,ldwork,info) ! in MB03VY.f + integer intent(in),check(n>=0) :: n + integer intent(hide),depend(a),check(p>=1) :: p=shape(a,2) + integer intent(in),depend(n),check(1<=ilo && ilo<=max(1,n)) :: ilo + integer intent(in),depend(n,ilo),check(min(ilo,n)<=ihi && ihi<=n) :: ihi + double precision intent(in,out,copy),dimension(lda1,lda2,p) :: a + integer intent(hide),depend(a,n),check(lda1>=max(1,n)) :: lda1=shape(a,0) + integer intent(hide),depend(a,n),check(lda2>=max(1,n)) :: lda2=shape(a,1) + double precision intent(in),depend(n),dimension(ldtau,p) :: tau + integer intent(hide),depend(tau),check(ldtau>=max(1,n-1)) :: ldtau=shape(tau,0) + double precision intent(hide,cache),dimension(n) :: dwork + integer intent(in),optional,check(ldwork>=max(1,n)) :: ldwork=max(1,n) + integer intent(out) :: info +end subroutine mb03vy + +subroutine mb03wd(job,compz,n,p,ilo,ihi,iloz,ihiz,h,ldh1,ldh2,z,ldz1,ldz2,wr,wi,dwork,ldwork,info) ! in MB03WD.f + character intent(in) :: job + character intent(in) :: compz + integer intent(in),check(n>=0) :: n + integer intent(hide),depend(h),check(p>=1) :: p=shape(h,2) + integer intent(in),depend(n),check(1<=ilo && ilo<=max(1,n)) :: ilo + integer intent(in),depend(n,ilo),check(min(ilo,n)<=ihi && ihi<=n) :: ihi + integer intent(in),depend(ilo),check(1<=iloz & iloz<=ilo) :: iloz + integer intent(in),depend(n,ihi),check(ihi<=ihiz && ihiz<=n) :: ihiz + double precision intent(in,out,copy),dimension(ldh1,ldh2,p) :: h + integer intent(hide),depend(h,n),check(ldh1>=max(1,n)) :: ldh1=shape(h,0) + integer intent(hide),depend(h,n),check(ldh2>=max(1,n)) :: ldh2=shape(h,1) + double precision intent(in,out,copy),depend(p),dimension(ldz1,ldz2,p) :: z + integer intent(hide),depend(z) :: ldz1=shape(z,0) + integer intent(hide),depend(z) :: ldz2=shape(z,1) + double precision intent(out), dimension(n), depend(n) :: wr + double precision intent(out), dimension(n), depend(n) :: wi + double precision intent(hide,cache), dimension(ldwork) :: dwork + integer optional,check(ldwork>=ihi-ilo+p-1), depend(ihi,ilo,p) :: ldwork=max(1,ihi-ilo+p-1) + integer intent(out) :: info +end subroutine mb03wd + subroutine mb05md(balanc,n,delta,a,lda,v,ldv,y,ldy,valr,vali,iwork,dwork,ldwork,info) ! in MB05MD.f character intent(in):: balanc integer intent(in),check(n>=0) :: n @@ -45,3 +96,6 @@ subroutine mb05nd(n,delta,a,lda,ex,ldex,exint,ldexin,tol,iwork,dwork,ldwork,info integer intent(hide),depend(dwork):: ldwork=shape(dwork,0) integer intent(out) :: info end subroutine mb05nd + +! This file was auto-generated with f2py (version:2). +! See http://cens.ioc.ee/projects/f2py2e/ diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 8c7f26d1..1bcba94f 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -5,6 +5,7 @@ set(PYSOURCE test_ag08bd.py test_mb.py test_mc.py + test_mb03schur.py test_sb10jd.py test_sg02ad.py test_sg03ad.py diff --git a/slycot/tests/test_mb03schur.py b/slycot/tests/test_mb03schur.py new file mode 100644 index 00000000..029c1208 --- /dev/null +++ b/slycot/tests/test_mb03schur.py @@ -0,0 +1,156 @@ +#!/usr/bin/env python +""" +test_mb03schur.py +Created on Sun Jan 26 17:38:08 2020 + +@author: bnavigator + +""" + +import unittest +from slycot import math +import numpy as np + +from numpy.testing import assert_allclose + + +class test_mb03schur(unittest.TestCase): + """unit tests for schur decomposition functions""" + + def test_mb03vd_mb03vy_ex(self): + """Test MB03VD and MB03VY + with the example given in the MB03VD SLICOT documentation""" + + n = 4 + p = 2 + ilo = 1 + ihi = 4 + A = np.zeros((n, n, p)) + A[:, :, 0] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + A[:, :, 1] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + + H_ref = np.zeros((n, n, p)) + H_ref[:, :, 0] = [[-2.3926, 2.7042, -0.9598, -1.2335], + [ 4.1417, -1.7046, 1.3001, -1.3120], + [ 0.0000, -1.6247, -0.2534, 1.6453], + [ 0.0000, 0.0000, -0.0169, -0.4451]] + + H_ref[:, :, 1] = [[-2.5495, 2.3402, 4.7021, 0.2329], + [ 0.0000, 1.9725, -0.2483, -2.3493], + [ 0.0000, 0.0000, -0.6290, -0.5975], + [ 0.0000, 0.0000, 0.0000, -0.4426]] + + Q_ref = np.zeros((n, n, p)) + Q_ref[:, :, 0] = [[ 1.0000, 0.0000, 0.0000, 0.0000], + [ 0.0000, -0.7103, 0.5504, -0.4388], + [ 0.0000, -0.4735, -0.8349, -0.2807], + [ 0.0000, -0.5209, 0.0084, 0.8536]] + + Q_ref[:, :, 1] = [[-0.5883, 0.2947, 0.7528, -0.0145], + [-0.3922, -0.8070, 0.0009, -0.4415], + [-0.5883, 0.4292, -0.6329, -0.2630], + [-0.3922, -0.2788, -0.1809, 0.8577]] + + HQ, Tau = math.mb03vd(n, ilo, ihi, A) + + H = np.zeros_like(HQ) + Q = np.zeros_like(HQ) + + for k in range(p): + Q[:, :, k] = np.tril(HQ[:, :, k]) + if k == 0: + H[:, :, k] = np.triu(HQ[:n, :n, k], -1) + elif k > 0: + H[:, :, k] = np.triu(HQ[:n, :n, k]) + assert_allclose(H[:, :, k], H_ref[:, :, k], atol=1e-4) + + Qr = math.mb03vy(n, ilo, ihi, Q, Tau) + + for k in range(p): + assert_allclose(Qr[:, :, k], Q_ref[:, :, k], atol=1e-4) + + # Computer Error: too machine dependent to test to reference value + # SSQ_ref = 2.93760e-15 + # SSQ = 0. + # for k in range(p): + # kp1 = k+1 + # if kp1 > p-1: + # kp1 = 0 + # P = Qr[:, :, k].T.dot(A[: ,: ,k]).dot(Qr[: ,: ,kp1]) - H[: ,: ,k] + # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) + + def test_mb03wd_ex(self): + """Test MB03WD with the example given in the SLICOT documentation""" + + n = 4 + p = 2 + ilo = 1 + ihi = 4 + iloz = 1 + ihiz = 4 + job = 'S' + compz = 'V' + A = np.zeros((n, n, p)) + A[:, :, 0] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + A[:, :, 1] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + + W_ref = np.array([6.449861+7.817717J, + 6.449861-7.817717J, + 0.091315+0.000000J, + 0.208964+0.000000J]) + + T_ref = np.zeros((n, n, p)) + T_ref[:, :, 0] = [[ 2.2112, 4.3718, -2.3362, 0.8907], + [ -0.9179, 2.7688, -0.6570, -2.2426], + [ 0.0000, 0.0000, 0.3022, 0.1932], + [ 0.0000, 0.0000, 0.0000, -0.4571]] + + T_ref[:, :, 1] = [[ 2.9169, 3.4539, 2.2016, 1.2367], + [ 0.0000, 3.4745, 1.0209, -2.0720], + [ 0.0000, 0.0000, 0.3022, -0.1932], + [ 0.0000, 0.0000, 0.0000, -0.4571]] + + Z_ref = np.zeros((n, n, p)) + Z_ref[:, :, 0] = [[ 0.3493, 0.6751, -0.6490, 0.0327], + [ 0.7483, -0.4863, -0.1249, -0.4336], + [ 0.2939, 0.5504, 0.7148, -0.3158], + [ 0.4813, -0.0700, 0.2286, 0.8433]] + + + Z_ref[:, :, 1] = [[ 0.2372, 0.7221, 0.6490, 0.0327], + [ 0.8163, -0.3608, 0.1249, -0.4336], + [ 0.2025, 0.5902, -0.7148, -0.3158], + [ 0.4863, 0.0076, -0.2286, 0.8433]] + + HQ, Tau = math.mb03vd(n, ilo, ihi, A) + Q = math.mb03vy(n, ilo, ihi, HQ, Tau) + T, Z, W = math.mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, HQ, Q) + + # TODO (?) + # isolate eigenvalues with math.mb03wx + + assert_allclose(W, W_ref, atol=1e-5) + assert_allclose(T, T_ref, atol=1e-4) + assert_allclose(Z, Z_ref, atol=1e-4) + + # Computer Error: too machine dependent to test to reference value + # SSQ_ref = 7.18432D-15 + # SSQ = 0. + # for k in range(p): + # kp1 = k+1 + # if kp1 > p-1: + # kp1 = 0 + # P = Zrr[:, :, k].T.dot(A[: ,: ,k]).dot(Zrr[: ,: ,kp1]) - Hrr[: ,: ,k] + # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) From d37866f8dc50a167f73b05294d3d1d8d8e749e81 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 26 Jan 2020 22:42:16 +0100 Subject: [PATCH 113/405] fix math.pyf for python2 error --- slycot/src/math.pyf | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index ccedae1d..ecf94f2c 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -20,9 +20,9 @@ subroutine mb03vd(n,p,ilo,ihi,a,lda1,lda2,tau,ldtau,dwork,info) ! in MB03VD.f double precision intent(in,out,copy),dimension(lda1,lda2,p) :: a integer intent(hide),depend(a,n),check(lda1>=max(1,n)) :: lda1=shape(a,0) integer intent(hide),depend(a,n),check(lda2>=max(1,n)) :: lda2=shape(a,1) - double precision intent(out),depend(n),dimension(max(1,n-1),p) :: tau + double precision intent(out),depend(n,p),dimension(max(1,n-1),p) :: tau integer intent(hide),depend(tau) :: ldtau=shape(tau,0) - double precision intent(hide,cache),dimension(n) :: dwork + double precision intent(hide,cache),depend(n),dimension(n) :: dwork integer intent(out) :: info end subroutine mb03vd @@ -34,9 +34,9 @@ subroutine mb03vy(n,p,ilo,ihi,a,lda1,lda2,tau,ldtau,dwork,ldwork,info) ! in MB03 double precision intent(in,out,copy),dimension(lda1,lda2,p) :: a integer intent(hide),depend(a,n),check(lda1>=max(1,n)) :: lda1=shape(a,0) integer intent(hide),depend(a,n),check(lda2>=max(1,n)) :: lda2=shape(a,1) - double precision intent(in),depend(n),dimension(ldtau,p) :: tau + double precision intent(in),depend(n,p),dimension(ldtau,p) :: tau integer intent(hide),depend(tau),check(ldtau>=max(1,n-1)) :: ldtau=shape(tau,0) - double precision intent(hide,cache),dimension(n) :: dwork + double precision intent(hide,cache),depend(ldwork),dimension(ldwork) :: dwork integer intent(in),optional,check(ldwork>=max(1,n)) :: ldwork=max(1,n) integer intent(out) :: info end subroutine mb03vy From 486239d857e5940edaa430b758f1abc3dc53658a Mon Sep 17 00:00:00 2001 From: Ben Date: Mon, 27 Jan 2020 14:41:48 +0100 Subject: [PATCH 114/405] some cosmetics on the docstrings --- slycot/math.py | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 5bf2f927..dc259424 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -258,7 +258,7 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): arg_list = ['n', 'p' + hidden, 'ilo', 'ihi', 'a', 'lda1' + hidden, 'lda2' + hidden, 'tau', - 'ldtau' + hidden, 'dwork' + hidden, 'info'] + 'ldtau' + hidden, 'dwork' + hidden, 'ldwork', 'info' + hidden] if not ldwork: ldwork = max(1, 2 * n) @@ -359,12 +359,12 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): ------- T : ndarray - If JOB = 'S', T[:n,:n,0] s upper quasi-triangular in rows + If JOB = 'S', T[:n,:n,0] is upper quasi-triangular in rows and columns [ilo-1:ihi], with any 2-by-2 diagonal blocks corresponding to a pair of complex conjugated eigenvalues, and T[:n,:n,j-1] for j > 1 contains the resulting upper triangular matrix T_j. - If job = 'E', T is None + If job = 'E', T is None Z : ndarray If compz = 'V', or compz = 'I', the leading From 1f43a0f47164f4ae1a2312b0b500c9d528f1c03c Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 10 Apr 2020 13:02:52 +0200 Subject: [PATCH 115/405] move the schur tests into test_mb.py --- slycot/__init__.py | 2 +- slycot/tests/test_mb.py | 141 ++++++++++++++++++++++++++++- slycot/tests/test_mb03schur.py | 156 --------------------------------- 3 files changed, 141 insertions(+), 158 deletions(-) delete mode 100644 slycot/tests/test_mb03schur.py diff --git a/slycot/__init__.py b/slycot/__init__.py index 22461b62..11b13d12 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -22,7 +22,7 @@ # Identification routines (0/5 wrapped) - # Mathematical routines (3/81 wrapped) + # Mathematical routines (6/81 wrapped) from .math import mc01td, mb03vd, mb03vy, mb03wd, mb05md, mb05nd # Synthesis routines (14/50 wrapped) diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index 2f8e3750..b55a0d91 100755 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -6,13 +6,152 @@ import unittest import numpy as np -from slycot import mb05md, mb05nd +from slycot import mb03vd, mb03vy, mb03wd, mb05md, mb05nd from numpy.testing import assert_allclose class test_mb(unittest.TestCase): + def test_mb03vd_mb03vy_ex(self): + """Test MB03VD and MB03VY + with the example given in the MB03VD SLICOT documentation""" + + n = 4 + p = 2 + ilo = 1 + ihi = 4 + A = np.zeros((n, n, p)) + A[:, :, 0] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + A[:, :, 1] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + + H_ref = np.zeros((n, n, p)) + H_ref[:, :, 0] = [[-2.3926, 2.7042, -0.9598, -1.2335], + [ 4.1417, -1.7046, 1.3001, -1.3120], + [ 0.0000, -1.6247, -0.2534, 1.6453], + [ 0.0000, 0.0000, -0.0169, -0.4451]] + + H_ref[:, :, 1] = [[-2.5495, 2.3402, 4.7021, 0.2329], + [ 0.0000, 1.9725, -0.2483, -2.3493], + [ 0.0000, 0.0000, -0.6290, -0.5975], + [ 0.0000, 0.0000, 0.0000, -0.4426]] + + Q_ref = np.zeros((n, n, p)) + Q_ref[:, :, 0] = [[ 1.0000, 0.0000, 0.0000, 0.0000], + [ 0.0000, -0.7103, 0.5504, -0.4388], + [ 0.0000, -0.4735, -0.8349, -0.2807], + [ 0.0000, -0.5209, 0.0084, 0.8536]] + + Q_ref[:, :, 1] = [[-0.5883, 0.2947, 0.7528, -0.0145], + [-0.3922, -0.8070, 0.0009, -0.4415], + [-0.5883, 0.4292, -0.6329, -0.2630], + [-0.3922, -0.2788, -0.1809, 0.8577]] + + HQ, Tau = mb03vd(n, ilo, ihi, A) + + H = np.zeros_like(HQ) + Q = np.zeros_like(HQ) + + for k in range(p): + Q[:, :, k] = np.tril(HQ[:, :, k]) + if k == 0: + H[:, :, k] = np.triu(HQ[:n, :n, k], -1) + elif k > 0: + H[:, :, k] = np.triu(HQ[:n, :n, k]) + assert_allclose(H[:, :, k], H_ref[:, :, k], atol=1e-4) + + Qr = mb03vy(n, ilo, ihi, Q, Tau) + + for k in range(p): + assert_allclose(Qr[:, :, k], Q_ref[:, :, k], atol=1e-4) + + # Computer Error: too machine dependent to test to reference value + # SSQ_ref = 2.93760e-15 + # SSQ = 0. + # for k in range(p): + # kp1 = k+1 + # if kp1 > p-1: + # kp1 = 0 + # P = Qr[:, :, k].T.dot(A[: ,: ,k]).dot(Qr[: ,: ,kp1]) - H[: ,: ,k] + # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) + + def test_mb03wd_ex(self): + """Test MB03WD with the example given in the SLICOT documentation""" + + n = 4 + p = 2 + ilo = 1 + ihi = 4 + iloz = 1 + ihiz = 4 + job = 'S' + compz = 'V' + A = np.zeros((n, n, p)) + A[:, :, 0] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + A[:, :, 1] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + + W_ref = np.array([6.449861+7.817717J, + 6.449861-7.817717J, + 0.091315+0.000000J, + 0.208964+0.000000J]) + + T_ref = np.zeros((n, n, p)) + T_ref[:, :, 0] = [[ 2.2112, 4.3718, -2.3362, 0.8907], + [ -0.9179, 2.7688, -0.6570, -2.2426], + [ 0.0000, 0.0000, 0.3022, 0.1932], + [ 0.0000, 0.0000, 0.0000, -0.4571]] + + T_ref[:, :, 1] = [[ 2.9169, 3.4539, 2.2016, 1.2367], + [ 0.0000, 3.4745, 1.0209, -2.0720], + [ 0.0000, 0.0000, 0.3022, -0.1932], + [ 0.0000, 0.0000, 0.0000, -0.4571]] + + Z_ref = np.zeros((n, n, p)) + Z_ref[:, :, 0] = [[ 0.3493, 0.6751, -0.6490, 0.0327], + [ 0.7483, -0.4863, -0.1249, -0.4336], + [ 0.2939, 0.5504, 0.7148, -0.3158], + [ 0.4813, -0.0700, 0.2286, 0.8433]] + + + Z_ref[:, :, 1] = [[ 0.2372, 0.7221, 0.6490, 0.0327], + [ 0.8163, -0.3608, 0.1249, -0.4336], + [ 0.2025, 0.5902, -0.7148, -0.3158], + [ 0.4863, 0.0076, -0.2286, 0.8433]] + + HQ, Tau = mb03vd(n, ilo, ihi, A) + Q = mb03vy(n, ilo, ihi, HQ, Tau) + T, Z, W = mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, HQ, Q) + + # TODO (?) + # isolate eigenvalues with math.mb03wx + + assert_allclose(W, W_ref, atol=1e-5) + assert_allclose(T, T_ref, atol=1e-4) + assert_allclose(Z, Z_ref, atol=1e-4) + + # Computer Error: too machine dependent to test to reference value + # SSQ_ref = 7.18432D-15 + # SSQ = 0. + # for k in range(p): + # kp1 = k+1 + # if kp1 > p-1: + # kp1 = 0 + # P = Zrr[:, :, k].T.dot(A[: ,: ,k]).dot(Zrr[: ,: ,kp1]) - Hrr[: ,: ,k] + # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) + + def test_mb05md(self): """ test_mb05md: verify Matrix exponential with slicot doc example data from http://slicot.org/objects/software/shared/doc/MB05MD.html diff --git a/slycot/tests/test_mb03schur.py b/slycot/tests/test_mb03schur.py deleted file mode 100644 index 029c1208..00000000 --- a/slycot/tests/test_mb03schur.py +++ /dev/null @@ -1,156 +0,0 @@ -#!/usr/bin/env python -""" -test_mb03schur.py -Created on Sun Jan 26 17:38:08 2020 - -@author: bnavigator - -""" - -import unittest -from slycot import math -import numpy as np - -from numpy.testing import assert_allclose - - -class test_mb03schur(unittest.TestCase): - """unit tests for schur decomposition functions""" - - def test_mb03vd_mb03vy_ex(self): - """Test MB03VD and MB03VY - with the example given in the MB03VD SLICOT documentation""" - - n = 4 - p = 2 - ilo = 1 - ihi = 4 - A = np.zeros((n, n, p)) - A[:, :, 0] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - A[:, :, 1] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - - H_ref = np.zeros((n, n, p)) - H_ref[:, :, 0] = [[-2.3926, 2.7042, -0.9598, -1.2335], - [ 4.1417, -1.7046, 1.3001, -1.3120], - [ 0.0000, -1.6247, -0.2534, 1.6453], - [ 0.0000, 0.0000, -0.0169, -0.4451]] - - H_ref[:, :, 1] = [[-2.5495, 2.3402, 4.7021, 0.2329], - [ 0.0000, 1.9725, -0.2483, -2.3493], - [ 0.0000, 0.0000, -0.6290, -0.5975], - [ 0.0000, 0.0000, 0.0000, -0.4426]] - - Q_ref = np.zeros((n, n, p)) - Q_ref[:, :, 0] = [[ 1.0000, 0.0000, 0.0000, 0.0000], - [ 0.0000, -0.7103, 0.5504, -0.4388], - [ 0.0000, -0.4735, -0.8349, -0.2807], - [ 0.0000, -0.5209, 0.0084, 0.8536]] - - Q_ref[:, :, 1] = [[-0.5883, 0.2947, 0.7528, -0.0145], - [-0.3922, -0.8070, 0.0009, -0.4415], - [-0.5883, 0.4292, -0.6329, -0.2630], - [-0.3922, -0.2788, -0.1809, 0.8577]] - - HQ, Tau = math.mb03vd(n, ilo, ihi, A) - - H = np.zeros_like(HQ) - Q = np.zeros_like(HQ) - - for k in range(p): - Q[:, :, k] = np.tril(HQ[:, :, k]) - if k == 0: - H[:, :, k] = np.triu(HQ[:n, :n, k], -1) - elif k > 0: - H[:, :, k] = np.triu(HQ[:n, :n, k]) - assert_allclose(H[:, :, k], H_ref[:, :, k], atol=1e-4) - - Qr = math.mb03vy(n, ilo, ihi, Q, Tau) - - for k in range(p): - assert_allclose(Qr[:, :, k], Q_ref[:, :, k], atol=1e-4) - - # Computer Error: too machine dependent to test to reference value - # SSQ_ref = 2.93760e-15 - # SSQ = 0. - # for k in range(p): - # kp1 = k+1 - # if kp1 > p-1: - # kp1 = 0 - # P = Qr[:, :, k].T.dot(A[: ,: ,k]).dot(Qr[: ,: ,kp1]) - H[: ,: ,k] - # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) - - def test_mb03wd_ex(self): - """Test MB03WD with the example given in the SLICOT documentation""" - - n = 4 - p = 2 - ilo = 1 - ihi = 4 - iloz = 1 - ihiz = 4 - job = 'S' - compz = 'V' - A = np.zeros((n, n, p)) - A[:, :, 0] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - A[:, :, 1] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - - W_ref = np.array([6.449861+7.817717J, - 6.449861-7.817717J, - 0.091315+0.000000J, - 0.208964+0.000000J]) - - T_ref = np.zeros((n, n, p)) - T_ref[:, :, 0] = [[ 2.2112, 4.3718, -2.3362, 0.8907], - [ -0.9179, 2.7688, -0.6570, -2.2426], - [ 0.0000, 0.0000, 0.3022, 0.1932], - [ 0.0000, 0.0000, 0.0000, -0.4571]] - - T_ref[:, :, 1] = [[ 2.9169, 3.4539, 2.2016, 1.2367], - [ 0.0000, 3.4745, 1.0209, -2.0720], - [ 0.0000, 0.0000, 0.3022, -0.1932], - [ 0.0000, 0.0000, 0.0000, -0.4571]] - - Z_ref = np.zeros((n, n, p)) - Z_ref[:, :, 0] = [[ 0.3493, 0.6751, -0.6490, 0.0327], - [ 0.7483, -0.4863, -0.1249, -0.4336], - [ 0.2939, 0.5504, 0.7148, -0.3158], - [ 0.4813, -0.0700, 0.2286, 0.8433]] - - - Z_ref[:, :, 1] = [[ 0.2372, 0.7221, 0.6490, 0.0327], - [ 0.8163, -0.3608, 0.1249, -0.4336], - [ 0.2025, 0.5902, -0.7148, -0.3158], - [ 0.4863, 0.0076, -0.2286, 0.8433]] - - HQ, Tau = math.mb03vd(n, ilo, ihi, A) - Q = math.mb03vy(n, ilo, ihi, HQ, Tau) - T, Z, W = math.mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, HQ, Q) - - # TODO (?) - # isolate eigenvalues with math.mb03wx - - assert_allclose(W, W_ref, atol=1e-5) - assert_allclose(T, T_ref, atol=1e-4) - assert_allclose(Z, Z_ref, atol=1e-4) - - # Computer Error: too machine dependent to test to reference value - # SSQ_ref = 7.18432D-15 - # SSQ = 0. - # for k in range(p): - # kp1 = k+1 - # if kp1 > p-1: - # kp1 = 0 - # P = Zrr[:, :, k].T.dot(A[: ,: ,k]).dot(Zrr[: ,: ,kp1]) - Hrr[: ,: ,k] - # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) From 932c041a232e11321751cfe366eabc08220ecc6d Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 10 Apr 2020 21:37:53 +0200 Subject: [PATCH 116/405] remove test_mb03schur.py entry from CMakeLists.txt --- slycot/tests/CMakeLists.txt | 1 - 1 file changed, 1 deletion(-) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 1bcba94f..8c7f26d1 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -5,7 +5,6 @@ set(PYSOURCE test_ag08bd.py test_mb.py test_mc.py - test_mb03schur.py test_sb10jd.py test_sg02ad.py test_sg03ad.py From 394db11cb653ac8d42bdd5c478135602a98c9555 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Sat, 11 Apr 2020 11:01:30 +0200 Subject: [PATCH 117/405] add dimensions to returned values in docstrings --- slycot/math.py | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index dc259424..4c2d7cac 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -109,7 +109,7 @@ def mb03vd(n, ilo, ihi, A): ------- HQ : ndarray - The upper triangle and the first + 3D array with same shape as A. The upper triangle and the first subdiagonal of HQ[:n,:n,0] contain the upper Hessenberg matrix H_1, and the elements below the first subdiagonal, with the first column of the array Tau represent the @@ -122,6 +122,7 @@ def mb03vd(n, ilo, ihi, A): elementary reflectors. See FURTHER COMMENTS. Tau : ndarray + 2D array with shape (max(1, n-1), p). The leading n-1 elements in the j-th column contain the scalar factors of the elementary reflectors used to form the matrix Q_j, j = 1, ..., p. See FURTHER COMMENTS. @@ -183,9 +184,6 @@ def mb03vd(n, ilo, ihi, A): denotes an element of the vector defining H_j(i). (The element (1,2) in A_p is also unchanged for this example.) - Note that for P = 1, the LAPACK Library routine DGEHRD could be - more efficient on some computer architectures than this routine - (a BLAS 2 version). """ hidden = ' (hidden by the wrapper)' arg_list = ['n', 'p' + hidden, @@ -235,16 +233,16 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): MB03VD. ldwork : int, optional - The length of the array DWORK. LDWORK >= MAX(1,N). - For optimum performance LDWORK should be larger. + The length of the internal array DWORK. ldwork >= max(1, n). + For optimum performance ldwork should be larger. Returns ------- Q : ndarray - Q[:n,:n,j-1] contains the - N-by-N orthogonal matrix Q_j, j = 1, ..., p. + 3D array with same shape as A. Q[:n,:n,j-1] contains the + N-by-N orthogonal matrix Q_j, j = 1, ..., p. Raises ------ @@ -359,6 +357,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): ------- T : ndarray + 3D array with the same shape as H. If JOB = 'S', T[:n,:n,0] is upper quasi-triangular in rows and columns [ilo-1:ihi], with any 2-by-2 diagonal blocks corresponding to a pair of complex conjugated eigenvalues, and @@ -367,6 +366,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): If job = 'E', T is None Z : ndarray + 3D array with the same shape as Q. If compz = 'V', or compz = 'I', the leading N-by-N-by-P part of this array contains the transformation matrices which produced the Schur form; the @@ -376,9 +376,10 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): W : ndarray (dtype=complex) + 1D array with shape (n). The computed eigenvalues ilo to ihi. If two eigenvalues are computed as a complex conjugate pair, they are stored - in consecutive elements of Wr say the i-th and + in consecutive elements of W say the i-th and (i+1)th, with imag(W][i]) > 0 and imag(W[i+1]) < 0. If JOB = 'S', the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H. From 5d409fa632016e9f25213a0d63b1385adb28489a Mon Sep 17 00:00:00 2001 From: bnavigator Date: Sat, 11 Apr 2020 12:23:41 +0200 Subject: [PATCH 118/405] docstring fix of index and slice --- slycot/math.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 4c2d7cac..39a7ea7c 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -94,7 +94,7 @@ def mb03vd(n, ilo, ihi, A): It is assumed that all matrices A_j, j = 2, ..., p, are already upper triangular in rows and columns [:ilo] and [ihi:n], and A_1 is upper Hessenberg in rows and columns - [:ilo] and [ihi:n], with A_1[ilo-1,ilo] = 0 (unless + [:ilo-1] and [ihi:n], with A_1[ilo-1,ilo-2] = 0 (unless ilo = 1), and A_1[ihi,ihi-1] = 0 (unless ihi = n). If this is not the case, ilo and ihi should be set to 1 and n, respectively. @@ -115,7 +115,7 @@ def mb03vd(n, ilo, ihi, A): with the first column of the array Tau represent the orthogonal matrix Q_1 as a product of elementary reflectors. See FURTHER COMMENTS. - For j > 1, the upper triangle of HQ[:n,_n,j-1] + For j > 1, the upper triangle of HQ[:n,:n,j-1] contains the upper triangular matrix H_j, and the elements below the diagonal, with the j-th column of the array TAU represent the orthogonal matrix Q_j as a product of From f3c9407b0c0b006bc764c90f00d04ccaf714d08e Mon Sep 17 00:00:00 2001 From: bnavigator Date: Sat, 11 Apr 2020 15:29:25 +0200 Subject: [PATCH 119/405] another slice in docstring fix --- slycot/math.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/math.py b/slycot/math.py index 39a7ea7c..a2c6b74d 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -92,7 +92,7 @@ def mb03vd(n, ilo, ihi, A): ilo, ihi : int It is assumed that all matrices A_j, j = 2, ..., p, are - already upper triangular in rows and columns [:ilo] and + already upper triangular in rows and columns [:ilo-1] and [ihi:n], and A_1 is upper Hessenberg in rows and columns [:ilo-1] and [ihi:n], with A_1[ilo-1,ilo-2] = 0 (unless ilo = 1), and A_1[ihi,ihi-1] = 0 (unless ihi = n). From 50f595467bbbadf9160ff800d3eb93e6215190f2 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 11 Apr 2020 19:53:16 +0200 Subject: [PATCH 120/405] a further slice in docstring fix --- slycot/math.py | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index a2c6b74d..3d28b591 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -321,9 +321,9 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): ilo, ihi : int It is assumed that all matrices H_j, j = 2, ..., p, are - already upper triangular in rows and columns [:ilo] and - [ihi+1:n], and H_1 is upper quasi-triangular in rows and - columns [:ilo] and [ihi+1:n], with H_1[ilo-1,ilo] = 0 + already upper triangular in rows and columns [:ilo-1] and + [ihi:n], and H_1 is upper quasi-triangular in rows and + columns [:ilo-1] and [ihi:n], with H_1[ilo-1,ilo] = 0 (unless ilo = 1), and H_1[ihi,ihi-1] = 0 (unless ihi = n). The routine works primarily with the Hessenberg submatrix in rows and columns ilo to ihi, but applies the From 35743db789eef998aa2997c674f8af8e06ef6dec Mon Sep 17 00:00:00 2001 From: bnavigator Date: Sat, 11 Apr 2020 21:40:33 +0200 Subject: [PATCH 121/405] yet another docstring index fix --- slycot/math.py | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 3d28b591..78808210 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -323,7 +323,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): It is assumed that all matrices H_j, j = 2, ..., p, are already upper triangular in rows and columns [:ilo-1] and [ihi:n], and H_1 is upper quasi-triangular in rows and - columns [:ilo-1] and [ihi:n], with H_1[ilo-1,ilo] = 0 + columns [:ilo-1] and [ihi:n], with H_1[ilo-1,ilo-2] = 0 (unless ilo = 1), and H_1[ihi,ihi-1] = 0 (unless ihi = n). The routine works primarily with the Hessenberg submatrix in rows and columns ilo to ihi, but applies the @@ -371,10 +371,9 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): N-by-N-by-P part of this array contains the transformation matrices which produced the Schur form; the transformations are applied only to the submatrices - Z[iloz-1:ihiz,ilo-1:ihi,j-1], j = 1, ..., P. + Z[iloz-1:ihiz,ilo-1:ihi,j-1], j = 1, ..., p. If compz = 'N', Z is None - W : ndarray (dtype=complex) 1D array with shape (n). The computed eigenvalues ilo to ihi. If two eigenvalues From 51f0b66f8028b1b909c09bb03fefa8fc13a67523 Mon Sep 17 00:00:00 2001 From: lytex Date: Wed, 1 Apr 2020 18:58:43 +0200 Subject: [PATCH 122/405] add ab08nz function to support regular pencil for complex state-space systems --- slycot/__init__.py | 3 +- slycot/analysis.py | 88 +++++++++++++++++++++++++++++++++++++++++ slycot/src/analysis.pyf | 31 +++++++++++++++ 3 files changed, 121 insertions(+), 1 deletion(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 11b13d12..aae4d81e 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -14,7 +14,8 @@ # Analysis routines (14/40 wrapped) from .analysis import ab01nd,ab05md,ab05nd,ab07nd,ab08nd, \ - ab09ad,ab09ax,ab09bd,ab09md,ab09nd,ab13bd,ab13dd,ab13ed,ab13fd + ab09ad,ab09ax,ab09bd,ab09md,ab09nd,ab13bd,ab13dd,ab13ed,ab13fd, \ + ab08nz # Data analysis routines (0/7 wrapped) diff --git a/slycot/analysis.py b/slycot/analysis.py index 1b496d69..edfd8bad 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -475,6 +475,94 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): raise e return out[:-1] +def ab08nz(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): + """ nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = ab08nz(n,m,p,A,B,C,D,[equil,tol,ldwork]) + + To construct for a linear multivariable system described by a state-space + model (A,B,C,D) a regular pencil (Af - lambda*Bf ) which has the invariant + zeros of the system as generalized eigenvalues. + The routine also computes the orders of the infinite zeros and the + right and left Kronecker indices of the system (A,B,C,D). + + Required arguments: + n : input int + The number of state variables. n >= 0. + m : input int + The number of system inputs. m >= 0. + p : input int + The number of system outputs. p >= 0. + A : input rank-2 array('d') with bounds (n,n) + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system. + B : input rank-2 array('d') with bounds (n,m) + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : input rank-2 array('d') with bounds (p,n) + The leading p-by-n part of this array must contain the state/output + matrix C of the system. + D : input rank-2 array('d') with bounds (p,m) + The leading p-by-m part of this array must contain the direct + transmission matrix D of the system. + Optional arguments: + equil := 'N' input string(len=1) + Specifies whether the user wishes to balance the compound matrix + as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + tol := 0.0 input float + A tolerance used in rank decisions to determine the effective rank, + which is defined as the order of the largest leading (or trailing) + triangular submatrix in the QR (or RQ) factorization with column + (or row) pivoting whose estimated condition number is less than 1/tol. + ldwork := None input int + The length of the cache array. The default value is n + 3*max(m,p), + for better performance should be larger. + Return objects: + nu : int + The number of (finite) invariant zeros. + rank : int + The normal rank of the transfer function matrix. + dinfz : int + The maximum degree of infinite elementary divisors. + nkror : int + The number of right Kronecker indices. + nkrol : int + The number of left Kronecker indices. + infz : rank-1 array('i') with bounds (n) + The leading dinfz elements of infz contain information on the + infinite elementary divisors as follows: the system has infz(i) + infinite elementary divisors of degree i, where i = 1,2,...,dinfz. + kronr : rank-1 array('i') with bounds (max(n,m)+1) + the leading nkror elements of this array contain the right kronecker + (column) indices. + kronl : rank-1 array('i') with bounds (max(n,p)+1) + the leading nkrol elements of this array contain the left kronecker + (row) indices. + Af : rank-2 array('d') with bounds (max(1,n+m),n+min(p,m)) + the leading nu-by-nu part of this array contains the coefficient + matrix Af of the reduced pencil. the remainder of the leading + (n+m)-by-(n+min(p,m)) part is used as internal workspace. + Bf : rank-2 array('d') with bounds (max(1,n+p),n+m) + The leading nu-by-nu part of this array contains the coefficient + matrix Bf of the reduced pencil. the remainder of the leading + (n+p)-by-(n+m) part is used as internal workspace. + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['equil', 'n', 'm', 'p', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, + 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, 'nu', 'rank', 'dinfz', 'nkror', + 'nkrol', 'infz', 'kronr', 'kronl', 'Af', 'LDAF'+hidden, 'Bf', + 'LDBF'+hidden, 'tol', 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', + 'INFO'+hidden] + if ldwork is None: + ldwork = n+3*max(m,p) #only an upper bound + out = _wrapper.ab08nz(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) + if out[-1] < 0: + error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] + e = ValueError(error_text) + e.info = out[-1] + raise e + return out[:-1] + def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): """ nr,Ar,Br,Cr,hsv = ab09ad(dico,job,equil,n,m,p,A,B,C,[nr,tol,ldwork]) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 58a0656b..fc412fde 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -184,6 +184,37 @@ subroutine ab08nd(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkr integer optional :: ldwork = n + 3*max(m,p) integer intent(out) :: info end subroutine ab08nd +subroutine ab08nz(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkrol,infz,kronr,kronl,af,ldaf,bf,ldbf,tol,iwork,dwork,ldwork,info) ! in :new:AB08NZ.f + character :: equil='N' + integer check(n>=0) :: n + integer check(m>=0) :: m + integer check(p>=0) :: p + complex*16 dimension(n,n),depend(n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + complex*16 dimension(n,m),depend(n,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + complex*16 dimension(p,n),depend(n,p) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + complex*16 dimension(p,m),depend(m,p) :: d + integer intent(hide),depend(d) :: ldd=shape(d,0) + integer intent(out) :: nu + integer intent(out) :: rank_bn + integer intent(out) :: dinfz + integer intent(out) :: nkror + integer intent(out) :: nkrol + integer intent(out),dimension(n),depend(n) :: infz + integer intent(out),dimension(max(n,m)+1),depend([n,m]) :: kronr + integer intent(out),dimension(max(n,p)+1),depend([n,p]) :: kronl + complex*16 intent(out),dimension(max(1,n+m),n+min(p,m)) :: af + integer intent(hide),depend(af) :: ldaf=shape(af,0) + complex*16 intent(out),dimension(max(1,n+p),n+m) :: bf + integer intent(hide),depend(bf) :: ldbf=shape(bf,0) + double precision :: tol=0.0 + integer intent(hide,cache),dimension(max(m,p)) :: iwork + double precision intent(hide,cache),dimension(ldwork) :: dwork + integer optional :: ldwork = n + 3*max(m,p) + integer intent(out) :: info +end subroutine ab08nz subroutine ab09ad(dico,job,equil,ordsel,n,m,p,nr,a,lda,b,ldb,c,ldc,hsv,tol,iwork,dwork,ldwork,iwarn,info) !in :balred:AB09AD.f character intent(in) :: dico character intent(in) :: job From 98c76bf6d734f746e121a2d7798bf56c67da7a33 Mon Sep 17 00:00:00 2001 From: lytex Date: Wed, 1 Apr 2020 21:42:12 +0200 Subject: [PATCH 123/405] add ab08n* tests (ab08nd executes successfully, ab08nz SEGFAULTs) --- slycot/tests/test_ab08n.py | 58 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 slycot/tests/test_ab08n.py diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py new file mode 100644 index 00000000..1823f1cc --- /dev/null +++ b/slycot/tests/test_ab08n.py @@ -0,0 +1,58 @@ +# =================================================== +# ag08bd tests + +import unittest +from slycot import analysis +import numpy as np + +from numpy.testing import assert_raises, assert_almost_equal, assert_equal + +# test input parameters + +test_A = np.array([[1, 0, 0, 0, 0, 0], + [0, 1, 0, 0, 0, 0], + [0, 0, 3, 0, 0, 0], + [0, 0, 0,-4, 0, 0], + [0, 0, 0, 0,-1, 0], + [0, 0, 0, 0, 1, 3]]) + +test_B = np.array([[0 , -1], + [-1, 0], + [ 1, -1], + [ 0, 0], + [ 0, 1], + [-1, -1]]) + +test_C = np.array([[1, 0, 0, 1, 0, 0], + [0, 1, 0, 1, 0, 1], + [0, 0, 1, 0, 0, 1]]) + +test_D = np.zeros((3, 2)) + +test_A = test_A.astype(np.complex128) +test_B = test_B.astype(np.complex128) +test_C = test_C.astype(np.complex128) +test_D = test_D.astype(np.complex128) + + +class test_ab08n(unittest.TestCase): + """ test1 to 4: Verify ag08bd with input parameters according to example in documentation """ + + def test_ab08nd(self): + #test [A-lambda*E] + #B,C,D must have correct dimensions according to l,n,m and p, but cannot have zero length in any dimenstion. Then the wrapper will complain. The length is then set to one. + + nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = analysis.ab08nd(6,2,3,test_A,test_B,test_C,test_D) + + def test_ab08nz(self): + #test [A-lambda*E] + #B,C,D must have correct dimensions according to l,n,m and p, but cannot have zero length in any dimenstion. Then the wrapper will complain. The length is then set to one. + nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = analysis.ab08nz(6,2,3,test_A,test_B,test_C,test_D) + + +def suite(): + return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + + +if __name__ == "__main__": + unittest.main() From 29355f25f991c3c1219a818cf4920c5394ec2337 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 03:03:15 +0200 Subject: [PATCH 124/405] clean __init__ --- slycot/__init__.py | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index aae4d81e..715a6214 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -12,10 +12,11 @@ # import slycot.examples - # Analysis routines (14/40 wrapped) - from .analysis import ab01nd,ab05md,ab05nd,ab07nd,ab08nd, \ - ab09ad,ab09ax,ab09bd,ab09md,ab09nd,ab13bd,ab13dd,ab13ed,ab13fd, \ - ab08nz + # Analysis routines (15/40 wrapped) + from .analysis import ab01nd, ab05md, ab05nd, ab07nd, ab08nd, ab08nz + from .analysis import ab09ad, ab09ax, ab09bd, ab09md, ab09nd + from .analysis import ab13bd, ab13dd, ab13ed, ab13fd + # Data analysis routines (0/7 wrapped) From 95af9c7caccfdac3483d79465dc11fafc016161a Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 03:03:39 +0200 Subject: [PATCH 125/405] rework signatures for ab08nd and ab08nz --- slycot/src/analysis.pyf | 65 +++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index fc412fde..2904949c 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -155,17 +155,17 @@ subroutine ab07nd(n,m,a,lda,b,ldb,c,ldc,d,ldd,rcond,iwork,dwork,ldwork,info) ! i end subroutine ab07nd subroutine ab08nd(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkrol,infz,kronr,kronl,af,ldaf,bf,ldbf,tol,iwork,dwork,ldwork,info) ! in :new:AB08ND.f character :: equil='N' - integer check(n>=0) :: n - integer check(m>=0) :: m - integer check(p>=0) :: p - double precision dimension(n,n),depend(n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) - double precision dimension(n,m),depend(n,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) - double precision dimension(p,n),depend(n,p) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) - double precision dimension(p,m),depend(m,p) :: d - integer intent(hide),depend(d) :: ldd=shape(d,0) + integer intent(in),check(n>=0),required :: n + integer intent(in),check(m>=0),required :: m + integer intent(in),check(p>=0),required :: p + double precision intent(in),dimension(lda,*),check(shape(a,1)>=n) :: a + integer intent(hide),check(lda>=max(1,n)) :: lda=shape(a,0) + double precision intent(in),dimension(ldb,*),check(shape(b,1)>=m) :: b + integer intent(hide),check(ldb>=max(1,n)) :: ldb=shape(b,0) + double precision intent(in),dimension(ldc,*),check(shape(c,1)>=n) :: c + integer intent(hide),check(ldc>=max(1,p)) :: ldc=shape(c,0) + double precision intent(in),dimension(ldd,*),check(shape(d,1)>=m) :: d + integer intent(hide),check(ldd>=max(1,p)) :: ldd=shape(d,0) integer intent(out) :: nu integer intent(out) :: rank_bn integer intent(out) :: dinfz @@ -184,35 +184,36 @@ subroutine ab08nd(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkr integer optional :: ldwork = n + 3*max(m,p) integer intent(out) :: info end subroutine ab08nd -subroutine ab08nz(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkrol,infz,kronr,kronl,af,ldaf,bf,ldbf,tol,iwork,dwork,ldwork,info) ! in :new:AB08NZ.f +subroutine ab08nz(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkrol,infz,kronr,kronl,af,ldaf,bf,ldbf,tol,iwork,dwork,zwork,lzwork,info) ! in AB08NZ.f character :: equil='N' - integer check(n>=0) :: n - integer check(m>=0) :: m - integer check(p>=0) :: p - complex*16 dimension(n,n),depend(n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) - complex*16 dimension(n,m),depend(n,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) - complex*16 dimension(p,n),depend(n,p) :: c - integer intent(hide),depend(c) :: ldc=shape(c,0) - complex*16 dimension(p,m),depend(m,p) :: d - integer intent(hide),depend(d) :: ldd=shape(d,0) + integer intent(in),check(n>=0),required :: n + integer intent(in),check(m>=0),required :: m + integer intent(in),check(p>=0),required :: p + complex*16 intent(in),dimension(lda,*),check(shape(a,1)>=n) :: a + integer intent(hide),check(lda>=max(1,n)) :: lda=shape(a,0) + complex*16 intent(in),dimension(ldb,*),check(shape(b,1)>=m) :: b + integer intent(hide),check(ldb>=max(1,n)) :: ldb=shape(b,0) + complex*16 intent(in),dimension(ldc,*),check(shape(c,1)>=n) :: c + integer intent(hide),check(ldc>=max(1,p)) :: ldc=shape(c,0) + complex*16 intent(in),dimension(ldd,*),check(shape(d,1)>=m) :: d + integer intent(hide),check(ldd>=max(1,p)) :: ldd=shape(d,0) integer intent(out) :: nu integer intent(out) :: rank_bn integer intent(out) :: dinfz integer intent(out) :: nkror integer intent(out) :: nkrol - integer intent(out),dimension(n),depend(n) :: infz - integer intent(out),dimension(max(n,m)+1),depend([n,m]) :: kronr - integer intent(out),dimension(max(n,p)+1),depend([n,p]) :: kronl + integer intent(out),dimension(n) :: infz + integer intent(out),dimension(max(n,m)+1) :: kronr + integer intent(out),dimension(max(n,p)+1) :: kronl complex*16 intent(out),dimension(max(1,n+m),n+min(p,m)) :: af - integer intent(hide),depend(af) :: ldaf=shape(af,0) + integer intent(hide),check(ldaf>=max(1,n+m)) :: ldaf=shape(af,0) complex*16 intent(out),dimension(max(1,n+p),n+m) :: bf - integer intent(hide),depend(bf) :: ldbf=shape(bf,0) - double precision :: tol=0.0 - integer intent(hide,cache),dimension(max(m,p)) :: iwork - double precision intent(hide,cache),dimension(ldwork) :: dwork - integer optional :: ldwork = n + 3*max(m,p) + integer intent(hide),check(ldbf>=max(1,n+p)) :: ldbf=shape(bf,0) + double precision intent(in) :: tol = 0.0 + integer intent(hide),cache,dimension(max(m,p)) :: iwork + double precision intent(hide),cache,dimension(max(n,2*max(p,m))) :: dwork + complex*16 intent(out),cache,dimension(lzwork) :: zwork + integer intent(in),check(lzwork>=max(min(p,m) + max(3*m-1,n), max(min(p,n) + max(3*p-1,max(n+p,n+m)), min(m,n) + max(3*m-1,n+m)))) :: lzwork = max(min(p,m) + max(3*m-1,n), max(min(p,n) + max(3*p-1,max(n+p,n+m)), min(m,n) + max(3*m-1,n+m))) integer intent(out) :: info end subroutine ab08nz subroutine ab09ad(dico,job,equil,ordsel,n,m,p,nr,a,lda,b,ldb,c,ldc,hsv,tol,iwork,dwork,ldwork,iwarn,info) !in :balred:AB09AD.f From e42edb72a374f85e99356083e14a9a481b7226bf Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 03:04:21 +0200 Subject: [PATCH 126/405] rework analysis.ab08nz() function --- slycot/analysis.py | 66 ++++++++++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 26 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index edfd8bad..96acc378 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -475,8 +475,8 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): raise e return out[:-1] -def ab08nz(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): - """ nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = ab08nz(n,m,p,A,B,C,D,[equil,tol,ldwork]) +def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): + """ nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = ab08nz(n,m,p,A,B,C,D,[equil,tol,lzwork]) To construct for a linear multivariable system described by a state-space model (A,B,C,D) a regular pencil (Af - lambda*Bf ) which has the invariant @@ -514,9 +514,12 @@ def ab08nz(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): which is defined as the order of the largest leading (or trailing) triangular submatrix in the QR (or RQ) factorization with column (or row) pivoting whose estimated condition number is less than 1/tol. - ldwork := None input int - The length of the cache array. The default value is n + 3*max(m,p), - for better performance should be larger. + lzwork := None input int + The length of the cache array zwork. The default value is calculated + to MAX( 1, MIN(P,M) + MAX(3*M-1,N), + MIN(P,N) + MAX(3*P-1,N+P,N+M), + MIN(M,N) + MAX(3*M-1,N+M) ) + for optimum performance should be larger. Return objects: nu : int The number of (finite) invariant zeros. @@ -546,22 +549,33 @@ def ab08nz(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): The leading nu-by-nu part of this array contains the coefficient matrix Bf of the reduced pencil. the remainder of the leading (n+p)-by-(n+m) part is used as internal workspace. + lzwork_opt : int + The optimal value of lzwork. """ hidden = ' (hidden by the wrapper)' - arg_list = ['equil', 'n', 'm', 'p', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, - 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, 'nu', 'rank', 'dinfz', 'nkror', - 'nkrol', 'infz', 'kronr', 'kronl', 'Af', 'LDAF'+hidden, 'Bf', - 'LDBF'+hidden, 'tol', 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', - 'INFO'+hidden] - if ldwork is None: - ldwork = n+3*max(m,p) #only an upper bound - out = _wrapper.ab08nz(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) - if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] + arg_list = ['equil', 'n', 'm', 'p', + 'a', 'lda' + hidden, 'b', 'ldb' + hidden, + 'c', 'ldc' + hidden, 'd', 'ldd' + hidden, + 'nu', 'rank', 'dinfz', 'nkror', 'nkrol', 'infz', 'kronr', + 'kronl', 'af', 'ldaf' + hidden, 'bf', 'ldbf' + hidden, + 'tol', 'iwork' + hidden, 'dwork' + hidden, 'zwork', + 'lzwork', 'info'] + if lzwork is None: + lzwork = max(min(p, m) + max(3*m-1, n), + min(p, n) + max(3*p-1, n+p, n+m), + min(m, n) + max(3*m-1, n+m)) + out = _wrapper.ab08nz(n, m, p, A, B, C, D, + equil=equil, tol=tol, lzwork=lzwork) + nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, zwork, info \ + = out + if info < 0: + error_text = "The following argument had an illegal value: " + \ + arg_list[info-1] e = ValueError(error_text) - e.info = out[-1] + e.info = info raise e - return out[:-1] + return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, + int(zwork[0])) def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): """ nr,Ar,Br,Cr,hsv = ab09ad(dico,job,equil,n,m,p,A,B,C,[nr,tol,ldwork]) @@ -817,7 +831,7 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): """ nr,Ar,Br,Cr,Dr,hsv = ab09bd(dico,job,equil,n,m,p,A,B,C,D,[nr,tol1,tol2,ldwork]) - + To compute a reduced order model (Ar,Br,Cr,Dr) for a stable original state-space representation (A,B,C,D) by using either the square-root or the balancing-free square-root Singular @@ -1000,7 +1014,7 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): The number of system outputs. p >= 0. A : input rank-2 array('d'), dimension (n,n) On entry, the leading N-by-N part of this array must - contain the state dynamics matrix A. + contain the state dynamics matrix A. B : input rank-2 array('d'), dimension (n,m) On entry, the leading N-by-M part of this array must contain the original input/state matrix B. @@ -1144,7 +1158,7 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork=None): """ nr,Ar,Br,Cr,Dr,ns,hsv = ab09nd(dico,job,equil,n,m,p,A,B,C,D,[alpha,nr,tol1,tol2,ldwork]) - + To compute a reduced order model (Ar,Br,Cr,Dr) for an original state-space representation (A,B,C,D) by using either the square-root or the balancing-free square-root Singular @@ -1662,23 +1676,23 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) To extract from the system pencil - + ( A-lambda*E B ) S(lambda) = ( ) ( C D ) - + a regular pencil Af-lambda*Ef which has the finite Smith zeros of S(lambda) as generalized eigenvalues. The routine also computes the orders of the infinite Smith zeros and determines the singular and infinite Kronecker structure of system pencil, i.e., the right and left Kronecker indices, and the multiplicities of infinite eigenvalues. - + Required arguments: l : input int The number of rows of matrices A, B, and E. l >= 0. n : input int - The number of columns of matrices A, E, and C. n >= 0. + The number of columns of matrices A, E, and C. n >= 0. m : input int The number of columns of matrix B. m >= 0. p : input int @@ -1746,10 +1760,10 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): """ hidden = ' (hidden by the wrapper)' arg_list = ['equil', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nfz', 'nrank', 'niz', 'dinfz', 'nkror', 'ninfe', 'nkrol', 'infz', 'kronr', 'infe', 'kronl', 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] - + if equil != 'S' and equil != 'N': raise ValueError('Parameter equil had an illegal value') - + if ldwork is None: ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)) if equil == 'S': From 21418b7d38a0b6d2a2da850103435af8bd3b70c0 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 03:04:43 +0200 Subject: [PATCH 127/405] extend tests for ab08nX --- slycot/tests/test_ab08n.py | 102 ++++++++++++++++++++++--------------- 1 file changed, 62 insertions(+), 40 deletions(-) diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py index 1823f1cc..a5773e4e 100644 --- a/slycot/tests/test_ab08n.py +++ b/slycot/tests/test_ab08n.py @@ -5,53 +5,75 @@ from slycot import analysis import numpy as np -from numpy.testing import assert_raises, assert_almost_equal, assert_equal +from scipy.linalg import eig +from numpy.testing import assert_equal, assert_allclose -# test input parameters -test_A = np.array([[1, 0, 0, 0, 0, 0], - [0, 1, 0, 0, 0, 0], - [0, 0, 3, 0, 0, 0], - [0, 0, 0,-4, 0, 0], - [0, 0, 0, 0,-1, 0], - [0, 0, 0, 0, 1, 3]]) - -test_B = np.array([[0 , -1], - [-1, 0], - [ 1, -1], - [ 0, 0], - [ 0, 1], - [-1, -1]]) - -test_C = np.array([[1, 0, 0, 1, 0, 0], - [0, 1, 0, 1, 0, 1], - [0, 0, 1, 0, 0, 1]]) - -test_D = np.zeros((3, 2)) - -test_A = test_A.astype(np.complex128) -test_B = test_B.astype(np.complex128) -test_C = test_C.astype(np.complex128) -test_D = test_D.astype(np.complex128) - - class test_ab08n(unittest.TestCase): - """ test1 to 4: Verify ag08bd with input parameters according to example in documentation """ + """ ag08nX with input parameters according to example in documentation """ + + A = np.diag([1., 1., 3., -4., -1., 3.]) + + B = np.array([[ 0., -1.], + [-1., 0.], + [ 1., -1.], + [ 0., 0.], + [ 0., 1.], + [-1., -1.]]) + + C = np.array([[1., 0., 0., 1., 0., 0.], + [0., 1., 0., 1., 0., 1.], + [0., 0., 1., 0., 0., 1.]]) + + D = np.zeros((3, 2)) + + def normalize(self, w): + wi = np.flip(np.argsort(np.abs(w))) + wn = w[wi]/w[wi[0]] + return wn + + def ab08nX(self, ab08fun, A, B, C, D): + n = 6 + m = 2 + p = 3 + # Check the observability and compute the ordered set of + # the observability indices (call the routine with M = 0). + out = ab08fun(n, 0, p, A, B, C, D) + nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf = out[:10] + + assert_equal(kronl[:nkrol], np.array([1, 2, 2])) + assert_equal(n-nu, 5) + assert_allclose(Af[:nu, :nu], np.array([[-1.]])) + # Check the controllability and compute the ordered set of + # the controllability indices (call the routine with P = 0) + out = ab08fun(n, m, 0, A, B, C, D) + nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf = out[:10] + assert_equal(kronr[:nkror], np.array([2, 3])) + assert_equal(n-nu, 5) + assert_allclose(Af[:nu, :nu], np.array([[-4.]])) + # Compute the structural invariants of the given system. + out = ab08fun(n, m, p, A, B, C, D) + nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf = out[:10] + assert_equal(nu, 2) + # Compute the invariant zeros of the given system. + w = eig(Af[:nu, :nu], Bf[:nu, :nu], left=False, right=False) + w_ref = np.array([-2., 1.]) + assert_allclose(self.normalize(w), self.normalize(w_ref)) + # the examples value of infinite zeros does not match the code + # compare output formats to given strings + # assert_equal(sum(infz[:dinfz]), 2) + # assert_equal([[infz[i], i+1] for i in range(dinfz)], [[1, 1]]) + assert_equal(nkror, 0) + assert_equal(nkrol, 1) + assert_equal(kronl[:nkrol], np.array([2])) def test_ab08nd(self): - #test [A-lambda*E] - #B,C,D must have correct dimensions according to l,n,m and p, but cannot have zero length in any dimenstion. Then the wrapper will complain. The length is then set to one. - - nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = analysis.ab08nd(6,2,3,test_A,test_B,test_C,test_D) + self.ab08nX(analysis.ab08nd, self.A, self.B, self.C, self.D) def test_ab08nz(self): - #test [A-lambda*E] - #B,C,D must have correct dimensions according to l,n,m and p, but cannot have zero length in any dimenstion. Then the wrapper will complain. The length is then set to one. - nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = analysis.ab08nz(6,2,3,test_A,test_B,test_C,test_D) - - -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + Ac, Bc, Cc, Dc = [M.astype(np.complex128) for M in [self.A, self.B, + self.C, self.D]] + self.ab08nX(analysis.ab08nz, Ac, Bc, Cc, Dc) if __name__ == "__main__": From 911a9db1aa712180f0edb42208d86b8637f1311a Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 03:13:05 +0200 Subject: [PATCH 128/405] fix docstring --- slycot/tests/test_ab08n.py | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py index a5773e4e..bdeb0b88 100644 --- a/slycot/tests/test_ab08n.py +++ b/slycot/tests/test_ab08n.py @@ -10,7 +10,8 @@ class test_ab08n(unittest.TestCase): - """ ag08nX with input parameters according to example in documentation """ + """ Test regular pencil construction ab08nX with input parameters + according to example in documentation """ A = np.diag([1., 1., 3., -4., -1., 3.]) @@ -68,9 +69,11 @@ def ab08nX(self, ab08fun, A, B, C, D): assert_equal(kronl[:nkrol], np.array([2])) def test_ab08nd(self): + "Test Construct regular pencil for real matrices" self.ab08nX(analysis.ab08nd, self.A, self.B, self.C, self.D) def test_ab08nz(self): + "Test Construct regular pencil for (pseudo) complex matrices" Ac, Bc, Cc, Dc = [M.astype(np.complex128) for M in [self.A, self.B, self.C, self.D]] self.ab08nX(analysis.ab08nz, Ac, Bc, Cc, Dc) From be079985540919c1a9d55b9e3ce8492a3ee78624 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 13:24:11 +0200 Subject: [PATCH 129/405] remove complex warning in ab08nz --- slycot/analysis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 96acc378..31bf0238 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -575,7 +575,7 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): e.info = info raise e return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, - int(zwork[0])) + int(zwork[0].real)) def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): """ nr,Ar,Br,Cr,hsv = ab09ad(dico,job,equil,n,m,p,A,B,C,[nr,tol,ldwork]) From cf6c13e7a635fab369fc988fadb3dc27147b75da Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 10 Apr 2020 13:15:31 +0200 Subject: [PATCH 130/405] add the test file to CMakeLists.txt --- slycot/tests/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 8c7f26d1..0b021358 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -2,6 +2,7 @@ set(PYSOURCE __init__.py test.py + test_ab08n.py test_ag08bd.py test_mb.py test_mc.py From ee1f0190ed0aafee79cab5254c94ef7773d0c4c0 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Sat, 11 Apr 2020 16:21:40 +0200 Subject: [PATCH 131/405] readd tolerance calculation docstring, reformat lzwork docstring --- slycot/analysis.py | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 31bf0238..76c63ba8 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -514,12 +514,21 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): which is defined as the order of the largest leading (or trailing) triangular submatrix in the QR (or RQ) factorization with column (or row) pivoting whose estimated condition number is less than 1/tol. + If tol is set to less than SQRT((N+P)*(N+M))*EPS + then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, + where EPS is the machine precision (see LAPACK Library + Routine DLAMCH). lzwork := None input int - The length of the cache array zwork. The default value is calculated - to MAX( 1, MIN(P,M) + MAX(3*M-1,N), - MIN(P,N) + MAX(3*P-1,N+P,N+M), - MIN(M,N) + MAX(3*M-1,N+M) ) - for optimum performance should be larger. + The length of the internal cache array ZWORK. The default value is + calculated to + MAX( 1, + MIN(P,M) + MAX(3*M-1,N), + MIN(P,N) + MAX(3*P-1,N+P,N+M), + MIN(M,N) + MAX(3*M-1,N+M) ) + For optimum performance lzwork should be larger. + If lzwork = -1, then a workspace query is assumed; + the routine only calculates the optimal size of the + ZWORK array, and returns this value in lzwork_opt Return objects: nu : int The number of (finite) invariant zeros. @@ -577,6 +586,7 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, int(zwork[0].real)) + def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): """ nr,Ar,Br,Cr,hsv = ab09ad(dico,job,equil,n,m,p,A,B,C,[nr,tol,ldwork]) From ac53a0a744a73450daa23ef7bf8cfae5bcb01e5d Mon Sep 17 00:00:00 2001 From: bnavigator Date: Fri, 3 Apr 2020 19:25:07 +0200 Subject: [PATCH 132/405] switch to pytest for python-control on travis, combine coverage for coveralls --- .coveragerc | 11 ++++++++++- .travis.yml | 24 ++++++++++++++++-------- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/.coveragerc b/.coveragerc index 5841bd04..7f5d53d6 100644 --- a/.coveragerc +++ b/.coveragerc @@ -1,3 +1,12 @@ [run] source = slycot -omit = */tests/* +omit = + */tests/* + */version.py + + +# please do not add any sections after this block +# the CI will add the slycot modules as last line here +[paths] +source = + slycot/ diff --git a/.travis.yml b/.travis.yml index 58774911..53a96738 100644 --- a/.travis.yml +++ b/.travis.yml @@ -138,16 +138,24 @@ install: script: # slycots own unit tests as installed, not those from source dir - - cd .. + - mkdir ../slycot-coverage + - cd ../slycot-coverage - slycot_dir=$(python -c "import slycot; print(slycot.__path__[0])") - - pytest --pyargs slycot --cov=$slycot_dir --cov-config=Slycot/.coveragerc - # - # As a deeper set of tests, get test against python-control as well + - pytest --pyargs slycot --cov=$slycot_dir --cov-config=../Slycot/.coveragerc # - # Get python-control from source and install - - git clone --depth 1 https://github.com/python-control/python-control.git control - - cd control - - python setup.py test + # As a deeper set of tests, use the suite from python-control master branch as well + - cd .. + - git clone --depth 1 https://github.com/python-control/python-control.git + - cd python-control + - pytest --disable-warnings --cov=$slycot_dir --cov-config=../Slycot/.coveragerc control/tests + after_success: + # go back to Slycot dir and merge the coverage to report correct repo data with coveralls + - cd ../Slycot + - cp ../slycot-coverage/.coverage .coverage.slycot + - cp ../python-control/.coverage .coverage.control + - echo " $slycot_dir" >> .coveragerc + - coverage combine + - coverage report - coveralls From 7a14759ae369897004dc9088caa099a802494b1e Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 13 Apr 2020 15:05:41 +0200 Subject: [PATCH 133/405] map logical to 1 or 0 independent of compiler in mc01td --- slycot/CMakeLists.txt | 198 +++++++++++++++++++++------------------- slycot/math.py | 30 +++--- slycot/src/_helper.pyf | 10 ++ slycot/src/_wrapper.pyf | 5 +- slycot/src/ftruefalse.f | 14 +++ 5 files changed, 146 insertions(+), 111 deletions(-) create mode 100644 slycot/src/_helper.pyf create mode 100644 slycot/src/ftruefalse.f diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 9819de59..fd84ef0b 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -6,106 +6,112 @@ set(FSOURCES - src/AB01MD.f src/MA02AD.f src/MB03YT.f src/NF01BW.f src/SB10KD.f - src/AB01ND.f src/MA02BD.f src/MB03ZA.f src/NF01BX.f src/SB10LD.f - src/AB01OD.f src/MA02BZ.f src/MB03ZD.f src/NF01BY.f src/SB10MD.f - src/AB04MD.f src/MA02CD.f src/MB04DD.f src/SB01BD.f src/SB10PD.f - src/AB05MD.f src/MA02CZ.f src/MB04DI.f src/SB01BX.f src/SB10QD.f - src/AB05ND.f src/MA02DD.f src/MB04DS.f src/SB01BY.f src/SB10RD.f - src/AB05OD.f src/MA02ED.f src/MB04DY.f src/SB01DD.f src/SB10SD.f - src/AB05PD.f src/MA02FD.f src/MB04GD.f src/SB01FY.f src/SB10TD.f - src/AB05QD.f src/MA02GD.f src/MB04ID.f src/SB01MD.f src/SB10UD.f - src/AB05RD.f src/MA02HD.f src/MB04IY.f src/SB02CX.f src/SB10VD.f - src/AB05SD.f src/MA02ID.f src/MB04IZ.f src/SB02MD.f src/SB10WD.f - src/AB07MD.f src/MA02JD.f src/MB04JD.f src/SB02MR.f src/SB10YD.f - src/AB07ND.f src/MB01MD.f src/MB04KD.f src/SB02MS.f src/SB10ZD.f - src/AB08MD.f src/MB01ND.f src/MB04LD.f src/SB02MT.f src/SB10ZP.f - src/AB08MZ.f src/MB01PD.f src/MB04MD.f src/SB02MU.f src/SB16AD.f - src/AB08ND.f src/MB01QD.f src/MB04ND.f src/SB02MV.f src/SB16AY.f - src/AB08NX.f src/MB01RD.f src/MB04NY.f src/SB02MW.f src/SB16BD.f - src/AB08NZ.f src/MB01RU.f src/MB04OD.f src/SB02ND.f src/SB16CD.f - src/AB09AD.f src/MB01RW.f src/MB04OW.f src/SB02OD.f src/SB16CY.f - src/AB09AX.f src/MB01RX.f src/MB04OX.f src/SB02OU.f src/select.f - src/AB09BD.f src/MB01RY.f src/MB04OY.f src/SB02OV.f src/SG02AD.f - src/AB09BX.f src/MB01SD.f src/MB04PA.f src/SB02OW.f src/SG03AD.f - src/AB09CD.f src/MB01TD.f src/MB04PB.f src/SB02OX.f src/SG03AX.f - src/AB09CX.f src/MB01UD.f src/MB04PU.f src/SB02OY.f src/SG03AY.f - src/AB09DD.f src/MB01UW.f src/MB04PY.f src/SB02PD.f src/SG03BD.f - src/AB09ED.f src/MB01UX.f src/MB04QB.f src/SB02QD.f src/SG03BU.f - src/AB09FD.f src/MB01VD.f src/MB04QC.f src/SB02RD.f src/SG03BV.f - src/AB09GD.f src/MB01WD.f src/MB04QF.f src/SB02RU.f src/SG03BW.f - src/AB09HD.f src/MB01XD.f src/MB04QU.f src/SB02SD.f src/SG03BX.f - src/AB09HX.f src/MB01XY.f src/MB04TB.f src/SB03MD.f src/SG03BY.f - src/AB09HY.f src/MB01YD.f src/MB04TS.f src/SB03MU.f - src/SLCT_DLATZM.f src/AB09ID.f src/MB01ZD.f src/MB04TT.f - src/SB03MV.f src/SLCT_ZLATZM.f src/AB09IX.f src/MB02CD.f - src/MB04TU.f src/SB03MW.f src/TB01ID.f src/AB09IY.f src/MB02CU.f - src/MB04TV.f src/SB03MX.f src/TB01IZ.f src/AB09JD.f src/MB02CV.f - src/MB04TW.f src/SB03MY.f src/TB01KD.f src/AB09JV.f src/MB02CX.f - src/MB04TX.f src/SB03OD.f src/TB01LD.f src/AB09JW.f src/MB02CY.f - src/MB04TY.f src/SB03OR.f src/TB01MD.f src/AB09JX.f src/MB02DD.f - src/MB04UD.f src/SB03OT.f src/TB01ND.f src/AB09KD.f src/MB02ED.f - src/MB04VD.f src/SB03OU.f src/TB01PD.f src/AB09KX.f src/MB02FD.f - src/MB04VX.f src/SB03OV.f src/TB01TD.f src/AB09MD.f src/MB02GD.f - src/MB04WD.f src/SB03OY.f src/TB01TY.f src/AB09ND.f src/MB02HD.f - src/MB04WP.f src/SB03PD.f src/TB01UD.f src/AB13AD.f src/MB02ID.f - src/MB04WR.f src/SB03QD.f src/TB01VD.f src/AB13AX.f src/MB02JD.f - src/MB04WU.f src/SB03QX.f src/TB01VY.f src/AB13BD.f src/MB02JX.f - src/MB04XD.f src/SB03QY.f src/TB01WD.f src/AB13CD.f src/MB02KD.f - src/MB04XY.f src/SB03RD.f src/TB01XD.f src/AB13DD.f src/MB02MD.f - src/MB04YD.f src/SB03SD.f src/TB01XZ.f src/AB13DX.f src/MB02ND.f - src/MB04YW.f src/SB03SX.f src/TB01YD.f src/AB13ED.f src/MB02NY.f - src/MB04ZD.f src/SB03SY.f src/TB01ZD.f src/AB13FD.f src/MB02OD.f - src/MB05MD.f src/SB03TD.f src/TB03AD.f src/AB13MD.f src/MB02PD.f - src/MB05MY.f src/SB03UD.f src/TB03AY.f src/AB8NXZ.f src/MB02QD.f - src/MB05ND.f src/SB04MD.f src/TB04AD.f src/AG07BD.f src/MB02QY.f - src/MB05OD.f src/SB04MR.f src/TB04AY.f src/AG08BD.f src/MB02RD.f - src/MB05OY.f src/SB04MU.f src/TB04BD.f src/AG08BY.f src/MB02RZ.f - src/MB3OYZ.f src/SB04MW.f src/TB04BV.f src/AG08BZ.f src/MB02SD.f - src/MB3PYZ.f src/SB04MY.f src/TB04BW.f src/AG8BYZ.f src/MB02SZ.f - src/MC01MD.f src/SB04ND.f src/TB04BX.f src/BB01AD.f src/MB02TD.f - src/MC01ND.f src/SB04NV.f src/TB04CD.f src/BB02AD.f src/MB02TZ.f - src/MC01OD.f src/SB04NW.f src/TB05AD.f src/BB03AD.f src/MB02UD.f - src/MC01PD.f src/SB04NX.f src/TC01OD.f src/BB04AD.f src/MB02UU.f - src/MC01PY.f src/SB04NY.f src/TC04AD.f src/BD01AD.f src/MB02UV.f - src/MC01QD.f src/SB04OD.f src/TC05AD.f src/BD02AD.f src/MB02VD.f - src/MC01RD.f src/SB04OW.f src/TD03AD.f src/DE01OD.f src/MB02WD.f - src/MC01SD.f src/SB04PD.f src/TD03AY.f src/DE01PD.f src/MB02XD.f - src/MC01SW.f src/SB04PX.f src/TD04AD.f src/delctg.f src/MB02YD.f - src/MC01SX.f src/SB04PY.f src/TD05AD.f src/DF01MD.f src/MB03MD.f - src/MC01SY.f src/SB04QD.f src/TF01MD.f src/DG01MD.f src/MB03MY.f - src/MC01TD.f src/SB04QR.f src/TF01MX.f src/DG01ND.f src/MB03ND.f - src/MC01VD.f src/SB04QU.f src/TF01MY.f src/DG01NY.f src/MB03NY.f - src/MC01WD.f src/SB04QY.f src/TF01ND.f src/DG01OD.f src/MB03OD.f - src/MC03MD.f src/SB04RD.f src/TF01OD.f src/DK01MD.f src/MB03OY.f - src/MC03ND.f src/SB04RV.f src/TF01PD.f src/FB01QD.f src/MB03PD.f - src/MC03NX.f src/SB04RW.f src/TF01QD.f src/FB01RD.f src/MB03PY.f - src/MC03NY.f src/SB04RX.f src/TF01RD.f src/FB01SD.f src/MB03QD.f - src/MD03AD.f src/SB04RY.f src/TG01AD.f src/FB01TD.f src/MB03QX.f - src/MD03BA.f src/SB06ND.f src/TG01AZ.f src/FB01VD.f src/MB03QY.f - src/MD03BB.f src/SB08CD.f src/TG01BD.f src/FD01AD.f src/MB03RD.f - src/MD03BD.f src/SB08DD.f src/TG01CD.f src/IB01AD.f src/MB03RX.f - src/MD03BF.f src/SB08ED.f src/TG01DD.f src/IB01BD.f src/MB03RY.f - src/MD03BX.f src/SB08FD.f src/TG01ED.f src/IB01CD.f src/MB03SD.f - src/MD03BY.f src/SB08GD.f src/TG01FD.f src/IB01MD.f src/MB03TD.f - src/NF01AD.f src/SB08HD.f src/TG01FZ.f src/IB01MY.f src/MB03TS.f - src/NF01AY.f src/SB08MD.f src/TG01HD.f src/IB01ND.f src/MB03UD.f - src/NF01BA.f src/SB08MY.f src/TG01HX.f src/IB01OD.f src/MB03VD.f - src/NF01BB.f src/SB08ND.f src/TG01ID.f src/IB01OY.f src/MB03VY.f - src/NF01BD.f src/SB08NY.f src/TG01JD.f src/IB01PD.f src/MB03WA.f - src/NF01BE.f src/SB09MD.f src/TG01WD.f src/IB01PX.f src/MB03WD.f - src/NF01BF.f src/SB10AD.f src/UD01BD.f src/IB01PY.f src/MB03WX.f - src/NF01BP.f src/SB10DD.f src/UD01CD.f src/IB01QD.f src/MB03XD.f - src/NF01BQ.f src/SB10ED.f src/UD01DD.f src/IB01RD.f src/MB03XP.f - src/NF01BR.f src/SB10FD.f src/UD01MD.f src/IB03AD.f src/MB03XU.f - src/NF01BS.f src/SB10HD.f src/UD01MZ.f src/IB03BD.f src/MB03YA.f - src/NF01BU.f src/SB10ID.f src/UD01ND.f src/MA01AD.f src/MB03YD.f - src/NF01BV.f src/SB10JD.f src/UE01MD.f) + src/AB01MD.f src/AB01ND.f src/AB01OD.f src/AB04MD.f src/AB05MD.f + src/AB05ND.f src/AB05OD.f src/AB05PD.f src/AB05QD.f src/AB05RD.f + src/AB05SD.f src/AB07MD.f src/AB07ND.f src/AB08MD.f src/AB08MZ.f + src/AB08ND.f src/AB08NX.f src/AB08NZ.f src/AB09AD.f src/AB09AX.f + src/AB09BD.f src/AB09BX.f src/AB09CD.f src/AB09CX.f src/AB09DD.f + src/AB09ED.f src/AB09FD.f src/AB09GD.f src/AB09HD.f src/AB09HX.f + src/AB09HY.f src/AB09ID.f src/AB09IX.f src/AB09IY.f src/AB09JD.f + src/AB09JV.f src/AB09JW.f src/AB09JX.f src/AB09KD.f src/AB09KX.f + src/AB09MD.f src/AB09ND.f src/AB13AD.f src/AB13AX.f src/AB13BD.f + src/AB13CD.f src/AB13DD.f src/AB13DX.f src/AB13ED.f src/AB13FD.f + src/AB13MD.f src/AB8NXZ.f src/AG07BD.f src/AG08BD.f src/AG08BY.f + src/AG08BZ.f src/AG8BYZ.f src/BB01AD.f src/BB02AD.f src/BB03AD.f + src/BB04AD.f src/BD01AD.f src/BD02AD.f src/DE01OD.f src/DE01PD.f + src/DF01MD.f src/DG01MD.f src/DG01ND.f src/DG01NY.f src/DG01OD.f + src/DK01MD.f src/FB01QD.f src/FB01RD.f src/FB01SD.f src/FB01TD.f + src/FB01VD.f src/FD01AD.f src/IB01AD.f src/IB01BD.f src/IB01CD.f + src/IB01MD.f src/IB01MY.f src/IB01ND.f src/IB01OD.f src/IB01OY.f + src/IB01PD.f src/IB01PX.f src/IB01PY.f src/IB01QD.f src/IB01RD.f + src/IB03AD.f src/IB03BD.f src/MA01AD.f src/MA02AD.f src/MA02BD.f + src/MA02BZ.f src/MA02CD.f src/MA02CZ.f src/MA02DD.f src/MA02ED.f + src/MA02FD.f src/MA02GD.f src/MA02HD.f src/MA02ID.f src/MA02JD.f + src/MB01MD.f src/MB01ND.f src/MB01PD.f src/MB01QD.f src/MB01RD.f + src/MB01RU.f src/MB01RW.f src/MB01RX.f src/MB01RY.f src/MB01SD.f + src/MB01TD.f src/MB01UD.f src/MB01UW.f src/MB01UX.f src/MB01VD.f + src/MB01WD.f src/MB01XD.f src/MB01XY.f src/MB01YD.f src/MB01ZD.f + src/MB02CD.f src/MB02CU.f src/MB02CV.f src/MB02CX.f src/MB02CY.f + src/MB02DD.f src/MB02ED.f src/MB02FD.f src/MB02GD.f src/MB02HD.f + src/MB02ID.f src/MB02JD.f src/MB02JX.f src/MB02KD.f src/MB02MD.f + src/MB02ND.f src/MB02NY.f src/MB02OD.f src/MB02PD.f src/MB02QD.f + src/MB02QY.f src/MB02RD.f src/MB02RZ.f src/MB02SD.f src/MB02SZ.f + src/MB02TD.f src/MB02TZ.f src/MB02UD.f src/MB02UU.f src/MB02UV.f + src/MB02VD.f src/MB02WD.f src/MB02XD.f src/MB02YD.f src/MB03MD.f + src/MB03MY.f src/MB03ND.f src/MB03NY.f src/MB03OD.f src/MB03OY.f + src/MB03PD.f src/MB03PY.f src/MB03QD.f src/MB03QX.f src/MB03QY.f + src/MB03RD.f src/MB03RX.f src/MB03RY.f src/MB03SD.f src/MB03TD.f + src/MB03TS.f src/MB03UD.f src/MB03VD.f src/MB03VY.f src/MB03WA.f + src/MB03WD.f src/MB03WX.f src/MB03XD.f src/MB03XP.f src/MB03XU.f + src/MB03YA.f src/MB03YD.f src/MB03YT.f src/MB03ZA.f src/MB03ZD.f + src/MB04DD.f src/MB04DI.f src/MB04DS.f src/MB04DY.f src/MB04GD.f + src/MB04ID.f src/MB04IY.f src/MB04IZ.f src/MB04JD.f src/MB04KD.f + src/MB04LD.f src/MB04MD.f src/MB04ND.f src/MB04NY.f src/MB04OD.f + src/MB04OW.f src/MB04OX.f src/MB04OY.f src/MB04PA.f src/MB04PB.f + src/MB04PU.f src/MB04PY.f src/MB04QB.f src/MB04QC.f src/MB04QF.f + src/MB04QU.f src/MB04TB.f src/MB04TS.f src/MB04TT.f src/MB04TU.f + src/MB04TV.f src/MB04TW.f src/MB04TX.f src/MB04TY.f src/MB04UD.f + src/MB04VD.f src/MB04VX.f src/MB04WD.f src/MB04WP.f src/MB04WR.f + src/MB04WU.f src/MB04XD.f src/MB04XY.f src/MB04YD.f src/MB04YW.f + src/MB04ZD.f src/MB05MD.f src/MB05MY.f src/MB05ND.f src/MB05OD.f + src/MB05OY.f src/MB3OYZ.f src/MB3PYZ.f src/MC01MD.f src/MC01ND.f + src/MC01OD.f src/MC01PD.f src/MC01PY.f src/MC01QD.f src/MC01RD.f + src/MC01SD.f src/MC01SW.f src/MC01SX.f src/MC01SY.f src/MC01TD.f + src/MC01VD.f src/MC01WD.f src/MC03MD.f src/MC03ND.f src/MC03NX.f + src/MC03NY.f src/MD03AD.f src/MD03BA.f src/MD03BB.f src/MD03BD.f + src/MD03BF.f src/MD03BX.f src/MD03BY.f src/NF01AD.f src/NF01AY.f + src/NF01BA.f src/NF01BB.f src/NF01BD.f src/NF01BE.f src/NF01BF.f + src/NF01BP.f src/NF01BQ.f src/NF01BR.f src/NF01BS.f src/NF01BU.f + src/NF01BV.f src/NF01BW.f src/NF01BX.f src/NF01BY.f src/SB01BD.f + src/SB01BX.f src/SB01BY.f src/SB01DD.f src/SB01FY.f src/SB01MD.f + src/SB02CX.f src/SB02MD.f src/SB02MR.f src/SB02MS.f src/SB02MT.f + src/SB02MU.f src/SB02MV.f src/SB02MW.f src/SB02ND.f src/SB02OD.f + src/SB02OU.f src/SB02OV.f src/SB02OW.f src/SB02OX.f src/SB02OY.f + src/SB02PD.f src/SB02QD.f src/SB02RD.f src/SB02RU.f src/SB02SD.f + src/SB03MD.f src/SB03MU.f src/SB03MV.f src/SB03MW.f src/SB03MX.f + src/SB03MY.f src/SB03OD.f src/SB03OR.f src/SB03OT.f src/SB03OU.f + src/SB03OV.f src/SB03OY.f src/SB03PD.f src/SB03QD.f src/SB03QX.f + src/SB03QY.f src/SB03RD.f src/SB03SD.f src/SB03SX.f src/SB03SY.f + src/SB03TD.f src/SB03UD.f src/SB04MD.f src/SB04MR.f src/SB04MU.f + src/SB04MW.f src/SB04MY.f src/SB04ND.f src/SB04NV.f src/SB04NW.f + src/SB04NX.f src/SB04NY.f src/SB04OD.f src/SB04OW.f src/SB04PD.f + src/SB04PX.f src/SB04PY.f src/SB04QD.f src/SB04QR.f src/SB04QU.f + src/SB04QY.f src/SB04RD.f src/SB04RV.f src/SB04RW.f src/SB04RX.f + src/SB04RY.f src/SB06ND.f src/SB08CD.f src/SB08DD.f src/SB08ED.f + src/SB08FD.f src/SB08GD.f src/SB08HD.f src/SB08MD.f src/SB08MY.f + src/SB08ND.f src/SB08NY.f src/SB09MD.f src/SB10AD.f src/SB10DD.f + src/SB10ED.f src/SB10FD.f src/SB10HD.f src/SB10ID.f src/SB10JD.f + src/SB10KD.f src/SB10LD.f src/SB10MD.f src/SB10PD.f src/SB10QD.f + src/SB10RD.f src/SB10SD.f src/SB10TD.f src/SB10UD.f src/SB10VD.f + src/SB10WD.f src/SB10YD.f src/SB10ZD.f src/SB10ZP.f src/SB16AD.f + src/SB16AY.f src/SB16BD.f src/SB16CD.f src/SB16CY.f src/SG02AD.f + src/SG03AD.f src/SG03AX.f src/SG03AY.f src/SG03BD.f src/SG03BU.f + src/SG03BV.f src/SG03BW.f src/SG03BX.f src/SG03BY.f src/TB01ID.f + src/TB01IZ.f src/TB01KD.f src/TB01LD.f src/TB01MD.f src/TB01ND.f + src/TB01PD.f src/TB01TD.f src/TB01TY.f src/TB01UD.f src/TB01VD.f + src/TB01VY.f src/TB01WD.f src/TB01XD.f src/TB01XZ.f src/TB01YD.f + src/TB01ZD.f src/TB03AD.f src/TB03AY.f src/TB04AD.f src/TB04AY.f + src/TB04BD.f src/TB04BV.f src/TB04BW.f src/TB04BX.f src/TB04CD.f + src/TB05AD.f src/TC01OD.f src/TC04AD.f src/TC05AD.f src/TD03AD.f + src/TD03AY.f src/TD04AD.f src/TD05AD.f src/TF01MD.f src/TF01MX.f + src/TF01MY.f src/TF01ND.f src/TF01OD.f src/TF01PD.f src/TF01QD.f + src/TF01RD.f src/TG01AD.f src/TG01AZ.f src/TG01BD.f src/TG01CD.f + src/TG01DD.f src/TG01ED.f src/TG01FD.f src/TG01FZ.f src/TG01HD.f + src/TG01HX.f src/TG01ID.f src/TG01JD.f src/TG01WD.f src/UD01BD.f + src/UD01CD.f src/UD01DD.f src/UD01MD.f src/UD01MZ.f src/UD01ND.f + src/UE01MD.f + + src/delctg.f src/select.f + src/SLCT_DLATZM.f src/SLCT_ZLATZM.f + + src/ftruefalse.f +) set(F2PYSOURCE src/_wrapper.pyf) set(F2PYSOURCE_DEPS src/analysis.pyf src/math.pyf - src/transform.pyf src/synthesis.pyf) + src/transform.pyf src/synthesis.pyf + src/_helper.pyf) configure_file(version.py.in version.py @ONLY) diff --git a/slycot/math.py b/slycot/math.py index 78808210..86a92df3 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -20,7 +20,8 @@ from . import _wrapper import warnings -def mc01td(dico,dp,p): + +def mc01td(dico, dp, p): """ dp,stable,nz = mc01td(dico,dp,p) To determine whether or not a given polynomial P(x) with real @@ -53,21 +54,24 @@ def mc01td(dico,dp,p): The number of unstable zeros. """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK', 'IWARN'+hidden, - 'INFO'+hidden] - out = _wrapper.mc01td(dico,dp,p) - if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] + arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, + 'IWARN', 'INFO'] + (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) + if info < 0: + fmt = "The following argument had an illegal value: '{}'" + e = ValueError(fmt.format(arg_list[-info - 1])) + e.info = info raise e - if out[-1] == 1: + if info == 1: warnings.warn('entry P(x) is the zero polynomial.') - if out[-1] == 2: + if info == 2: warnings.warn('P(x) may have zeros very close to stability boundary.') - if out[-2] > 0: - warnings.warn('The degree of P(x) has been reduced to %i' %(dp-out[-2])) - return out[:-2] + if iwarn > 0: + fmt = 'The degree of P(x) has been reduced to {:d}' + warnings.warn(fmt.format(dp - iwarn)) + ftrue, ffalse = _wrapper.ftruefalse() + stable = 1 if stable_log == ftrue else 0 + return (dp_out, stable, nz) def mb03vd(n, ilo, ihi, A): diff --git a/slycot/src/_helper.pyf b/slycot/src/_helper.pyf new file mode 100644 index 00000000..ed59e106 --- /dev/null +++ b/slycot/src/_helper.pyf @@ -0,0 +1,10 @@ +! -*- f90 -*- +! Note: the context of this file is case sensitive. + +subroutine ftruefalse(ftrue,ffalse) ! in src/ftruefalse.f + logical intent(out) :: ftrue + logical intent(out) :: ffalse +end subroutine ftruefalse + +! This file was auto-generated with f2py (version:2). +! See http://cens.ioc.ee/projects/f2py2e/ diff --git a/slycot/src/_wrapper.pyf b/slycot/src/_wrapper.pyf index af1557f6..5a4c6784 100644 --- a/slycot/src/_wrapper.pyf +++ b/slycot/src/_wrapper.pyf @@ -1,11 +1,12 @@ ! -*- f90 -*- ! Note: the context of this file is case sensitive. -python module _wrapper ! in +python module _wrapper ! in interface ! in :wrapper include "analysis.pyf" include "math.pyf" include "synthesis.pyf" include "transform.pyf" - end interface + include "_helper.pyf" + end interface end python module slycot diff --git a/slycot/src/ftruefalse.f b/slycot/src/ftruefalse.f new file mode 100644 index 00000000..53d24942 --- /dev/null +++ b/slycot/src/ftruefalse.f @@ -0,0 +1,14 @@ + SUBROUTINE FTRUEFALSE( FTRUE, FFALSE ) +C +C SLYCOT +C Helper Function to map the correct values of .TRUE. and .FALSE. +C + LOGICAL FTRUE + LOGICAL FFALSE +C + FTRUE = .TRUE. + FFALSE = .FALSE. +C + RETURN +C + END From 3fc89348159ff9b0e3f9a29b12cd4a72f098a841 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 13 Apr 2020 16:20:40 +0200 Subject: [PATCH 134/405] move mc01td to its alphabetical place --- slycot/math.py | 105 ++++++++++++++++++++++++------------------------- 1 file changed, 51 insertions(+), 54 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 86a92df3..7913eb08 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -21,59 +21,6 @@ import warnings -def mc01td(dico, dp, p): - """ dp,stable,nz = mc01td(dico,dp,p) - - To determine whether or not a given polynomial P(x) with real - coefficients is stable, either in the continuous-time or discrete- - time case. - - A polynomial is said to be stable in the continuous-time case - if all its zeros lie in the left half-plane, and stable in the - discrete-time case if all its zeros lie inside the unit circle. - - - Required arguments: - dico : input string(len=1) - Indicates whether the stability test to be applied to P(x) is in - the continuous-time or discrete-time case as follows: - = 'C': continuous-time case; - = 'D': discrete-time case. - dp : input int - The degree of the polynomial P(x). dp >= 0. - p : input rank-1 array('d') with bounds (dp + 1) - This array must contain the coefficients of P(x) in increasing - powers of x. - Return objects: - dp : int - If P(dp+1) = 0.0 on entry, then dp contains the index of the highest - power of x for which P(dp+1) <> 0.0. - stable : int - Equal to 1 if P(x) if stable, 0 otherwise. - nz : int - The number of unstable zeros. - """ - hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, - 'IWARN', 'INFO'] - (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) - if info < 0: - fmt = "The following argument had an illegal value: '{}'" - e = ValueError(fmt.format(arg_list[-info - 1])) - e.info = info - raise e - if info == 1: - warnings.warn('entry P(x) is the zero polynomial.') - if info == 2: - warnings.warn('P(x) may have zeros very close to stability boundary.') - if iwarn > 0: - fmt = 'The degree of P(x) has been reduced to {:d}' - warnings.warn(fmt.format(dp - iwarn)) - ftrue, ffalse = _wrapper.ftruefalse() - stable = 1 if stable_log == ftrue else 0 - return (dp_out, stable, nz) - - def mb03vd(n, ilo, ihi, A): """ HQ, Tau = mb03vd(n, ilo, ihi, A) @@ -569,4 +516,54 @@ def mb05nd(a, delta, tol=1e-7): raise e -# to be replaced by python wrappers +def mc01td(dico, dp, p): + """ dp,stable,nz = mc01td(dico,dp,p) + + To determine whether or not a given polynomial P(x) with real + coefficients is stable, either in the continuous-time or discrete- + time case. + + A polynomial is said to be stable in the continuous-time case + if all its zeros lie in the left half-plane, and stable in the + discrete-time case if all its zeros lie inside the unit circle. + + + Required arguments: + dico : input string(len=1) + Indicates whether the stability test to be applied to P(x) is in + the continuous-time or discrete-time case as follows: + = 'C': continuous-time case; + = 'D': discrete-time case. + dp : input int + The degree of the polynomial P(x). dp >= 0. + p : input rank-1 array('d') with bounds (dp + 1) + This array must contain the coefficients of P(x) in increasing + powers of x. + Return objects: + dp : int + If P(dp+1) = 0.0 on entry, then dp contains the index of the highest + power of x for which P(dp+1) <> 0.0. + stable : int + Equal to 1 if P(x) if stable, 0 otherwise. + nz : int + The number of unstable zeros. + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, + 'IWARN', 'INFO'] + (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) + if info < 0: + fmt = "The following argument had an illegal value: '{}'" + e = ValueError(fmt.format(arg_list[-info - 1])) + e.info = info + raise e + if info == 1: + warnings.warn('entry P(x) is the zero polynomial.') + if info == 2: + warnings.warn('P(x) may have zeros very close to stability boundary.') + if iwarn > 0: + fmt = 'The degree of P(x) has been reduced to {:d}' + warnings.warn(fmt.format(dp - iwarn)) + ftrue, ffalse = _wrapper.ftruefalse() + stable = 1 if stable_log == ftrue else 0 + return (dp_out, stable, nz) From 3a24b5afa5b8a7207f20b99ac0b8be45b0ebb9bd Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 13 Apr 2020 17:22:00 +0200 Subject: [PATCH 135/405] mc01td() docstring to numpydoc [skip ci] (except first line for signature and no short summary) --- slycot/math.py | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 7913eb08..c029b6cc 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -468,12 +468,6 @@ def mb05md(a, delta, balanc='N'): e.info = INFO raise e -""" -from slycot import mb05nd -import numpy as np -a = np.mat('[-2. 0; 0.1 -3.]') -mb05nd(a.shape[0], a, 0.1) -""" def mb05nd(a, delta, tol=1e-7): """F, H = mb05nd(n, a, delta, tol=1e-7) @@ -517,7 +511,7 @@ def mb05nd(a, delta, tol=1e-7): def mc01td(dico, dp, p): - """ dp,stable,nz = mc01td(dico,dp,p) + """dp, stable, nz = mc01td(dico, dp, p) To determine whether or not a given polynomial P(x) with real coefficients is stable, either in the continuous-time or discrete- @@ -528,25 +522,31 @@ def mc01td(dico, dp, p): discrete-time case if all its zeros lie inside the unit circle. - Required arguments: - dico : input string(len=1) - Indicates whether the stability test to be applied to P(x) is in - the continuous-time or discrete-time case as follows: + Parameters + ---------- + dico : {'C', 'D'} + Indicates whether the stability test to be applied to `P(x)` is in + the continuous-time or discrete-time case as follows:: + = 'C': continuous-time case; = 'D': discrete-time case. - dp : input int - The degree of the polynomial P(x). dp >= 0. - p : input rank-1 array('d') with bounds (dp + 1) - This array must contain the coefficients of P(x) in increasing - powers of x. - Return objects: + dp : int - If P(dp+1) = 0.0 on entry, then dp contains the index of the highest - power of x for which P(dp+1) <> 0.0. + The degree of the polynomial `P(x)`. ``dp >= 0``. + p : (dp+1,) array_like + This array must contain the coefficients of `P(x)` in increasing + powers of `x`. + + Returns + ------- + dp : int + If ``P(dp+1) = 0.0`` on entry, then `dp` contains the index of the + highest power of `x` for which ``P(dp+1) <> 0.0``. stable : int - Equal to 1 if P(x) if stable, 0 otherwise. + Equal to 1 if `P(x)` is stable, 0 otherwise. nz : int The number of unstable zeros. + """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, From 7ea8f837e98800cdebfcbb54ffd4cb5441d31f17 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 13 Apr 2020 21:12:55 +0200 Subject: [PATCH 136/405] run examples in testsuite --- slycot/tests/CMakeLists.txt | 1 + slycot/tests/test_examples.py | 29 +++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+) create mode 100755 slycot/tests/test_examples.py diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 0b021358..912e9717 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -4,6 +4,7 @@ set(PYSOURCE test.py test_ab08n.py test_ag08bd.py + test_examples.py test_mb.py test_mc.py test_sb10jd.py diff --git a/slycot/tests/test_examples.py b/slycot/tests/test_examples.py new file mode 100755 index 00000000..b926e2ea --- /dev/null +++ b/slycot/tests/test_examples.py @@ -0,0 +1,29 @@ +""" + +test_examples.py + + +""" + +from inspect import getmembers, isfunction +import pytest + +from slycot import examples + +examplefunctions = [fun for (fname, fun) in getmembers(examples) + if isfunction(fun) and "_example" in fname] + + +@pytest.mark.parametrize('examplefun', examplefunctions) +def test_example(examplefun, capsys, recwarn): + """ + Test the examples. + + Test that all the examples work, produce some (unchecked) output but no + exceptions or warnings. + """ + examplefun() + captured = capsys.readouterr() + assert len(captured.out) > 0 + assert not captured.err + assert not recwarn From 5f8c60818ade9c3b8e4d9d063009589495d6f68f Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 13 Apr 2020 23:14:56 +0200 Subject: [PATCH 137/405] clean test files --- slycot/tests/CMakeLists.txt | 3 +- slycot/tests/test.py | 48 ------------------ slycot/tests/test_ag08bd.py | 34 +++++++------ slycot/tests/test_mb.py | 1 + slycot/tests/test_sb.py | 98 +++++++++++++++++++++++++++++++++++++ slycot/tests/test_sb10jd.py | 72 --------------------------- slycot/tests/test_sg02ad.py | 29 ++++++----- slycot/tests/test_tb05ad.py | 6 --- slycot/tests/test_td04ad.py | 30 +++++++----- slycot/tests/test_tg01ad.py | 8 +-- slycot/tests/test_tg01fd.py | 21 ++++---- 11 files changed, 161 insertions(+), 189 deletions(-) delete mode 100644 slycot/tests/test.py create mode 100644 slycot/tests/test_sb.py delete mode 100644 slycot/tests/test_sb10jd.py mode change 100644 => 100755 slycot/tests/test_sg02ad.py diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 912e9717..ec4b5ea1 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -1,13 +1,12 @@ set(PYSOURCE __init__.py - test.py test_ab08n.py test_ag08bd.py test_examples.py test_mb.py test_mc.py - test_sb10jd.py + test_sb.py test_sg02ad.py test_sg03ad.py test_tb05ad.py diff --git a/slycot/tests/test.py b/slycot/tests/test.py deleted file mode 100644 index c12d8689..00000000 --- a/slycot/tests/test.py +++ /dev/null @@ -1,48 +0,0 @@ -import unittest -from slycot import synthesis -from slycot import transform - -class Test(unittest.TestCase): - - def setUp(self): - pass - - def test_1(self): - synthesis.sb02mt(1,1,1,1) - - def test_sb02ad(self): - "Test sb10ad, Hinf synthesis" - import numpy as np - a = np.array([[-1]]) - b = np.array([[1, 1]]) - c = np.array([[1], [1]]) - d = np.array([[0, 1], [1, 0]]) - - n = 1 - m = 2 - np_ = 2 - ncon = 1 - nmeas = 1 - gamma = 10 - - gamma_est, Ak, Bk, Ck, Dk, Ac, Bc, Cc, Dc, rcond = synthesis.sb10ad( - n, m, np_, ncon, nmeas, gamma, a, b, c, d) - # from Octave, which also uses SB10AD: - # a= -1; b1= 1; b2= 1; c1= 1; c2= 1; d11= 0; d12= 1; d21= 1; d22= 0; - # g = ss(a,[b1,b2],[c1;c2],[d11,d12;d21,d22]); - # [k,cl] = hinfsyn(g,1,1); - # k.a is Ak, cl.a is Ac - # gamma values don't match; not sure that's critical - # this is a bit fragile - # a simpler, more robust check might be to check stability of Ac - self.assertEqual(Ak.shape, (1, 1)) - self.assertAlmostEqual(Ak[0][0], -3) - self.assertEqual(Ac.shape, (2, 2)) - self.assertAlmostEqual(Ac[0][0], -1) - self.assertAlmostEqual(Ac[0][1], -1) - self.assertAlmostEqual(Ac[1][0], 1) - self.assertAlmostEqual(Ac[1][1], -3) - - -if __name__ == "__main__": - unittest.main() diff --git a/slycot/tests/test_ag08bd.py b/slycot/tests/test_ag08bd.py index f1101765..b8d23174 100644 --- a/slycot/tests/test_ag08bd.py +++ b/slycot/tests/test_ag08bd.py @@ -5,7 +5,7 @@ from slycot import analysis import numpy as np -from numpy.testing import assert_raises, assert_almost_equal, assert_equal +from numpy.testing import assert_almost_equal, assert_equal # test1 input parameters @@ -27,7 +27,7 @@ [0, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 0, 0, 0, 0, 1, 0, 0], [0, 0, 0, 0, 0, 0, 0, 1, 0]]) - + test1_B = np.array([[-1, 0, 0], [ 0, 0, 0], [ 0, 0, 0], @@ -46,13 +46,17 @@ [ 0, -1, -2], [ 0, 0, 0]]) - + class test_tg01fd(unittest.TestCase): - """ test1 to 4: Verify ag08bd with input parameters according to example in documentation """ + """ Verify ag08bd with input parameters according to example in documentation """ def test1_ag08bd(self): - #test [A-lambda*E] - #B,C,D must have correct dimensions according to l,n,m and p, but cannot have zero length in any dimenstion. Then the wrapper will complain. The length is then set to one. + """test [A-lambda*E] + + B,C,D must have correct dimensions according to l,n,m and p, but cannot + have zero length in any dimenstion. Then the wrapper will complain. + The length is then set to one. + """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=0,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=np.zeros((1,test1_n)),D=np.zeros((1,1)),equil=test1_equil, tol=test1_tol) @@ -66,8 +70,10 @@ def test1_ag08bd(self): assert_equal(kronl, []) def test2_ag08bd(self): - #test [A-lambda*E;C] - #B,D must have correct dimensions as before + """test [A-lambda*E;C] + + B,D must have correct dimensions as before + """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=test1_p,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=test1_C,D=np.zeros((test1_p,1)),equil=test1_equil, tol=test1_tol) @@ -81,8 +87,10 @@ def test2_ag08bd(self): assert_equal(kronl, [0,1,1]) def test3_ag08bd(self): - #test [A-lambda*E,B] - #C,D must have correct dimensions as before + """test [A-lambda*E,B] + + C,D must have correct dimensions as before + """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=0,A=test1_A,E=test1_E,B=test1_B,C=np.zeros((1,test1_n)),D=np.zeros((1,test1_m)),equil=test1_equil, tol=test1_tol) @@ -96,7 +104,7 @@ def test3_ag08bd(self): assert_equal(kronl, []) def test4_ag08bd(self): - #test [A-lambda*E,B;C,D] + """test [A-lambda*E,B;C,D]""" Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,D=test1_D,equil=test1_equil, tol=test1_tol) @@ -108,10 +116,6 @@ def test4_ag08bd(self): assert_equal(kronr, [2]) assert_equal(infe, [1,1,1,1,3]) assert_equal(kronl, [1]) - - -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) if __name__ == "__main__": diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index b55a0d91..7dc81d6a 100755 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -154,6 +154,7 @@ def test_mb03wd_ex(self): def test_mb05md(self): """ test_mb05md: verify Matrix exponential with slicot doc example + data from http://slicot.org/objects/software/shared/doc/MB05MD.html """ A = np.array([[ 0.5, 0., 2.3, -2.6], diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py new file mode 100644 index 00000000..3f988d3d --- /dev/null +++ b/slycot/tests/test_sb.py @@ -0,0 +1,98 @@ +# =================================================== +# sb* synthesis tests + +from slycot import synthesis +import numpy as np +from numpy.testing import assert_allclose + + +def test_sb02mt(): + """Test if sb02mt is callable + + This is a dummy test, not really checking the wrapper of the FORTRAN + function + """ + out = synthesis.sb02mt(1, 1, 1., 1.) + assert(len(out) == 8) + + +def test_sb10ad(): + """Test sb10ad, Hinf synthesis""" + a = np.array([[-1]]) + b = np.array([[1, 1]]) + c = np.array([[1], [1]]) + d = np.array([[0, 1], [1, 0]]) + + n = 1 + m = 2 + np_ = 2 + ncon = 1 + nmeas = 1 + gamma = 10 + + gamma_est, Ak, Bk, Ck, Dk, Ac, Bc, Cc, Dc, rcond = synthesis.sb10ad( + n, m, np_, ncon, nmeas, gamma, a, b, c, d) + # from Octave, which also uses SB10AD: + # a= -1; b1= 1; b2= 1; c1= 1; c2= 1; d11= 0; d12= 1; d21= 1; d22= 0; + # g = ss(a,[b1,b2],[c1;c2],[d11,d12;d21,d22]); + # [k,cl] = hinfsyn(g,1,1); + # k.a is Ak, cl.a is Ac + # gamma values don't match; not sure that's critical + # this is a bit fragile + # a simpler, more robust check might be to check stability of Ac + assert_allclose(Ak, np.array([[-3.]])) + assert_allclose(Ac, np.array([[-1., -1.] + [1., -3.]])) + + +def test_sb10jd(): + """ verify the output of sb10jd for a descriptor system """ + + # test1 input parameters + n = 6 + m = 1 + np = 6 + + A = np.array([[ 0, 0, 0, -1, 1, 0], + [ 0, 32, 0, 0, -1, 1], + [ 0, 0, 1, 0, 0, 0], + [ 0, 0, 0, 1, 0, 0], + [-1, 1, 0, 0, 0, 0], + [ 0, -1, 1, 0, 0, 0]]) + E = np.array([[ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, -10, 0, 10], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0]]) + B = np.array([[-7.1], + [ 0. ], + [ 0. ], + [ 0. ], + [ 0. ], + [ 0. ]]) + C = np.eye(6) + D = np.zeros((7,1)) + + # test1 expected results + Aexp = np.array([[-0.00312500]]) + Bexp = np.array([[ 0.05899985]]) + Cexp = np.array([[-1.17518847e-02], + [-1.17518847e-02], + [-1.17518847e-02], + [ 0.00000000e+00], + [ 0.00000000e+00], + [ 3.76060309e-01]]) + Dexp = np.array([[ 2.21875000e-01], + [ 2.21875000e-01], + [ 2.21875000e-01], + [ 0.00000000e+00], + [ 7.10000000e+00], + [ 0.00000000e+00]]) + + A_r, B_r, C_r, D_r = synthesis.sb10jd(n, m, np, A, B, C, D, E) + assert_allclose(A, Aexp) + assert_allclose(B, Bexp) + assert_allclose(C, Cexp) + assert_allclose(D, Dexp) + diff --git a/slycot/tests/test_sb10jd.py b/slycot/tests/test_sb10jd.py deleted file mode 100644 index c252dcee..00000000 --- a/slycot/tests/test_sb10jd.py +++ /dev/null @@ -1,72 +0,0 @@ -# =================================================== -# sb10jd tests - -import unittest -from slycot import synthesis -import numpy as np -from numpy.testing import assert_raises, assert_almost_equal, assert_equal - -# test1 input parameters - -test1_n = 6 -test1_m = 1 -test1_np = 6 - -test1_A = np.array([[ 0, 0, 0, -1, 1, 0], - [ 0, 32, 0, 0, -1, 1], - [ 0, 0, 1, 0, 0, 0], - [ 0, 0, 0, 1, 0, 0], - [-1, 1, 0, 0, 0, 0], - [ 0, -1, 1, 0, 0, 0]]) - - -test1_E = np.array([[ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, -10, 0, 10], - [ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, 0, 0, 0]]) - -test1_B = np.array([[-7.1], - [ 0. ], - [ 0. ], - [ 0. ], - [ 0. ], - [ 0. ]]) - -test1_C = np.eye(6) - -test1_D = np.zeros((7,1)) - -# test1 expected results - -test1_Aexp = np.array([[-0.00312500]]) -test1_Bexp = np.array([[ 0.05899985]]) -test1_Cexp = np.array([[-1.17518847e-02], - [-1.17518847e-02], - [-1.17518847e-02], - [ 0.00000000e+00], - [ 0.00000000e+00], - [ 3.76060309e-01]]) -test1_Dexp = np.array([[ 2.21875000e-01], - [ 2.21875000e-01], - [ 2.21875000e-01], - [ 0.00000000e+00], - [ 7.10000000e+00], - [ 0.00000000e+00]]) - -class test_sb10jd(unittest.TestCase): - def test1_sb10jd(self): - """ verify the output of sb10jd for a descriptor system """ - A,B,C,D = synthesis.sb10jd(test1_n,test1_m,test1_np,test1_A,test1_B,test1_C,test1_D,test1_E) - assert_almost_equal(A, test1_Aexp) - assert_almost_equal(B, test1_Bexp) - assert_almost_equal(C, test1_Cexp) - assert_almost_equal(D, test1_Dexp) - -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) - - -if __name__ == "__main__": - unittest.main() diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py old mode 100644 new mode 100755 index 60627014..df5e4a02 --- a/slycot/tests/test_sg02ad.py +++ b/slycot/tests/test_sg02ad.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # test_sg02ad.py - test suite for ricatti equation solving # RvP, 19 Jun 2017 @@ -7,21 +6,23 @@ import unittest from slycot import synthesis import numpy as np -from numpy import linalg -from numpy.testing import assert_raises, assert_almost_equal +from numpy.testing import assert_almost_equal + + +class test_sg02ad(unittest.TestCase): -class test_sg03ad(unittest.TestCase): - def test_sg02ad_case1(self): n = 3 m = 1 # from a discussion here: # https://github.com/scipy/scipy/issues/2251 A = np.array([[ 0.63399379, 0.54906824, 0.76253406], - [ 0.5404729 , 0.53745766, 0.08731853], - [ 0.27524045, 0.84922129, 0.4681622 ]]) - B = np.array([[ 0.96861695],[ 0.05532739],[ 0.78934047]]) + [ 0.5404729 , 0.53745766, 0.08731853], + [ 0.27524045, 0.84922129, 0.4681622 ]]) + B = np.array([[ 0.96861695], + [ 0.05532739], + [ 0.78934047]]) Q = np.eye(3) E = np.eye(3) R = np.ones((1,1), dtype=float) @@ -33,14 +34,12 @@ def test_sg02ad_case1(self): synthesis.sg02ad('D', 'B', 'N', 'U', 'Z', 'N', 'S', 'R', n, m, 1, A, E, B, Q, R, L) + LATXB = L + A.T.dot(X).dot(B) assert_almost_equal( - A.T.dot(X).dot(A) - E.T.dot(X).dot(E) - - (L + A.T.dot(X).dot(B)) .dot( np.linalg.solve (R+B.T.dot(X).dot(B), (L+A.T.dot(X).dot(B)).T) ) + - Q, - np.zeros((n,n))) - -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) + A.T.dot(X).dot(A) - + E.T.dot(X).dot(E) - + LATXB.dot(np.linalg.solve(R+B.T.dot(X).dot(B), LATXB.T)) + Q, + np.zeros((n, n))) if __name__ == "__main__": diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index d06146cf..df7ac42e 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -65,7 +65,6 @@ def test_tb05ad_nh(self): sys_transformed = self.check_tb05ad_AG_NG(sys, jomega, 'NG') self.check_tb05ad_NH(sys_transformed, sys, jomega) - def test_tb05ad_errors(self): """ Test tb05ad error handling. We give wrong inputs and @@ -156,10 +155,5 @@ def check_tb05ad_errors(self, sys): sys['A'], sys['B'], sys['C'], job='a') - -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) - - if __name__ == "__main__": unittest.main() diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index e442a967..7a2bbd7a 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -67,12 +67,12 @@ def test_td04ad_c(self): np.testing.assert_array_almost_equal(dcoeff,dcoeffref) np.testing.assert_array_almost_equal(ucoeff,ucoeffref) - def test_td04ad_r(self): - """td04ad: Convert with 'R' option""" + """td04ad: Convert with 'R' option - """ example program from - http://slicot.org/objects/software/shared/doc/TD04AD.html""" + example program from + http://slicot.org/objects/software/shared/doc/TD04AD.html + """ m = 2 p = 2 @@ -173,27 +173,30 @@ def test_td04ad_static(self): np.testing.assert_equal(M, np.zeros_like(M)) np.testing.assert_almost_equal(D, Dref) - def test_mixfeedthrough(self): - """Test case popping up from control testing""" - # a mix of feedthrough and dynamics. The problem from the control - # package was somewhere else + """Test case popping up from control testing + + a mix of feedthrough and dynamics. The problem from the control + package was somewhere else + """ num = np.array([ [ [ 0.0, 0.0 ], [ 0.0, -0.2 ] ], [ [ -0.1, 0.0 ], [ 0.0, 0.0 ] ] ]) p, m, d = num.shape numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) numc[:p,:m,:] = num - denc = np.array([ [ 1.0, 1.1 ], [ 1.0, 0.0 ] ]) - idxc = np.array([ 1, 0 ]) + denc = np.array([[1.0, 1.1], + [1.0, 0.0]]) + idxc = np.array([1, 0]) n, A, B, C, D = transform.td04ad('C', 2, 2, idxc, denc, numc) np.testing.assert_array_almost_equal(D, np.array([[0, 0],[-0.1, 0]])) def test_toandfrom(self): - A = np.array([[-3.0]]) B = np.array([[0.1, 0.0]]) - C = np.array([[1.0],[0.0]]) - D = np.array([[0.0, 0.0],[0.0, 1.0]]) + C = np.array([[1.0], + [0.0]]) + D = np.array([[0.0, 0.0], + [0.0, 1.0]]) tfout = transform.tb04ad(1, 2, 2, A, B, C, D) @@ -220,5 +223,6 @@ def test_tfm2ss_6(self): self.assertEqual(n, 0) np.testing.assert_array_almost_equal(D, np.array([[64]])) + if __name__ == "__main__": unittest.main() diff --git a/slycot/tests/test_tg01ad.py b/slycot/tests/test_tg01ad.py index 2ad78f7f..3b509204 100644 --- a/slycot/tests/test_tg01ad.py +++ b/slycot/tests/test_tg01ad.py @@ -59,13 +59,13 @@ test1_C_desired = \ np.array([[-1e-2, 0.0, 1e-3, 0.0 ], [ 0.0, 1e-3, -1e-3, 1e-3 ]]) - + test1_lscale_desired = \ np.array([ 10.0, 10.0, 0.1, 1e-2 ]) test1_rscale_desired = \ np.array([ 0.1, 0.1, 1.0, 10.0 ]) - + class test_tg01ad(unittest.TestCase): """ test1: Verify tg01ad with input parameters according to example in documentation """ @@ -79,10 +79,6 @@ def test1_tg01ad(self): assert_almost_equal(C, test1_C_desired) assert_almost_equal(lscale, test1_lscale_desired) assert_almost_equal(rscale, test1_rscale_desired) - - -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) if __name__ == "__main__": diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py index bc8fe2cb..e80ff6e3 100644 --- a/slycot/tests/test_tg01fd.py +++ b/slycot/tests/test_tg01fd.py @@ -8,11 +8,11 @@ from numpy.testing import assert_raises, assert_almost_equal, assert_equal # test1 input parameters -test1_l = 4 -test1_n = 4 -test1_m = 2 -test1_p = 2 -test1_tol = 0.0 +test1_l = 4 +test1_n = 4 +test1_m = 2 +test1_p = 2 +test1_tol = 0.0 test1_A = np.array([[-1, 0, 0, 3], [ 0, 0, 1, 2], [ 1, 1, 0, 4], @@ -58,10 +58,10 @@ [-9.12870929e-01, 0.00000000e+00, 0.00000000e+00, -4.08248290e-01], [ 6.19714937e-17, -1.00000000e+00, 0.00000000e+00, -1.38572473e-16], [-1.82574186e-01, -6.78863700e-17, -8.94427191e-01, 4.08248290e-01]]) - + test1_ranke_exp = 3 test1_rnka22_exp = 1 - + class test_tg01fd(unittest.TestCase): def test1_tg01fd(self): @@ -83,7 +83,7 @@ def test2_tg01fd(self): n = 30 m = 70 p = 44 - + np.random.seed(0) Ain = np.random.rand(l, n) @@ -92,7 +92,7 @@ def test2_tg01fd(self): Cin = np.random.rand(p, n) Qin = np.random.randn(l,l) Zin = np.random.randn(n,n) - + A_1,E_1,B_1,C_1,ranke_1,rnka22_1,Q_1,Z_1= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,compq='I', compz='I', joba='T', tol=0.0) A_2,E_2,B_2,C_2,ranke_2,rnka22_2,Q_2,Z_2= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,Q=Qin,Z=Zin,compq='U', compz='U', joba='T', tol=0.0) @@ -107,9 +107,6 @@ def test2_tg01fd(self): assert_almost_equal(np.dot(Qin, Q_1), Q_2) assert_almost_equal(np.dot(Zin, Z_1), Z_2) -def suite(): - return unittest.TestLoader().loadTestsFromTestCase(TestConvert) - if __name__ == "__main__": unittest.main() From 8aad320c394a1d732048e0fb2643e0ce73a3dd01 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 13 Apr 2020 23:57:41 +0200 Subject: [PATCH 138/405] fix syntax errrors in test_sb.py --- slycot/tests/test_sb.py | 91 +++++++++++++++++++++-------------------- 1 file changed, 46 insertions(+), 45 deletions(-) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 3f988d3d..3f612f15 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -2,7 +2,7 @@ # sb* synthesis tests from slycot import synthesis -import numpy as np +from numpy import array, eye, zeros from numpy.testing import assert_allclose @@ -18,20 +18,22 @@ def test_sb02mt(): def test_sb10ad(): """Test sb10ad, Hinf synthesis""" - a = np.array([[-1]]) - b = np.array([[1, 1]]) - c = np.array([[1], [1]]) - d = np.array([[0, 1], [1, 0]]) + a = array([[-1]]) + b = array([[1, 1]]) + c = array([[1], + [1]]) + d = array([[0, 1], + [1, 0]]) n = 1 m = 2 - np_ = 2 + np = 2 ncon = 1 nmeas = 1 gamma = 10 gamma_est, Ak, Bk, Ck, Dk, Ac, Bc, Cc, Dc, rcond = synthesis.sb10ad( - n, m, np_, ncon, nmeas, gamma, a, b, c, d) + n, m, np, ncon, nmeas, gamma, a, b, c, d) # from Octave, which also uses SB10AD: # a= -1; b1= 1; b2= 1; c1= 1; c2= 1; d11= 0; d12= 1; d21= 1; d22= 0; # g = ss(a,[b1,b2],[c1;c2],[d11,d12;d21,d22]); @@ -40,9 +42,9 @@ def test_sb10ad(): # gamma values don't match; not sure that's critical # this is a bit fragile # a simpler, more robust check might be to check stability of Ac - assert_allclose(Ak, np.array([[-3.]])) - assert_allclose(Ac, np.array([[-1., -1.] - [1., -3.]])) + assert_allclose(Ak, array([[-3.]])) + assert_allclose(Ac, array([[-1., -1.], + [1., -3.]])) def test_sb10jd(): @@ -53,46 +55,45 @@ def test_sb10jd(): m = 1 np = 6 - A = np.array([[ 0, 0, 0, -1, 1, 0], - [ 0, 32, 0, 0, -1, 1], - [ 0, 0, 1, 0, 0, 0], - [ 0, 0, 0, 1, 0, 0], - [-1, 1, 0, 0, 0, 0], - [ 0, -1, 1, 0, 0, 0]]) - E = np.array([[ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, -10, 0, 10], - [ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, 0, 0, 0], - [ 0, 0, 0, 0, 0, 0]]) - B = np.array([[-7.1], - [ 0. ], - [ 0. ], - [ 0. ], - [ 0. ], - [ 0. ]]) - C = np.eye(6) - D = np.zeros((7,1)) + A = array([[ 0, 0, 0, -1, 1, 0], + [ 0, 32, 0, 0, -1, 1], + [ 0, 0, 1, 0, 0, 0], + [ 0, 0, 0, 1, 0, 0], + [-1, 1, 0, 0, 0, 0], + [ 0, -1, 1, 0, 0, 0]]) + E = array([[ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, -10, 0, 10], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0], + [ 0, 0, 0, 0, 0, 0]]) + B = array([[-7.1], + [ 0. ], + [ 0. ], + [ 0. ], + [ 0. ], + [ 0. ]]) + C = eye(6) + D = zeros((7, 1)) # test1 expected results - Aexp = np.array([[-0.00312500]]) - Bexp = np.array([[ 0.05899985]]) - Cexp = np.array([[-1.17518847e-02], - [-1.17518847e-02], - [-1.17518847e-02], - [ 0.00000000e+00], - [ 0.00000000e+00], - [ 3.76060309e-01]]) - Dexp = np.array([[ 2.21875000e-01], - [ 2.21875000e-01], - [ 2.21875000e-01], - [ 0.00000000e+00], - [ 7.10000000e+00], - [ 0.00000000e+00]]) + Aexp = array([[-0.00312500]]) + Bexp = array([[ 0.05899985]]) + Cexp = array([[-1.17518847e-02], + [-1.17518847e-02], + [-1.17518847e-02], + [ 0.00000000e+00], + [ 0.00000000e+00], + [ 3.76060309e-01]]) + Dexp = array([[ 2.21875000e-01], + [ 2.21875000e-01], + [ 2.21875000e-01], + [ 0.00000000e+00], + [ 7.10000000e+00], + [ 0.00000000e+00]]) A_r, B_r, C_r, D_r = synthesis.sb10jd(n, m, np, A, B, C, D, E) assert_allclose(A, Aexp) assert_allclose(B, Bexp) assert_allclose(C, Cexp) assert_allclose(D, Dexp) - From bb1a4a689890e3a8541b08bea8a33ba1f0146da7 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 14 Apr 2020 01:17:49 +0200 Subject: [PATCH 139/405] test_sb10jd did not use the return values --- slycot/tests/test_sb.py | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 3f612f15..12d56996 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -93,7 +93,7 @@ def test_sb10jd(): [ 0.00000000e+00]]) A_r, B_r, C_r, D_r = synthesis.sb10jd(n, m, np, A, B, C, D, E) - assert_allclose(A, Aexp) - assert_allclose(B, Bexp) - assert_allclose(C, Cexp) - assert_allclose(D, Dexp) + assert_allclose(A_r, Aexp) + assert_allclose(B_r, Bexp) + assert_allclose(C_r, Cexp) + assert_allclose(D_r, Dexp) From 003a2afe09987d80e45302bd3534eb530653f542 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 14 Apr 2020 12:30:44 +0200 Subject: [PATCH 140/405] ease precision tolerance for sb10jd test --- slycot/tests/test_sb.py | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 12d56996..1322360d 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -77,23 +77,23 @@ def test_sb10jd(): D = zeros((7, 1)) # test1 expected results - Aexp = array([[-0.00312500]]) - Bexp = array([[ 0.05899985]]) - Cexp = array([[-1.17518847e-02], - [-1.17518847e-02], - [-1.17518847e-02], - [ 0.00000000e+00], - [ 0.00000000e+00], - [ 3.76060309e-01]]) - Dexp = array([[ 2.21875000e-01], - [ 2.21875000e-01], - [ 2.21875000e-01], - [ 0.00000000e+00], - [ 7.10000000e+00], - [ 0.00000000e+00]]) + Aexp = array([[-0.003125]]) + Bexp = array([[ 0.059000]]) + Cexp = array([[-1.17519e-02], + [-1.17519e-02], + [-1.17519e-02], + [ 0. ], + [ 0. ], + [ 3.76060e-01]]) + Dexp = array([[ 2.21875e-01], + [ 2.21875e-01], + [ 2.21875e-01], + [ 0. ], + [ 7.100000+00], + [ 0. ]]) A_r, B_r, C_r, D_r = synthesis.sb10jd(n, m, np, A, B, C, D, E) - assert_allclose(A_r, Aexp) - assert_allclose(B_r, Bexp) - assert_allclose(C_r, Cexp) - assert_allclose(D_r, Dexp) + assert_allclose(A_r, Aexp, atol=1e-5) + assert_allclose(B_r, Bexp, atol=1e-5) + assert_allclose(C_r, Cexp, atol=1e-5) + assert_allclose(D_r, Dexp, atol=1e-5) From 885a5a764bcadd94d63e9b17bba28911fe19f3e6 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Mon, 27 Apr 2020 00:26:42 +0200 Subject: [PATCH 141/405] run pytest with --pyargs slycot by default --- setup.cfg.in | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/setup.cfg.in b/setup.cfg.in index 9067d0c0..6473f3df 100644 --- a/setup.cfg.in +++ b/setup.cfg.in @@ -4,3 +4,7 @@ name = slycot version = @version@ gitrevision = @gitrevision@ release = @release@ + +[tool:pytest] +# run the tests with compiled and installed package +addopts = --pyargs slycot From b85b63d410f77d63c2c2f6131117b5d9ccebcf42 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 11 Apr 2020 18:48:54 +0200 Subject: [PATCH 142/405] Update README.rst build instructions - note tests depend on scipy - remove reference to deleted conda-build - added conda instructions per platform (Linux, macOS, Windows) - remove instruction installing "plain" LAPACK from conda - minor rewording and fixes --- README.rst | 44 ++++++++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/README.rst b/README.rst index fdd64cf2..d1804759 100644 --- a/README.rst +++ b/README.rst @@ -19,7 +19,7 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ -Slycot supports Python versions 2.7 and >=3.5. +Slycot supports Python versions 2.7, and 3.5 or later. To run the compiled Slycot package, the following must be installed as dependencies: @@ -32,12 +32,14 @@ following dependencies: - Python 2.7, 3.5+ - NumPy -- scikit-build >=0.8.1 -- cmake +- scikit-build +- CMake - C compiler (e.g. gcc, MS Visual C++) - FORTRAN compiler (e.g. gfortran, ifort, flang) - BLAS/LAPACK (e.g. OpenBLAS, ATLAS, MKL) +To run the Slycot unit tests and examples, you'll also need scipy. + There are a variety of ways to install these dependencies on different operating systems. See the individual packages' documentation for options. @@ -87,34 +89,36 @@ before running the install:: # Windows: set FC=D:\path\to\my\fortran.exe -To build and install execute:: +To build and install, execute:: cd /path/to/slycot_src/ python setup.py install -You can also use conda to build and install Slycot from source:: +You can also use conda to build and install Slycot from source, but +you'll have to choose the right recipe directory. - conda build conda-recipe - conda install --use-local slycot +On Linux you can choose between conda-recipe-openblas and +conda-recipe-mkl -If you prefer to use the OpenBLAS library, a conda recipe is available in -``conda-recipe-openblas``. +On macOS you should use conda-recipe-apple. -Additional tips for how to install Slycot from source can be found in the -``.travis.yml`` (commands used for Travis CI) and conda-recipe/ (conda -pre-requisites) both which are included in the source code repository. +On Windows you can try either conda-recipe-openblas or +conda-recipe-mkl; they allow for Windows builds, but we don't +regularly test on that OS. The Windows builds use flang, which is +incompatible with Python 2.7. -The hardest part about installing from source is getting a working version of -FORTRAN and LAPACK installed on your system and working properly with Python. -On Windows, the build system currently uses flang, which can be installed from -conda-forge. Note that flang is incompatible with Python 2.7. +For example, to build with the OpenBLAS recipe:: -If you are using conda, you can also get working (binary) copies of LAPACK from -conda-forge using the command:: + conda build conda-recipe-openblas + conda install --use-local slycot - conda install -c conda-forge lapack +Additional tips for how to install Slycot from source can be found in the +``.travis.yml`` (commands used for Travis CI) and conda-recipe/ (conda +pre-requisites) both which are included in the source code repository. -Slycot will also work with the OpenBLAS libraries. +The hardest part about installing from source is getting a working +version of FORTRAN and LAPACK (provided by OpenBLAS, MKL, etc.) +installed on your system and working properly with Python. Note that in some cases you may need to set the ``LIBRARY_PATH`` environment variable to pick up dependencies such as ``-lpythonN.m`` (where N.m is the From 7e11225ba809c780bf377f0df045184950693731 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 12 Apr 2020 12:18:17 +0200 Subject: [PATCH 143/405] Apply suggestions from code review Co-Authored-By: Ben --- README.rst | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/README.rst b/README.rst index d1804759..53a3d216 100644 --- a/README.rst +++ b/README.rst @@ -97,13 +97,13 @@ To build and install, execute:: You can also use conda to build and install Slycot from source, but you'll have to choose the right recipe directory. -On Linux you can choose between conda-recipe-openblas and -conda-recipe-mkl +On Linux you can choose between ``conda-recipe-openblas`` and +``conda-recipe-mkl`` -On macOS you should use conda-recipe-apple. +On macOS you should use ``conda-recipe-apple``. -On Windows you can try either conda-recipe-openblas or -conda-recipe-mkl; they allow for Windows builds, but we don't +On Windows you can try either ``conda-recipe-openblas`` or +``conda-recipe-mkl``; they allow for Windows builds, but we don't regularly test on that OS. The Windows builds use flang, which is incompatible with Python 2.7. @@ -113,8 +113,9 @@ For example, to build with the OpenBLAS recipe:: conda install --use-local slycot Additional tips for how to install Slycot from source can be found in the -``.travis.yml`` (commands used for Travis CI) and conda-recipe/ (conda -pre-requisites) both which are included in the source code repository. +``.travis.yml`` (commands used for Travis CI) and the ``conda-recipe-*/`` +directories (conda pre-requisites) both which are included in the source +code repository. The hardest part about installing from source is getting a working version of FORTRAN and LAPACK (provided by OpenBLAS, MKL, etc.) From 1f021738eeb65ca104907c21a20782d5da26a2cc Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 12 Apr 2020 12:22:43 +0200 Subject: [PATCH 144/405] Correct coveralls URLs --- README.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.rst b/README.rst index 53a3d216..8a6d4252 100644 --- a/README.rst +++ b/README.rst @@ -10,8 +10,8 @@ Slycot .. image:: https://travis-ci.org/python-control/Slycot.svg?branch=master :target: https://travis-ci.org/python-control/Slycot -.. image:: https://coveralls.io/repos/python-control/slycot/badge.png - :target: https://coveralls.io/r/python-control/slycot +.. image:: https://coveralls.io/repos/github/python-control/Slycot/badge.svg + :target: https://coveralls.io/github/python-control/Slycot Python wrapper for selected SLICOT routines, notably including solvers for Riccati, Lyapunov, and Sylvester equations. From dc3ac50de068819dc3010f08b1071607b5aeaf8e Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 25 Apr 2020 11:28:40 +0200 Subject: [PATCH 145/405] Re-arrange to emphasize conda-forge binaries; new Windows build example --- README.rst | 92 ++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 58 insertions(+), 34 deletions(-) diff --git a/README.rst b/README.rst index 8a6d4252..dc865e12 100644 --- a/README.rst +++ b/README.rst @@ -38,7 +38,8 @@ following dependencies: - FORTRAN compiler (e.g. gfortran, ifort, flang) - BLAS/LAPACK (e.g. OpenBLAS, ATLAS, MKL) -To run the Slycot unit tests and examples, you'll also need scipy. +To run the Slycot unit tests and examples, you'll also need scipy and +pytest. There are a variety of ways to install these dependencies on different operating systems. See the individual packages' documentation for options. @@ -46,36 +47,23 @@ operating systems. See the individual packages' documentation for options. Installing ----------- -In general Slycot requires non-trivial compilation to install on a given -system. The easiest way to get started using Slycot is by installing -pre-compiled binaries. The Slycot team provides pre-compiled binaries via the -conda package manager and conda forge package hosting channel for Linux, OSX, -and Windows. +The easiest way to get started with Slycot is to install pre-compiled +binaries from conda-forge (see below); these are available for Linux, +OSX, and Windows. -Using conda -~~~~~~~~~~~ +Compiling the Slycot source is unfortunately a bit tricky, especially +on Windows, but we give some pointers further below for doing this. -Install Miniconda or Anaconda and then Slycot can be installed via the conda -package manager from the conda-forge channel with the following command:: +Using conda and conda-forge +~~~~~~~~~~~~~~~~~~~~~~~~~~~ - conda install -c conda-forge slycot - -Using pip -~~~~~~~~~ +First install Miniconda or Anaconda. Slycot can then be installed +from the conda-forge channel with the following command:: -Slycot can also be installed via the pip package manager. Install pip as per -recommendations in pip's documentation. At a minimum, Python and pip must be -installed. If a pre-complied binary (i.e. "wheel") is available it will be -installed with no need for compilation. If not, pip will attempt to compile the -package from source and thus the compilation dependencies will be required -(scikit-build, gfortran, BLAS, etc.). - -Pip can then be used to install Slycot with the command:: - - pip install slycot + conda install -c conda-forge slycot -From source -~~~~~~~~~~~ +From source without conda (Linux, macOS, Windows) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unpack the course code to a directory of your choice, e.g. ``/path/to/slycot_src/`` @@ -94,6 +82,9 @@ To build and install, execute:: cd /path/to/slycot_src/ python setup.py install +From source using a conda recipe (Linux and macOS) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + You can also use conda to build and install Slycot from source, but you'll have to choose the right recipe directory. @@ -102,15 +93,37 @@ On Linux you can choose between ``conda-recipe-openblas`` and On macOS you should use ``conda-recipe-apple``. -On Windows you can try either ``conda-recipe-openblas`` or -``conda-recipe-mkl``; they allow for Windows builds, but we don't -regularly test on that OS. The Windows builds use flang, which is -incompatible with Python 2.7. - For example, to build with the OpenBLAS recipe:: - conda build conda-recipe-openblas - conda install --use-local slycot + conda build -c conda-forge conda-recipe-openblas + conda install -c conda-forge --use-local slycot + +From source in a conda environment (Windows) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A similar method can be used for Linux and macOS, but is detailed here +for Windows. This method uses conda and conda-forge to get most build +dependencies, *except* for the C compiler. + +First, install the appropriate Visual Studio compiler (see +https://wiki.python.org/moin/WindowsCompilers ). + +In the unpacked Slycot source directory, run the following commands. +This example is for Python 3.5; adapt as required. + + conda create --channel conda-forge --name build-slycot-py35 python=3.5 scikit-build flang numpy scipy + activate build-slycot-py35 + + REM you won't need this if conda installs f2py.exe rather than f2py.cmd or f2py.bat + where f2py > %TMP%\F2PYPATH.txt + set /P F2PYPATH=< %TMP%\F2PYPATH.txt + + python setup.py install -- -DF2PY_EXECUTABLE=%F2PYPATH% + cd slycot\tests + python -m unittest -v + +General notes on compiling +~~~~~~~~~~~~~~~~~~~~~~~~~~ Additional tips for how to install Slycot from source can be found in the ``.travis.yml`` (commands used for Travis CI) and the ``conda-recipe-*/`` @@ -119,8 +132,19 @@ code repository. The hardest part about installing from source is getting a working version of FORTRAN and LAPACK (provided by OpenBLAS, MKL, etc.) -installed on your system and working properly with Python. +installed on your system, and working properly with Python. Note that in some cases you may need to set the ``LIBRARY_PATH`` environment variable to pick up dependencies such as ``-lpythonN.m`` (where N.m is the version of python you are using). + +Using pip +~~~~~~~~~ + +We publish Slycot to the Python package index, but only as a source +package, so to install using pip you'll first need to install the +build prerequisites (compilers, libraries, etc.) + +If you have these build prerequisites, install in the standard way with: + + pip install slycot From e277d0b65ceceea9e0aa99db1e3bd98f56cb0e26 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 25 Apr 2020 11:30:47 +0200 Subject: [PATCH 146/405] Remove buggy and unsupported Windows conda-recipe build scripts --- conda-recipe-mkl/bld.bat | 20 -------------------- conda-recipe-openblas/bld.bat | 27 --------------------------- 2 files changed, 47 deletions(-) delete mode 100644 conda-recipe-mkl/bld.bat delete mode 100644 conda-recipe-openblas/bld.bat diff --git a/conda-recipe-mkl/bld.bat b/conda-recipe-mkl/bld.bat deleted file mode 100644 index 1b0a25e6..00000000 --- a/conda-recipe-mkl/bld.bat +++ /dev/null @@ -1,20 +0,0 @@ -:: Uncoment following two lines for local test build -cd %RECIPE_DIR% -cd .. - -:: Clean old build attempts -RD /S /Q _skbuild - -set FC=%BUILD_PREFIX%\Library\bin\flang.exe -set BLA_VENDOR=Intel10_64lp -:: Prefer f2py.exe, if it exists; this is provided by numpy 1.16 (and, we assume, later) -if EXIST "%PREFIX%\Scripts\f2py.exe" ( - set F2PY=%PREFIX%\Scripts\f2py.exe -) ELSE ( -:: Otherwise use f2py.bat, which is provided by numpy 1.15 and earlier - set F2PY=%PREFIX%\Scripts\f2py.bat -) - -"%PYTHON%" -m pip install . --no-deps --ignore-installed -vv - -if errorlevel 1 exit 1 diff --git a/conda-recipe-openblas/bld.bat b/conda-recipe-openblas/bld.bat deleted file mode 100644 index cc819308..00000000 --- a/conda-recipe-openblas/bld.bat +++ /dev/null @@ -1,27 +0,0 @@ -:: Uncoment following two lines for local test build -cd %RECIPE_DIR% -cd .. - -:: Clear old build attempts -RD /S /Q _skbuild - -set BLAS_ROOT=%PREFIX% -set LAPACK_ROOT=%PREFIX% -set NUMPY_INCLUDE=%PREFIX%\Include -:: Prefer f2py.exe, if it exists; this is provided by numpy 1.16 (and, we assume, later) -if EXIST "%PREFIX%\Scripts\f2py.exe" ( - set F2PY=%PREFIX%\Scripts\f2py.exe -) ELSE ( -:: Otherwise use f2py.bat, which is provided by numpy 1.15 and earlier - set F2PY=%PREFIX%\Scripts\f2py.bat -) - -"%PYTHON%" -m pip install . --no-deps --ignore-installed -vv - -if errorlevel 1 exit 1 - -:: Add more build steps here, if they are necessary. - -:: See -:: https://conda.io/docs/user-guide/tasks/build-packages/environment-variables.html -:: for a list of environment variables that are set during the build process. From 5ac22a98e211985848e5e4a1103f151010418f58 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 25 Apr 2020 13:55:19 +0200 Subject: [PATCH 147/405] Add info on getting the required macOS SDK Co-Authored-By: Ben --- README.rst | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/README.rst b/README.rst index dc865e12..575e8e83 100644 --- a/README.rst +++ b/README.rst @@ -91,7 +91,10 @@ you'll have to choose the right recipe directory. On Linux you can choose between ``conda-recipe-openblas`` and ``conda-recipe-mkl`` -On macOS you should use ``conda-recipe-apple``. +On macOS you should use ``conda-recipe-apple``. See the +`conda-build documentation`_ how to get the required macOS SDK. + +.. _conda-build documentation: https://docs.conda.io/projects/conda-build/en/latest/resources/compiler-tools.html#macos-sdk For example, to build with the OpenBLAS recipe:: From a292586e732e44b47469e3795dacd218e5fa8e1e Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 2 May 2020 13:11:22 +0200 Subject: [PATCH 148/405] Renaming CREDITS to AUTHORS --- CREDITS => AUTHORS | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename CREDITS => AUTHORS (100%) diff --git a/CREDITS b/AUTHORS similarity index 100% rename from CREDITS rename to AUTHORS From 1b692cd8bd6ab9d78e52ee493b4e0f0d4c8b62fa Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 2 May 2020 13:33:49 +0200 Subject: [PATCH 149/405] Update copyright and authors Authors found from `git shortlog -sn`. --- AUTHORS | 31 +++++++++++++++++++++++++------ COPYING | 3 ++- 2 files changed, 27 insertions(+), 7 deletions(-) diff --git a/AUTHORS b/AUTHORS index 86126ec2..bffe1d0e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -1,6 +1,25 @@ -Here's a list of contributors to the project: - -Cheng Soon - SB04QD -Lauren Padilla - TB04AD, TD04AD -Steve Brunton - SB10AD, SB10HD -Jerker Nordh - SG02AD, SG03AD +ArmstrongJ +Benjamin Greiner +Cheng Soon +Clancy Rowley +Enrico Avventi +Gilles Plessis +JKP3nt +Jake Vanderplas +James Goppert +Jason K. Moore +Jerker Nordh +Johannes Scharlach +Joris Geysens +Lauren Padilla +Lucas Mehl +Marcus Liljedahl +René van Paassen +Richard Murray +Rory Yorke +Scott C. Livingston +Steve Brunton +arnold +clementm +eph +lytex diff --git a/COPYING b/COPYING index ccbf5cff..68c2b233 100644 --- a/COPYING +++ b/COPYING @@ -1,5 +1,6 @@ Copyright (c) 2002-2009 NICONET e.V. Copyright 2010-2011 Enrico Avventi +Copyright (C) 2012-2020 Slycot team This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License version 2 as @@ -13,4 +14,4 @@ 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, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, -MA 02110-1301, USA. \ No newline at end of file +MA 02110-1301, USA. From 976b332062199b6864d7a5627c20ad20b42cc1a7 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 2 May 2020 13:36:18 +0200 Subject: [PATCH 150/405] Fix-up MANIFEST.in For rename of CREDITS to AUTHORS, and previously removed runtests.py. --- MANIFEST.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/MANIFEST.in b/MANIFEST.in index fa02bd06..cc943fea 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -1,6 +1,6 @@ include slycot/src/*.pyf include COPYING -include CREDITS +include AUTHORS include gpl-2.0.txt include README.rst include MANIFEST.in @@ -13,4 +13,4 @@ include slycot/*.py include slycot/version.py.in include slycot/src/*.f include slycot/tests/*.py -include runtests.py + From cb791af513e4d38bd950b849acfb2a34e9a432b2 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 2 May 2020 14:32:45 +0200 Subject: [PATCH 151/405] Change README.rst version specifiers, Windows build instructions Specify minimum scikit-build version. Updated Windows build instructions for Python 3.7, 3.8, and to use pytest. --- README.rst | 34 +++++++++++++++++++++------------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/README.rst b/README.rst index 575e8e83..871602e4 100644 --- a/README.rst +++ b/README.rst @@ -32,7 +32,7 @@ following dependencies: - Python 2.7, 3.5+ - NumPy -- scikit-build +- scikit-build >= 0.10.0 - CMake - C compiler (e.g. gcc, MS Visual C++) - FORTRAN compiler (e.g. gfortran, ifort, flang) @@ -108,22 +108,30 @@ A similar method can be used for Linux and macOS, but is detailed here for Windows. This method uses conda and conda-forge to get most build dependencies, *except* for the C compiler. -First, install the appropriate Visual Studio compiler (see -https://wiki.python.org/moin/WindowsCompilers ). +This procedure has been tested on Python 3.7 and 3.8. -In the unpacked Slycot source directory, run the following commands. -This example is for Python 3.5; adapt as required. +First, install the `correct Visual Studio compiler for the Python +version`_ you wish to build for. - conda create --channel conda-forge --name build-slycot-py35 python=3.5 scikit-build flang numpy scipy - activate build-slycot-py35 +.. _correct Visual Studio compiler for the Python version: https://wiki.python.org/moin/WindowsCompilers - REM you won't need this if conda installs f2py.exe rather than f2py.cmd or f2py.bat - where f2py > %TMP%\F2PYPATH.txt - set /P F2PYPATH=< %TMP%\F2PYPATH.txt +To build, you'll need a command shell setup for both conda and the +Visual Studio build tools. See `conda activation`_ and `Microsoft +Visual Studio setup`_ for information on this. - python setup.py install -- -DF2PY_EXECUTABLE=%F2PYPATH% - cd slycot\tests - python -m unittest -v +.. _conda activation: https://docs.conda.io/projects/conda/en/latest/user-guide/troubleshooting.html#windows-environment-has-not-been-activated +.. _Microsoft Visual Studio setup: https://docs.microsoft.com/en-us/cpp/build/setting-the-path-and-environment-variables-for-command-line-builds?view=vs-2019 + +In such a command shell, run the following commands to build and +install Slycot (this example creates a Python 3.8 environment):: + + conda create --channel conda-forge --name build-slycot python=3.8 numpy scipy libblas=*=*netlib liblapack=*=*netlib scikit-build flang pytest + conda activate build-slycot + + python setup.py install + pytest + +The final ``pytest`` command is optional; it runs the Slycot unit tests. General notes on compiling ~~~~~~~~~~~~~~~~~~~~~~~~~~ From f8891e4e960e82e0c484ef9d29c86360ed444d38 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 2 May 2020 15:57:54 +0200 Subject: [PATCH 152/405] Expand heading and fix typo in README.rst Co-authored-by: Ben Greiner --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index 871602e4..51af1048 100644 --- a/README.rst +++ b/README.rst @@ -65,7 +65,7 @@ from the conda-forge channel with the following command:: From source without conda (Linux, macOS, Windows) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unpack the course code to a directory of your choice, +Unpack the source code to a directory of your choice, e.g. ``/path/to/slycot_src/`` If you need to specify a specific compiler, set the environment variable FC From ed070cabd77f4845f1aa9354f303faa2012574fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Sat, 2 May 2020 23:23:48 +0200 Subject: [PATCH 153/405] modify conda build recipes to perform the unit tests --- conda-recipe-apple/build.sh | 11 ++++++++++- conda-recipe-apple/meta.yaml | 4 ++++ conda-recipe-mkl/build.sh | 8 ++++---- conda-recipe-mkl/meta.yaml | 6 +++++- conda-recipe-openblas/build.sh | 8 ++++---- conda-recipe-openblas/meta.yaml | 9 +++++++-- 6 files changed, 34 insertions(+), 12 deletions(-) diff --git a/conda-recipe-apple/build.sh b/conda-recipe-apple/build.sh index 9e868bc8..2f751531 100644 --- a/conda-recipe-apple/build.sh +++ b/conda-recipe-apple/build.sh @@ -1,6 +1,15 @@ +cd $RECIPE_DIR/.. + +# ensure we are not building with old cmake files +rm -rf _skbuild +rm -rf _cmake_test_compile + export LDFLAGS="$LDFLAGS -v" if [[ "$target_platform" == osx-64 ]]; then export LDFLAGS="${LDFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" export CFLAGS="${CFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" fi -$PYTHON setup.py build_ext install -- -DCMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} + +$PYTHON setup.py build_ext install -- \ + -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ + -DCMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} diff --git a/conda-recipe-apple/meta.yaml b/conda-recipe-apple/meta.yaml index b36461a1..1a9270ea 100644 --- a/conda-recipe-apple/meta.yaml +++ b/conda-recipe-apple/meta.yaml @@ -14,6 +14,7 @@ requirements: - {{ compiler('c') }} - {{ compiler('fortran') }} # [unix] - flang # [win] + - cmake host: - numpy @@ -29,6 +30,9 @@ requirements: test: imports: - slycot + commands: + - conda install nose pytest scipy parameterized --yes --quiet + - python -c "from slycot import test; test()" about: home: https://github.com/python-control/Slycot diff --git a/conda-recipe-mkl/build.sh b/conda-recipe-mkl/build.sh index a122f8b1..2e670f98 100644 --- a/conda-recipe-mkl/build.sh +++ b/conda-recipe-mkl/build.sh @@ -1,10 +1,10 @@ cd $RECIPE_DIR/.. -# specify blas vendor should be MKL -export BLA_VENDOR=Intel10_64lp - # ensure we are not building with old cmake files rm -rf _skbuild +rm -rf _cmake_test_compile # do the build -$PYTHON -m pip install . --no-deps --ignore-installed -vv +$PYTHON setup.py build_ext -lmkl install -- \ + -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ + -DBLA_VENDOR=Intel10_64lp diff --git a/conda-recipe-mkl/meta.yaml b/conda-recipe-mkl/meta.yaml index 2b19e938..a9db22c7 100644 --- a/conda-recipe-mkl/meta.yaml +++ b/conda-recipe-mkl/meta.yaml @@ -14,13 +14,14 @@ requirements: - {{ compiler('c') }} - {{ compiler('fortran') }} # [unix] - flang # [win] + - cmake + - numpy host: - numpy - mkl - python - scikit-build - - pip run: - python {{ PY_VER }} @@ -30,6 +31,9 @@ requirements: test: imports: - slycot + commands: + - conda install nose pytest scipy parameterized --yes --quiet + - python -c "from slycot import test; test()" about: home: https://github.com/python-control/Slycot diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh index 71a0d6c4..9896e862 100644 --- a/conda-recipe-openblas/build.sh +++ b/conda-recipe-openblas/build.sh @@ -1,11 +1,11 @@ cd $RECIPE_DIR/.. -# specify blas vendor should be OpenBLAS -export BLA_VENDOR=OpenBLAS - # ensure we are not building with old cmake files rm -rf _skbuild +rm -rf _cmake_test_compile # do the build -$PYTHON -m pip install . --no-deps --ignore-installed -vv +$PYTHON setup.py build_ext install -- \ + -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ + -DBLA_VENDOR=OpenBLAS diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index a584562b..63066313 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -14,22 +14,27 @@ requirements: - {{ compiler('c') }} - {{ compiler('fortran') }} # [unix] - flang # [win] + - cmake + - numpy host: - numpy - libopenblas + - openblas - python - scikit-build - - pip run: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} - libopenblas - + test: imports: - slycot + commands: + - conda install nose pytest scipy parameterized --yes --quiet + - python -c "from slycot import test; test()" about: home: https://github.com/python-control/Slycot From dec9f584df6c2a63498fe9fb440b0fc4d4a5ccf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Fri, 1 May 2020 19:25:16 +0200 Subject: [PATCH 154/405] limit line lengths to 72 char for fortran compiler compatibility --- slycot/src/SB04OD.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/slycot/src/SB04OD.f b/slycot/src/SB04OD.f index 929b1d65..d4ccfb0d 100644 --- a/slycot/src/SB04OD.f +++ b/slycot/src/SB04OD.f @@ -567,7 +567,8 @@ SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, C $ LDD, DWORK, DWORK(M+1), DWORK(2*M+1), P, LDP, Q, C $ LDQ, DWORK(3*M+1), LDWORK-3*M, INFO ) CALL DGGES( 'Vectors left', 'Vectors right', 'N', 0, N, A, LDA, - $ D, LDD, SDIM, DWORK, DWORK(M+1), DWORK(2*M+1), P, LDP, Q, + $ D, LDD, SDIM, DWORK, DWORK(M+1), DWORK(2*M+1), P, + $ LDP, Q, $ LDQ, DWORK(3*M+1), LDWORK-3*M, 0, INFO ) C @@ -626,8 +627,10 @@ SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, C CALL DGEGS( 'Vectors left', 'Vectors right', N, B, LDB, E, C $ LDE, DWORK, DWORK(N+1), DWORK(2*N+1), U, LDU, V, C $ LDV, DWORK(3*N+1), LDWORK-3*N, INFO ) - CALL DGGES( 'Vectors left', 'Vectors right', 'N', 0, N, B, LDB, E, - $ LDE, SDIM, DWORK, DWORK(N+1), DWORK(2*N+1), U, LDU, V, + CALL DGGES( 'Vectors left', 'Vectors right', 'N', + $ 0, N, B, LDB, E, + $ LDE, SDIM, DWORK, DWORK(N+1), DWORK(2*N+1), + $ U, LDU, V, $ LDV, DWORK(3*N+1), LDWORK-3*N, 0, INFO ) C C Undo scaling From 1bf49c1894745c62f7cbcd78f03052639ff10ef3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Sat, 2 May 2020 23:58:09 +0200 Subject: [PATCH 155/405] small update to the CMakeLists.txt files, feedback on locations lib/headers --- CMakeLists.txt | 25 +++++++++++++------------ slycot/CMakeLists.txt | 24 +++++++++++++----------- 2 files changed, 26 insertions(+), 23 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index be2c0718..26c01c5c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,13 +1,12 @@ # CMake file for use in conjunction with scikit-build -cmake_minimum_required(VERSION 3.4.0) +cmake_minimum_required(VERSION 3.11.0) if (CMAKE_VERSION VERSION_GREATER "3.11.99") cmake_policy(SET CMP0074 NEW) endif() project(slycot VERSION ${SLYCOT_VERSION} LANGUAGES NONE) - # Fortran detection fails on windows, use the CMAKE_C_SIMULATE flag to # force success if(WIN32) @@ -19,12 +18,24 @@ endif() enable_language(C) enable_language(Fortran) +# base site dir, use python installation for location specific includes +execute_process( + COMMAND "${PYTHON_EXECUTABLE}" -c + "import os,numpy; print(os.path.dirname(numpy.__path__[0]))" + OUTPUT_VARIABLE PYTHON_SITE + OUTPUT_STRIP_TRAILING_WHITESPACE) +if(WIN32) + string(REPLACE "\\" "/" PYTHON_SITE ${PYTHON_SITE}) +endif() find_package(PythonLibs REQUIRED) find_package(NumPy REQUIRED) find_package(BLAS REQUIRED) find_package(LAPACK REQUIRED) + +message(STATUS "NumPy: ${NumPy_INCLUDE_DIR}") message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") +message(STATUS "BLAS: ${BLAS_LIBRARIES}") message(STATUS "Slycot version: ${SLYCOT_VERSION}") # find python, standard packages, F2PY find flaky on Windows @@ -37,15 +48,5 @@ if (WIN32) set(CMAKE_Fortran_COMPILE_OPTIONS_PIC "") endif() -# base site dir, use python installation for location specific includes -execute_process( - COMMAND "${PYTHON_EXECUTABLE}" -c - "import os,numpy; print(os.path.dirname(numpy.__path__[0]))" - OUTPUT_VARIABLE PYTHON_SITE - OUTPUT_STRIP_TRAILING_WHITESPACE) -if(WIN32) - string(REPLACE "\\" "/" PYTHON_SITE ${PYTHON_SITE}) -endif() - add_subdirectory(slycot) diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index fd84ef0b..c481cea6 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -131,7 +131,7 @@ set(CMAKE_Fortran_FLAGS ) add_custom_target(wrapper ALL DEPENDS ${FSOURCES}) add_custom_command( - OUTPUT SLYCOTmodule.c _wrappermodule.c _wrapper-f2pywrappers.f + OUTPUT _wrappermodule.c _wrapper-f2pywrappers.f COMMAND ${F2PY_EXECUTABLE} -m SLYCOT ${CMAKE_CURRENT_SOURCE_DIR}/${F2PYSOURCE} DEPENDS ${F2PYSOURCE_DEPS} ${F2PYSOURCE} @@ -139,13 +139,21 @@ add_custom_command( add_library( ${SLYCOT_MODULE} MODULE - SLYCOTmodule.c _wrappermodule.c _wrapper-f2pywrappers.f - "${PYTHON_SITE}/numpy/f2py/src/fortranobject.c" + _wrappermodule.c + ${PYTHON_SITE}/numpy/f2py/src/fortranobject.c + _wrapper-f2pywrappers.f ${FSOURCES}) target_link_libraries(${SLYCOT_MODULE} ${LAPACK_LIBRARIES}) +target_include_directories( + ${SLYCOT_MODULE} PUBLIC + ${PYTHON_SITE}/numpy/core/include + ${PYTHON_SITE}/numpy/f2py/src + ${PYTHON_INCLUDE_DIRS} + ) + if (UNIX) if (APPLE) set_target_properties(${SLYCOT_MODULE} PROPERTIES @@ -156,15 +164,9 @@ if (UNIX) endif() endif() -target_include_directories( - ${SLYCOT_MODULE} PUBLIC - ${PYTHON_SITE}/numpy/core/include - ${PYTHON_SITE}/numpy/f2py/src - ${PYTHON_INCLUDE_DIRS} - ) - python_extension_module(${SLYCOT_MODULE}) -install(TARGETS ${SLYCOT_MODULE} DESTINATION slycot) + +install(TARGETS ${SLYCOT_MODULE} LIBRARY DESTINATION slycot) install(FILES ${PYSOURCE} DESTINATION slycot) add_subdirectory(tests) From de9090ab28aba913b77d93ea75d6cafe62abf349 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Fri, 2 Aug 2019 22:53:42 +0200 Subject: [PATCH 156/405] addition of wrapper for mb03rd --- slycot/src/transform.pyf | 37 +++++++++++++ slycot/tests/test_mb03rd.py | 63 +++++++++++++++++++++ slycot/transform.py | 106 ++++++++++++++++++++++++++++++++++++ 3 files changed, 206 insertions(+) create mode 100644 slycot/tests/test_mb03rd.py diff --git a/slycot/src/transform.pyf b/slycot/src/transform.pyf index dc7277b1..19d6729c 100644 --- a/slycot/src/transform.pyf +++ b/slycot/src/transform.pyf @@ -528,3 +528,40 @@ subroutine tg01fd_uu(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ld integer required intent(in) :: ldwork integer intent(out) :: info end subroutine tg01fd_uu +subroutine mb03rd_n(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,info) ! in MB03RD.f + fortranname mb03rd + character intent(hide) :: jobx = 'N' + character intent(in),required :: sort + integer intent(in),required,check(n>0) :: n + double precision intent(in),required,check(pmax>=1.0) :: pmax + double precision intent(in,out,copy),dimension(n,n),depend(n) :: a + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) + double precision intent(cache,hide) :: x + integer intent(in,hide) :: ldx=1 + integer intent(out) :: nblcks + integer intent(out),dimension(n),depend(n) :: blsize + double precision intent(out),dimension(n),depend(n) :: wr + double precision intent(out),dimension(n),depend(n) :: wi + double precision intent(in) :: tol + double precision intent(cache,hide),dimension(n),depend(n) :: dwork + integer intent(out) :: info +end subroutine mb03rd_n +subroutine mb03rd_u(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,info) ! in MB03RD.f + fortranname mb03rd + character intent(hide) :: jobx = 'U' + character intent(in),required :: sort + integer intent(in),required,check(n>0) :: n + double precision intent(in),required,check(pmax>=1.0) :: pmax + double precision intent(in,out,copy),dimension(n,n),depend(n) :: a + integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) + double precision intent(in,out,copy),dimension(n,n),depend(n) :: x + integer intent(hide),depend(x) :: ldx=MAX(shape(x,0),1) + integer intent(out) :: nblcks + integer intent(out),dimension(n),depend(n) :: blsize + double precision intent(out),dimension(n),depend(n) :: wr + double precision intent(out),dimension(n),depend(n) :: wi + double precision intent(in) :: tol + double precision intent(cache,hide),dimension(n),depend(n) :: dwork + integer intent(out) :: info +end subroutine mb03rd_u + diff --git a/slycot/tests/test_mb03rd.py b/slycot/tests/test_mb03rd.py new file mode 100644 index 00000000..6c820871 --- /dev/null +++ b/slycot/tests/test_mb03rd.py @@ -0,0 +1,63 @@ +#!/usr/bin/env python +# +# test_mb03rd.py - test suite for Shur form reduction +# RvP, 31 Jul 2019 +import unittest +from slycot import transform +import numpy as np +from numpy.testing import assert_raises, assert_almost_equal, assert_equal +from scipy.linalg import schur + +test1_A = np.array([ + [ 1., -1., 1., 2., 3., 1., 2., 3.], + [ 1., 1., 3., 4., 2., 3., 4., 2.], + [ 0., 0., 1., -1., 1., 5., 4., 1.], + [ 0., 0., 0., 1., -1., 3., 1., 2.], + [ 0., 0., 0., 1., 1., 2., 3., -1.], + [ 0., 0., 0., 0., 0., 1., 5., 1.], + [ 0., 0., 0., 0., 0., 0., 0.99999999, -0.99999999 ], + [ 0., 0., 0., 0., 0., 0., 0.99999999, 0.99999999 ] + ]) +test1_n = test1_A.shape[0] + +test1_Ar = np.array([ + [ 1.0000, -1.0000, -1.2247, -0.7071, -3.4186, 1.4577, 0.0000, 0.0000 ], + [ 1.0000, 1.0000, 0.0000, 1.4142, -5.1390, 3.1637, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 1.0000, -1.7321, -0.0016, 2.0701, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.5774, 1.0000, 0.7516, 1.1379, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -5.8606, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.1706, 1.0000, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -0.8850 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000 ], + ]) + +test1_Xr = np.array([ + [ 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.9045, 0.1957 ], + [ 0.0000, 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, -0.3015, 0.9755 ], + [ 0.0000, 0.0000, 0.8165, 0.0000, -0.5768, -0.0156, -0.3015, 0.0148 ], + [ 0.0000, 0.0000, -0.4082, 0.7071, -0.5768, -0.0156, 0.0000, -0.0534 ], + [ 0.0000, 0.0000, -0.4082, -0.7071, -0.5768, -0.0156, 0.0000, 0.0801 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, -0.0276, 0.9805, 0.0000, 0.0267 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0332, -0.0066, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0011, 0.1948, 0.0000, 0.0000 ] + ]) + +test1_pmax = 1e3 +test1_tol = 0.01 +class test_mb03rd(unittest.TestCase): + def test1(self): + # create schur form with scipy + A, X = schur(test1_A) + Ah, Xh = np.copy(A), np.copy(X) + # on this basis, get the transform + Ar, Xr, blks, eig = transform.mb03rd( + test1_n, A, X, 'U', 'S', test1_pmax, test1_tol) + # ensure X and A are unchanged + assert_equal(A, Ah) + assert_equal(X, Xh) + # compare to test case results + assert_almost_equal(Ar, test1_Ar, decimal=4) + assert_almost_equal(Xr, test1_Xr, decimal=4) + +if __name__ == "__main__": + unittest.main() diff --git a/slycot/transform.py b/slycot/transform.py index b9a72fa3..52357d72 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1350,4 +1350,110 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld return A,E,B,C,ranke,rnka22,Q,Z +def mb03rd(n,A,X=None,jobx='U',sort='N',pmax=1.0,tol=0.0): + """ A,X,blcks,EIG = mb03rd(n,A,[X,job,sort,pmax,tol]) -- if jobx='U' + A,blcks,EIG = mb03rd(n,A,[X,job,sort,pmax,tol]) -- if jobx='N' + + To reduce a matrix A in real Schur form to a block-diagonal form + using well-conditioned non-orthogonal similarity transformations. + The condition numbers of the transformations used for reduction + are roughly bounded by pmax*pmax, where pmax is a given value. + The transformations are optionally postmultiplied in a given + matrix X. The real Schur form is optionally ordered, so that + clustered eigenvalues are grouped in the same block. + + Required arguments: + n : input int + The order of the matrices A and X. n >= 0. + A : input rank-2 array('d') with bounds (n,n) + the matrix A to be block-diagonalized, in real Schur form. + Optional arguments: + X : input rank-2 array('d') with bounds (n,n) + a given matrix X, for accumulation of transformations (only if + jobx='U' + jobx : input char*1 + Specifies whether or not the transformations are + accumulated, as follows: + = 'N': The transformations are not accumulated; + = 'U': The transformations are accumulated in X (the + given matrix X is updated). + sort : input char*1 + Specifies whether or not the diagonal blocks of the real + Schur form are reordered, as follows: + = 'N': The diagonal blocks are not reordered; + = 'S': The diagonal blocks are reordered before each + step of reduction, so that clustered eigenvalues + appear in the same block; + = 'C': The diagonal blocks are not reordered, but the + "closest-neighbour" strategy is used instead of + the standard "closest to the mean" strategy + (see METHOD); + = 'B': The diagonal blocks are reordered before each + step of reduction, and the "closest-neighbour" + strategy is used (see METHOD). + pmax : input float + An upper bound for the infinity norm of elementary + submatrices of the individual transformations used for + reduction (see METHOD). PMAX >= 1.0D0. + tol : input float + The tolerance to be used in the ordering of the diagonal + blocks of the real Schur form matrix. + If the user sets TOL > 0, then the given value of TOL is + used as an absolute tolerance: a block i and a temporarily + fixed block 1 (the first block of the current trailing + submatrix to be reduced) are considered to belong to the + same cluster if their eigenvalues satisfy + + | lambda_1 - lambda_i | <= TOL. + + If the user sets TOL < 0, then the given value of TOL is + used as a relative tolerance: a block i and a temporarily + fixed block 1 are considered to belong to the same cluster + if their eigenvalues satisfy, for j = 1, ..., N, + + | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. + + If the user sets TOL = 0, then an implicitly computed, + default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) + is used instead, as a relative tolerance, where EPS is + the machine precision (see LAPACK Library routine DLAMCH). + If SORT = 'N' or 'C', this parameter is not referenced. + Return objects: + Ar : output rank-2 array('d') with bounds (n,n) + Contains the computed block-diagonal matrix, in real Schur + canonical form. The non-diagonal blocks are set to zero. + Xr : output rank-2 array('d') with bounds (n,n) + Contains the product of the given matrix X and the + transformation matrix that reduced A to block-diagonal + form. The transformation matrix is itself a product of + non-orthogonal similarity transformations having elements + with magnitude less than or equal to PMAX. + If JOBX = 'N', this array is not referenced, and not returned + blksize : output rank-1 array('i') with bounds (n) + The orders of the resulting diagonal blocks of the matrix Ar. + W : output rank-1 array('c') size (n) + This arrays contain the eigenvalues of the matrix A. +""" + hidden = ' (hidden by the wrapper)' + arg_list = ('jobx', 'sort', 'n', 'pmax', 'A', 'LDA'+hidden, + 'X', 'LDX'+hidden, 'nblks'+hidden, 'blsize'+hidden, + 'WR'+hidden, 'WI'+hidden, 'tol', + 'DWORK'+hidden, 'INFO'+hidden) + if jobx == 'N': + out = _wrapper.mb03rd_n(sort, n, pmax, A, tol) + else: + if X is None: + X = _np.eye(n) + out = _wrapper.mb03rd_u(sort, n, pmax, A, X, tol) + + if out[-1] < 0: + error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] + e = ValueError(error_text) + e.info = out[-1] + raise e + if jobx == 'N': + return out[0], out[2][:out[1]], out[-3] + out[-2]*1j + else: + return out[0], out[1], out[3][:out[2]], out[-3] + out[-2]*1j + # to be replaced by python wrappers From d0c4560d6366fd7f230eccf27819898356612a2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Sun, 3 May 2020 17:35:14 +0200 Subject: [PATCH 157/405] use pytest for running the tests --- conda-recipe-apple/meta.yaml | 6 ++++-- conda-recipe-mkl/meta.yaml | 6 ++++-- conda-recipe-openblas/meta.yaml | 6 ++++-- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/conda-recipe-apple/meta.yaml b/conda-recipe-apple/meta.yaml index 1a9270ea..4c55afcf 100644 --- a/conda-recipe-apple/meta.yaml +++ b/conda-recipe-apple/meta.yaml @@ -28,11 +28,13 @@ requirements: - {{ pin_compatible('numpy') }} test: + requires: + - pytest + - scipy imports: - slycot commands: - - conda install nose pytest scipy parameterized --yes --quiet - - python -c "from slycot import test; test()" + - pytest --pyargs slycot about: home: https://github.com/python-control/Slycot diff --git a/conda-recipe-mkl/meta.yaml b/conda-recipe-mkl/meta.yaml index a9db22c7..ef778be3 100644 --- a/conda-recipe-mkl/meta.yaml +++ b/conda-recipe-mkl/meta.yaml @@ -29,11 +29,13 @@ requirements: - mkl test: + requires: + - pytest + - scipy imports: - slycot commands: - - conda install nose pytest scipy parameterized --yes --quiet - - python -c "from slycot import test; test()" + - pytest --pyargs slycot about: home: https://github.com/python-control/Slycot diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 63066313..900224ca 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -30,11 +30,13 @@ requirements: - libopenblas test: + requires: + - pytest + - scipy imports: - slycot commands: - - conda install nose pytest scipy parameterized --yes --quiet - - python -c "from slycot import test; test()" + - pytest --pyargs slycot about: home: https://github.com/python-control/Slycot From fcf4396a5cbe82ceb332cffd95a0720ceedab9ce Mon Sep 17 00:00:00 2001 From: bnavigator Date: Sun, 3 May 2020 18:15:14 +0200 Subject: [PATCH 158/405] mb03rd schur to block-diagonal transform Based on PR #73 by @repagh Moved from transform to math single wrapper for all jobx parameter valies docstring in numpydoc (#100) run all jobx and sort parameter values in test check the returned complex eigenvalues in test --- slycot/__init__.py | 4 +- slycot/math.py | 228 ++++++++++++++++++++++++++++++++++++ slycot/src/math.pyf | 20 +++- slycot/src/transform.pyf | 51 ++------ slycot/tests/test_mb.py | 70 ++++++++++- slycot/tests/test_mb03rd.py | 63 ---------- slycot/transform.py | 158 ++++--------------------- 7 files changed, 350 insertions(+), 244 deletions(-) delete mode 100644 slycot/tests/test_mb03rd.py diff --git a/slycot/__init__.py b/slycot/__init__.py index 715a6214..981f43ac 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -24,8 +24,8 @@ # Identification routines (0/5 wrapped) - # Mathematical routines (6/81 wrapped) - from .math import mc01td, mb03vd, mb03vy, mb03wd, mb05md, mb05nd + # Mathematical routines (7/81 wrapped) + from .math import mc01td, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd # Synthesis routines (14/50 wrapped) from .synthesis import sb01bd,sb02md,sb02mt,sb02od,sb03md,sb03od diff --git a/slycot/math.py b/slycot/math.py index c029b6cc..94a9e98b 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -20,6 +20,234 @@ from . import _wrapper import warnings +import numpy as np + + +def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): + """Ar, Xr, blsize, W = mb03rd(n, A, [X, jobx, sort, pmax, tol]) + + To reduce a matrix `A` in real Schur form to a block-diagonal form + using well-conditioned non-orthogonal similarity transformations. + The condition numbers of the transformations used for reduction + are roughly bounded by `pmax`*`pmax`, where `pmax` is a given value. + The transformations are optionally postmultiplied in a given + matrix `X`. The real Schur form is optionally ordered, so that + clustered eigenvalues are grouped in the same block. + + Parameters + ---------- + n : int + The order of the matrices `A` and `X`. `n` >= 0. + A : (n, n) array_like + The matrix `A` to be block-diagonalized, in real Schur form. + X : (n, n) array_like, optional + A given matrix `X`, for accumulation of transformations (only if + `jobx`='U') + jobx : {'N', 'U'}, optional + Specifies whether or not the transformations are + accumulated, as follows: + + := 'N': The transformations are not accumulated + := 'U': The transformations are accumulated in `Xr` (default) + + sort : {'N', 'S', 'C', 'B'}, optional + Specifies whether or not the diagonal blocks of the real + Schur form are reordered, as follows: + + := 'N': The diagonal blocks are not reordered (default); + := 'S': The diagonal blocks are reordered before each + step of reduction, so that clustered eigenvalues + appear in the same block; + := 'C': The diagonal blocks are not reordered, but the + "closest-neighbour" strategy is used instead of + the standard "closest to the mean" strategy + (see Notes_); + := 'B': The diagonal blocks are reordered before each + step of reduction, and the "closest-neighbour" + strategy is used (see Notes_). + + pmax : float, optional + An upper bound for the infinity norm of elementary + submatrices of the individual transformations used for + reduction (see Notes_). `pmax` >= 1.0 + tol : float, optional + The tolerance to be used in the ordering of the diagonal + blocks of the real Schur form matrix. + If the user sets `tol` > 0, then the given value of `tol` is + used as an absolute tolerance: a block `i` and a temporarily + fixed block 1 (the first block of the current trailing + submatrix to be reduced) are considered to belong to the + same cluster if their eigenvalues satisfy + + .. math:: | \\lambda_1 - \\lambda_i | <= tol. + + If the user sets `tol` < 0, then the given value of tol is + used as a relative tolerance: a block i and a temporarily + fixed block 1 are considered to belong to the same cluster + if their eigenvalues satisfy, for ``j = 1, ..., n`` + + .. math:: | \\lambda_1 - \\lambda_i | <= | tol | * \\max | \\lambda_j |. + + If the user sets `tol` = 0, then an implicitly computed, + default tolerance, defined by ``tol = SQRT( SQRT( EPS ) )`` + is used instead, as a relative tolerance, where `EPS` is + the machine precision (see LAPACK Library routine DLAMCH). + If `sort` = 'N' or 'C', this parameter is not referenced. + + Returns + ------- + Ar : (n, n) ndarray + Contains the computed block-diagonal matrix, in real Schur + canonical form. The non-diagonal blocks are set to zero. + Xr : (n, n) ndarray or None + Contains the product of the given matrix `X` and the + transformation matrix that reduced `A` to block-diagonal + form. The transformation matrix is itself a product of + non-orthogonal similarity transformations having elements + with magnitude less than or equal to `pmax`. + If `jobx` = 'N', this array is returned as None + blsize : (n,) ndarray + The orders of the resulting diagonal blocks of the matrix `Ar`. + W : (n,) complex ndarray + Contains the complex eigenvalues of the matrix `A`. + + Notes + ----- + **Method** + + Consider first that `sort` = 'N'. Let + + :: + + ( A A ) + ( 11 12 ) + A = ( ), + ( 0 A ) + ( 22 ) + + be the given matrix in real Schur form, where initially :math:`A_{11}` is the + first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is + made to compute a transformation matrix `X` of the form + + :: + + ( I P ) + X = ( ) (1) + ( 0 I ) + + (partitioned as `A`), so that + + :: + + ( A 0 ) + -1 ( 11 ) + X A X = ( ), + ( 0 A ) + ( 22 ) + + and the elements of `P` do not exceed the value `pmax` in magnitude. + An adaptation of the standard method for solving Sylvester + equations [1]_, which controls the magnitude of the individual + elements of the computed solution [2]_, is used to obtain matrix `P`. + When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of + :math:`A_{22}` , whose eigenvalue(s) is (are) the closest to the mean of those + of :math:`A_{11}` is selected, and moved by orthogonal similarity + transformations in the leading position of :math:`A_{22}` ; the moved diagonal + block is then added to the block :math:`A_{11}` , increasing its order by 1 + (or 2). Another attempt is made to compute a suitable + transformation matrix X with the new definitions of the blocks :math:`A_{11}` + and :math:`A_{22}` . After a successful transformation matrix `X` has been + obtained, it postmultiplies the current transformation matrix + (if `jobx` = 'U'), and the whole procedure is repeated for the + matrix :math:`A_{22}`. + + When `sort` = 'S', the diagonal blocks of the real Schur form are + reordered before each step of the reduction, so that each cluster + of eigenvalues, defined as specified in the definition of TOL, + appears in adjacent blocks. The blocks for each cluster are merged + together, and the procedure described above is applied to the + larger blocks. Using the option `sort` = 'S' will usually provide + better efficiency than the standard option (`sort` = 'N'), proposed + in [2]_, because there could be no or few unsuccessful attempts + to compute individual transformation matrices `X` of the form (1). + However, the resulting dimensions of the blocks are usually + larger; this could make subsequent calculations less efficient. + + When `sort` = 'C' or 'B', the procedure is similar to that for + `sort` = 'N' or 'S', respectively, but the block of :math:`A_{22}` whose + eigenvalue(s) is (are) the closest to those of :math:`A_{11}` (not to their + mean) is selected and moved to the leading position of :math:`A_{22}`. This + is called the "closest-neighbour" strategy. + + **Numerical Aspects** + + The algorithm usually requires :math:`\mathcal{O}(N^3)` operations, + but :math:`\mathcal{O}(N^4)` are + possible in the worst case, when all diagonal blocks in the real + Schur form of `A` are 1-by-1, and the matrix cannot be diagonalized + by well-conditioned transformations. + + **Further Comments** + + The individual non-orthogonal transformation matrices used in the + reduction of `A` to a block-diagonal form have condition numbers + of the order `pmax`*`pmax`. This does not guarantee that their product + is well-conditioned enough. The routine can be easily modified to + provide estimates for the condition numbers of the clusters of + eigenvalues. + + **Contributor** + + V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. + Partly based on the RASP routine BDIAG by A. Varga, German + Aerospace Center, DLR Oberpfaffenhofen. + + **Revisions** + + \V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. + + References + ---------- + .. [1] Bartels, R.H. and Stewart, G.W. T + Solution of the matrix equation A X + XB = C. + Comm. A.C.M., 15, pp. 820-826, 1972. + + .. [2] Bavely, C. and Stewart, G.W. + An Algorithm for Computing Reducing Subspaces by Block + Diagonalization. + SIAM J. Numer. Anal., 16, pp. 359-367, 1979. + + .. [3] Demmel, J. + The Condition Number of Equivalence Transformations that + Block Diagonalize Matrix Pencils. + SIAM J. Numer. Anal., 20, pp. 599-610, 1983. + + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['jobx', 'sort', 'n', 'pmax', + 'A', 'lda' + hidden, 'X', 'ldx' + hidden, + 'nblcks', 'blsize', 'wr', 'wi', 'tol', + 'dwork' + hidden, 'info'] + + if X is None: + X = np.zeros((1, n)) + + Ar, Xr, nblcks, blsize, wr, wi, info = _wrapper.mb03rd( + jobx, sort, n, pmax, A, X, tol) + + if info < 0: + fmt = "The following argument had an illegal value: '{}'" + e = ValueError(fmt.format(arg_list[-info - 1])) + e.info = info + raise e + if jobx == 'N': + Xr = None + else: + Xr = Xr[:n, :n] + Ar = Ar[:n, :n] + W = wr + 1J*wi + return Ar, Xr, blsize[:nblcks], W + def mb03vd(n, ilo, ihi, A): """ HQ, Tau = mb03vd(n, ilo, ihi, A) diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index ecf94f2c..8cc06ace 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -12,6 +12,24 @@ subroutine mc01td(dico,dp,p,stable,nz,dwork,iwarn,info) ! in :new:MC01TD.f integer intent(out) :: info end subroutine mc01td +subroutine mb03rd(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,info) ! in MB03RD.f + character intent(in) :: jobx + character intent(in),required :: sort + integer intent(in),required,check(n>=0) :: n + double precision intent(in),required,check(pmax>=1.0) :: pmax + double precision intent(in,out,copy),dimension(lda,n),depend(n) :: a + integer intent(hide),check(lda>=max(1,n)) :: lda=shape(a,0) + double precision intent(in,out,copy),dimension(ldx,n),depend(n) :: x + integer intent(hide),check((*jobx == 'N' && ldx>=1) || (*jobx == 'U' && ldx >= max(1,n))) :: ldx=shape(x,0) + integer intent(out) :: nblcks + integer intent(out),dimension(n) :: blsize + double precision intent(out),dimension(n) :: wr + double precision intent(out),dimension(n) :: wi + double precision intent(in) :: tol + double precision intent(cache,hide),dimension(n) :: dwork + integer intent(out) :: info +end subroutine mb03rd + subroutine mb03vd(n,p,ilo,ihi,a,lda1,lda2,tau,ldtau,dwork,info) ! in MB03VD.f integer intent(in),check(n>=0) :: n integer intent(hide),depend(a),check(p>=1) :: p=shape(a,2) @@ -97,5 +115,3 @@ subroutine mb05nd(n,delta,a,lda,ex,ldex,exint,ldexin,tol,iwork,dwork,ldwork,info integer intent(out) :: info end subroutine mb05nd -! This file was auto-generated with f2py (version:2). -! See http://cens.ioc.ee/projects/f2py2e/ diff --git a/slycot/src/transform.pyf b/slycot/src/transform.pyf index 19d6729c..524996aa 100644 --- a/slycot/src/transform.pyf +++ b/slycot/src/transform.pyf @@ -45,7 +45,7 @@ subroutine tb03ad_l(leri,equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nr,index_bn,pcoeff, double precision :: tol = 0 integer intent(hide,cache),dimension(n+max(m,p)) :: iwork double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork - integer :: ldwork = max( 2*n + 3*max(m,p), p*(p+2)) + integer :: ldwork = max( 2*n + 3*max(m,p), p*(p+2)) integer intent(out) :: info end subroutine tb03ad_l subroutine tb03ad_r(leri,equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nr,index_bn,pcoeff,ldpco1,ldpco2,qcoeff,ldqco1,ldqco2,vcoeff,ldvco1,ldvco2,tol,iwork,dwork,ldwork,info) ! in :new:TB03AD.f @@ -77,7 +77,7 @@ subroutine tb03ad_r(leri,equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nr,index_bn,pcoeff, double precision :: tol = 0 integer intent(hide,cache),dimension(n+max(m,p)) :: iwork double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork - integer :: ldwork = max( 2*n + 3*max(m,p), m*(m+2)) + integer :: ldwork = max( 2*n + 3*max(m,p), m*(m+2)) integer intent(out) :: info end subroutine tb03ad_r subroutine tb04ad_r(rowcol,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nr,index_bn,dcoeff,lddcoe,ucoeff,lduco1,lduco2,tol1,tol2,iwork,dwork,ldwork,info) ! in TB04AD.f @@ -99,7 +99,7 @@ subroutine tb04ad_r(rowcol,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nr,index_bn,dcoeff,lddc double precision intent(out),dimension(max(1,p),n+1),depend(p,n) :: dcoeff integer intent(hide),depend(dcoeff) :: lddcoe=shape(dcoeff,0) double precision intent(out),dimension(max(1,p),max(1,m),n+1),depend(p,m,n) :: ucoeff - integer intent(hide),depend(ucoeff) :: lduco1=shape(ucoeff,0) + integer intent(hide),depend(ucoeff) :: lduco1=shape(ucoeff,0) integer intent(hide),depend(ucoeff) :: lduco2=shape(ucoeff,1) double precision :: tol1 = 0 double precision :: tol2 = 0 @@ -284,7 +284,7 @@ subroutine tc04ad_l(leri,m,p,index_bn,pcoeff,ldpco1,ldpco2,qcoeff,ldqco1,ldqco2, double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork integer depend(m,p) :: ldwork = max(m,p)*(max(m,p)+4) integer intent(out) :: info -end subroutine tc04ad_l +end subroutine tc04ad_l subroutine tc04ad_r(leri,m,p,index_bn,pcoeff,ldpco1,ldpco2,qcoeff,ldqco1,ldqco2,n,rcond,a,lda,b,ldb,c,ldc,d,ldd,iwork,dwork,ldwork,info) ! in TC04AD.f fortranname tc04ad character intent(hide) :: leri = 'R' @@ -325,7 +325,7 @@ subroutine td04ad_r(rowcol,m,p,index_bn,dcoeff,lddcoe,ucoeff,lduco1,lduco2,nr,a, integer intent(hide),depend(ucoeff) :: lduco2=shape(ucoeff,1) integer intent(in,out) :: nr !=sum(index_bn) double precision intent(out),dimension(max(1,nr),max(1,nr)),depend(nr) :: a - integer intent(hide),depend(a) :: lda = shape(a,0) + integer intent(hide),depend(a) :: lda = shape(a,0) double precision intent(out),dimension(max(1,nr),max(m,p)),depend(nr,m,p) :: b integer intent(hide),depend(b) :: ldb = shape(b,0) double precision intent(out),dimension(max(1,max(m,p)),max(1,nr)),depend(nr,m,p) :: c @@ -351,7 +351,7 @@ subroutine td04ad_c(rowcol,m,p,index_bn,dcoeff,lddcoe,ucoeff,lduco1,lduco2,nr,a, integer intent(hide),depend(ucoeff) :: lduco2=shape(ucoeff,1) integer intent(in,out) :: nr != sum(index_bn) double precision intent(out),dimension(max(1,nr),max(1,nr)),depend(nr) :: a - integer intent(hide),depend(a) :: lda = shape(a,0) + integer intent(hide),depend(a) :: lda = shape(a,0) double precision intent(out),dimension(max(1,nr),max(m,p)),depend(nr,m,p) :: b integer intent(hide),depend(b) :: ldb = shape(b,0) double precision intent(out),dimension(max(1,max(m,p)),max(1,nr)),depend(nr,m,p) :: c @@ -525,43 +525,6 @@ subroutine tg01fd_uu(compq,compz,joba,l,n,m,p,a,lda,e,lde,b,ldb,c,ldc,q,ldq,z,ld double precision intent(in) :: tol integer intent(cache,hide),dimension(ldwork),depend(ldwork) :: iwork double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork -integer required intent(in) :: ldwork + integer required intent(in) :: ldwork integer intent(out) :: info end subroutine tg01fd_uu -subroutine mb03rd_n(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,info) ! in MB03RD.f - fortranname mb03rd - character intent(hide) :: jobx = 'N' - character intent(in),required :: sort - integer intent(in),required,check(n>0) :: n - double precision intent(in),required,check(pmax>=1.0) :: pmax - double precision intent(in,out,copy),dimension(n,n),depend(n) :: a - integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) - double precision intent(cache,hide) :: x - integer intent(in,hide) :: ldx=1 - integer intent(out) :: nblcks - integer intent(out),dimension(n),depend(n) :: blsize - double precision intent(out),dimension(n),depend(n) :: wr - double precision intent(out),dimension(n),depend(n) :: wi - double precision intent(in) :: tol - double precision intent(cache,hide),dimension(n),depend(n) :: dwork - integer intent(out) :: info -end subroutine mb03rd_n -subroutine mb03rd_u(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,info) ! in MB03RD.f - fortranname mb03rd - character intent(hide) :: jobx = 'U' - character intent(in),required :: sort - integer intent(in),required,check(n>0) :: n - double precision intent(in),required,check(pmax>=1.0) :: pmax - double precision intent(in,out,copy),dimension(n,n),depend(n) :: a - integer intent(hide),depend(a) :: lda=MAX(shape(a,0),1) - double precision intent(in,out,copy),dimension(n,n),depend(n) :: x - integer intent(hide),depend(x) :: ldx=MAX(shape(x,0),1) - integer intent(out) :: nblcks - integer intent(out),dimension(n),depend(n) :: blsize - double precision intent(out),dimension(n),depend(n) :: wr - double precision intent(out),dimension(n),depend(n) :: wi - double precision intent(in) :: tol - double precision intent(cache,hide),dimension(n),depend(n) :: dwork - integer intent(out) :: info -end subroutine mb03rd_u - diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index 7dc81d6a..4ea494a6 100755 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -5,14 +5,82 @@ import unittest import numpy as np +from scipy.linalg import schur -from slycot import mb03vd, mb03vy, mb03wd, mb05md, mb05nd +from slycot import mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd from numpy.testing import assert_allclose class test_mb(unittest.TestCase): + def test_mb03rd(self): + """ Test for Schur form reduction. + + RvP, 31 Jul 2019""" + + test1_A = np.array([ + [ 1., -1., 1., 2., 3., 1., 2., 3.], + [ 1., 1., 3., 4., 2., 3., 4., 2.], + [ 0., 0., 1., -1., 1., 5., 4., 1.], + [ 0., 0., 0., 1., -1., 3., 1., 2.], + [ 0., 0., 0., 1., 1., 2., 3., -1.], + [ 0., 0., 0., 0., 0., 1., 5., 1.], + [ 0., 0., 0., 0., 0., 0., 0.99999999, -0.99999999 ], + [ 0., 0., 0., 0., 0., 0., 0.99999999, 0.99999999 ] + ]) + test1_n = test1_A.shape[0] + + test1_Ar = np.array([ + [ 1.0000, -1.0000, -1.2247, -0.7071, -3.4186, 1.4577, 0.0000, 0.0000 ], + [ 1.0000, 1.0000, 0.0000, 1.4142, -5.1390, 3.1637, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 1.0000, -1.7321, -0.0016, 2.0701, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.5774, 1.0000, 0.7516, 1.1379, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -5.8606, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.1706, 1.0000, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -0.8850 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000 ], + ]) + + test1_Xr = np.array([ + [ 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.9045, 0.1957 ], + [ 0.0000, 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, -0.3015, 0.9755 ], + [ 0.0000, 0.0000, 0.8165, 0.0000, -0.5768, -0.0156, -0.3015, 0.0148 ], + [ 0.0000, 0.0000, -0.4082, 0.7071, -0.5768, -0.0156, 0.0000, -0.0534 ], + [ 0.0000, 0.0000, -0.4082, -0.7071, -0.5768, -0.0156, 0.0000, 0.0801 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, -0.0276, 0.9805, 0.0000, 0.0267 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0332, -0.0066, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0011, 0.1948, 0.0000, 0.0000 ] + ]) + + test1_W = np.array([1+1j, 1-1j, + 1+1j, 1-1j, + 0.99999+0.99999j, 0.99999-0.99999j, + 1., 1.]) + + test1_pmax = 1e3 + test1_tol = 0.01 + # create schur form with scipy + A, X = schur(test1_A) + Ah, Xh = np.copy(A), np.copy(X) + # on this basis, get the transform + Ar, Xr, blsize, W = mb03rd( + test1_n, A, X, 'U', 'S', test1_pmax, test1_tol) + # ensure X and A are unchanged + assert_allclose(A, Ah) + assert_allclose(X, Xh) + # compare to test case results + assert_allclose(Ar, test1_Ar, atol=0.0001) + assert_allclose(Xr, test1_Xr, atol=0.0001) + assert_allclose(W, test1_W, atol=0.0001) + + # Test that the non sorting options do not throw errors and that Xr is + # returned as None for jobx='N' + for sort in ['N', 'C', 'B']: + Ar, Xr, blsize, W = mb03rd( + test1_n, A, X, 'N', sort, test1_pmax, test1_tol) + assert Xr is None + def test_mb03vd_mb03vy_ex(self): """Test MB03VD and MB03VY with the example given in the MB03VD SLICOT documentation""" diff --git a/slycot/tests/test_mb03rd.py b/slycot/tests/test_mb03rd.py deleted file mode 100644 index 6c820871..00000000 --- a/slycot/tests/test_mb03rd.py +++ /dev/null @@ -1,63 +0,0 @@ -#!/usr/bin/env python -# -# test_mb03rd.py - test suite for Shur form reduction -# RvP, 31 Jul 2019 -import unittest -from slycot import transform -import numpy as np -from numpy.testing import assert_raises, assert_almost_equal, assert_equal -from scipy.linalg import schur - -test1_A = np.array([ - [ 1., -1., 1., 2., 3., 1., 2., 3.], - [ 1., 1., 3., 4., 2., 3., 4., 2.], - [ 0., 0., 1., -1., 1., 5., 4., 1.], - [ 0., 0., 0., 1., -1., 3., 1., 2.], - [ 0., 0., 0., 1., 1., 2., 3., -1.], - [ 0., 0., 0., 0., 0., 1., 5., 1.], - [ 0., 0., 0., 0., 0., 0., 0.99999999, -0.99999999 ], - [ 0., 0., 0., 0., 0., 0., 0.99999999, 0.99999999 ] - ]) -test1_n = test1_A.shape[0] - -test1_Ar = np.array([ - [ 1.0000, -1.0000, -1.2247, -0.7071, -3.4186, 1.4577, 0.0000, 0.0000 ], - [ 1.0000, 1.0000, 0.0000, 1.4142, -5.1390, 3.1637, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 1.0000, -1.7321, -0.0016, 2.0701, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.5774, 1.0000, 0.7516, 1.1379, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -5.8606, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.1706, 1.0000, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -0.8850 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000 ], - ]) - -test1_Xr = np.array([ - [ 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.9045, 0.1957 ], - [ 0.0000, 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, -0.3015, 0.9755 ], - [ 0.0000, 0.0000, 0.8165, 0.0000, -0.5768, -0.0156, -0.3015, 0.0148 ], - [ 0.0000, 0.0000, -0.4082, 0.7071, -0.5768, -0.0156, 0.0000, -0.0534 ], - [ 0.0000, 0.0000, -0.4082, -0.7071, -0.5768, -0.0156, 0.0000, 0.0801 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, -0.0276, 0.9805, 0.0000, 0.0267 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0332, -0.0066, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0011, 0.1948, 0.0000, 0.0000 ] - ]) - -test1_pmax = 1e3 -test1_tol = 0.01 -class test_mb03rd(unittest.TestCase): - def test1(self): - # create schur form with scipy - A, X = schur(test1_A) - Ah, Xh = np.copy(A), np.copy(X) - # on this basis, get the transform - Ar, Xr, blks, eig = transform.mb03rd( - test1_n, A, X, 'U', 'S', test1_pmax, test1_tol) - # ensure X and A are unchanged - assert_equal(A, Ah) - assert_equal(X, Xh) - # compare to test case results - assert_almost_equal(Ar, test1_Ar, decimal=4) - assert_almost_equal(Xr, test1_Xr, decimal=4) - -if __name__ == "__main__": - unittest.main() diff --git a/slycot/transform.py b/slycot/transform.py index 52357d72..0e758f60 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -1049,30 +1049,30 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): """ A,E,B,C,lscale,rscale = tg01ad(l,n,m,p,A,E,B,C,[thresh,job]) - + To balance the matrices of the system pencil - + S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, ( C 0 ) ( 0 0 ) - + corresponding to the descriptor triple (A-lambda E,B,C), by balancing. This involves diagonal similarity transformations (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system (A-lambda E,B,C) to make the rows and columns of system pencil matrices - + diag(Dl,I) * S * diag(Dr,I) - + as close in norm as possible. Balancing may reduce the 1-norms of the matrices of the system pencil S. - + The balancing can be performed optionally on the following particular system pencils - + S = A-lambda E, - + S = ( A-lambda E B ), or - + S = ( A-lambda E ). ( C ) Required arguments: @@ -1134,15 +1134,15 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): the scaling factor applied to column j, then SCALE(j) = Dr(j), for j = 1,...,N. """ - + hidden = ' (hidden by the wrapper)' arg_list = ['job', 'l', 'n', 'm', 'p', 'thresh', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden, 'lscale', 'rscale', 'dwork'+hidden, 'info'] - + if job != 'A' and job != 'B' and job != 'C' and job != 'N': raise ValueError('Parameter job had an illegal value') A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) - + if info < 0: error_text = "The following argument had an illegal value: "+arg_list[-info-1] e = ValueError(error_text) @@ -1152,7 +1152,7 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): e = ArithmeticError('tg01ad failed') e.info = info raise e - + return A,E,B,C,lscale,rscale def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): @@ -1162,23 +1162,23 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld the orthogonal transformation matrices Q and Z such that the transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in a SVD-like coordinate form with - + ( A11 A12 ) ( Er 0 ) Q'*A*Z = ( ) , Q'*E*Z = ( ) , ( A21 A22 ) ( 0 0 ) - + where Er is an upper triangular invertible matrix. Optionally, the A22 matrix can be further reduced to the form - + ( Ar X ) A22 = ( ) , ( 0 0 ) - + with Ar an upper triangular invertible matrix, and X either a full or a zero matrix. The left and/or right orthogonal transformations performed to reduce E and A22 can be optionally accumulated. - + Required arguments: l : input int The number of rows of matrices A, B, and E. l >= 0. @@ -1253,22 +1253,22 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld On exit, the leading L-by-N part of this array contains the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix is in the form - + ( A11 * * ) Q'*A*Z = ( * Ar X ) , ( * 0 0 ) - + where A11 is a RANKE-by-RANKE matrix and Ar is a RNKA22-by-RNKA22 invertible upper triangular matrix. If JOBA = 'R' then A has the above form with X = 0. E : rank-2 array('d') with bounds (l,n) The leading L-by-N part of this array contains the transformed matrix Q'*E*Z. - + ( Er 0 ) Q'*E*Z = ( ) , ( 0 0 ) - + where Er is a RANKE-by-RANKE upper triangular invertible matrix. B : rank-2 array('d') with bounds (l,m) @@ -1310,7 +1310,7 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld hidden = ' (hidden by the wrapper)' arg_list = ['compq', 'compz', 'joba', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden,'Q','ldq'+hidden,'Z','ldz'+hidden,'ranke','rnka22','tol','iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] - + if compq != 'N' and compq != 'I' and compq != 'U': raise ValueError('Parameter compq had an illegal value') @@ -1334,7 +1334,7 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld A,E,B,C,Q,Z,ranke,rnka22,info = _wrapper.tg01fd_uu(joba,l,n,m,p,A,E,B,C,Q,Z,tol,ldwork) else: raise ValueError("The combination of compq and compz in not implemented") - + if info < 0: error_text = "The following argument had an illegal value: "+arg_list[-info-1] e = ValueError(error_text) @@ -1344,116 +1344,10 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld e = ArithmeticError('tg01fd failed') e.info = info raise e - + if joba == 'N': rnka22 = None - - return A,E,B,C,ranke,rnka22,Q,Z - -def mb03rd(n,A,X=None,jobx='U',sort='N',pmax=1.0,tol=0.0): - """ A,X,blcks,EIG = mb03rd(n,A,[X,job,sort,pmax,tol]) -- if jobx='U' - A,blcks,EIG = mb03rd(n,A,[X,job,sort,pmax,tol]) -- if jobx='N' - - To reduce a matrix A in real Schur form to a block-diagonal form - using well-conditioned non-orthogonal similarity transformations. - The condition numbers of the transformations used for reduction - are roughly bounded by pmax*pmax, where pmax is a given value. - The transformations are optionally postmultiplied in a given - matrix X. The real Schur form is optionally ordered, so that - clustered eigenvalues are grouped in the same block. - Required arguments: - n : input int - The order of the matrices A and X. n >= 0. - A : input rank-2 array('d') with bounds (n,n) - the matrix A to be block-diagonalized, in real Schur form. - Optional arguments: - X : input rank-2 array('d') with bounds (n,n) - a given matrix X, for accumulation of transformations (only if - jobx='U' - jobx : input char*1 - Specifies whether or not the transformations are - accumulated, as follows: - = 'N': The transformations are not accumulated; - = 'U': The transformations are accumulated in X (the - given matrix X is updated). - sort : input char*1 - Specifies whether or not the diagonal blocks of the real - Schur form are reordered, as follows: - = 'N': The diagonal blocks are not reordered; - = 'S': The diagonal blocks are reordered before each - step of reduction, so that clustered eigenvalues - appear in the same block; - = 'C': The diagonal blocks are not reordered, but the - "closest-neighbour" strategy is used instead of - the standard "closest to the mean" strategy - (see METHOD); - = 'B': The diagonal blocks are reordered before each - step of reduction, and the "closest-neighbour" - strategy is used (see METHOD). - pmax : input float - An upper bound for the infinity norm of elementary - submatrices of the individual transformations used for - reduction (see METHOD). PMAX >= 1.0D0. - tol : input float - The tolerance to be used in the ordering of the diagonal - blocks of the real Schur form matrix. - If the user sets TOL > 0, then the given value of TOL is - used as an absolute tolerance: a block i and a temporarily - fixed block 1 (the first block of the current trailing - submatrix to be reduced) are considered to belong to the - same cluster if their eigenvalues satisfy - - | lambda_1 - lambda_i | <= TOL. - - If the user sets TOL < 0, then the given value of TOL is - used as a relative tolerance: a block i and a temporarily - fixed block 1 are considered to belong to the same cluster - if their eigenvalues satisfy, for j = 1, ..., N, - - | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. - - If the user sets TOL = 0, then an implicitly computed, - default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) - is used instead, as a relative tolerance, where EPS is - the machine precision (see LAPACK Library routine DLAMCH). - If SORT = 'N' or 'C', this parameter is not referenced. - Return objects: - Ar : output rank-2 array('d') with bounds (n,n) - Contains the computed block-diagonal matrix, in real Schur - canonical form. The non-diagonal blocks are set to zero. - Xr : output rank-2 array('d') with bounds (n,n) - Contains the product of the given matrix X and the - transformation matrix that reduced A to block-diagonal - form. The transformation matrix is itself a product of - non-orthogonal similarity transformations having elements - with magnitude less than or equal to PMAX. - If JOBX = 'N', this array is not referenced, and not returned - blksize : output rank-1 array('i') with bounds (n) - The orders of the resulting diagonal blocks of the matrix Ar. - W : output rank-1 array('c') size (n) - This arrays contain the eigenvalues of the matrix A. -""" - hidden = ' (hidden by the wrapper)' - arg_list = ('jobx', 'sort', 'n', 'pmax', 'A', 'LDA'+hidden, - 'X', 'LDX'+hidden, 'nblks'+hidden, 'blsize'+hidden, - 'WR'+hidden, 'WI'+hidden, 'tol', - 'DWORK'+hidden, 'INFO'+hidden) - if jobx == 'N': - out = _wrapper.mb03rd_n(sort, n, pmax, A, tol) - else: - if X is None: - X = _np.eye(n) - out = _wrapper.mb03rd_u(sort, n, pmax, A, X, tol) - - if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e - if jobx == 'N': - return out[0], out[2][:out[1]], out[-3] + out[-2]*1j - else: - return out[0], out[1], out[3][:out[2]], out[-3] + out[-2]*1j + return A,E,B,C,ranke,rnka22,Q,Z # to be replaced by python wrappers From 8e141caf900846d9b19b37e9d10b2f2490d72881 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sun, 3 May 2020 21:36:16 +0200 Subject: [PATCH 159/405] conda recipe fixes --- conda-recipe-apple/meta.yaml | 5 ++++- conda-recipe-openblas/meta.yaml | 1 - 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/conda-recipe-apple/meta.yaml b/conda-recipe-apple/meta.yaml index 4c55afcf..e5bd4e1e 100644 --- a/conda-recipe-apple/meta.yaml +++ b/conda-recipe-apple/meta.yaml @@ -7,7 +7,7 @@ source: build: number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_mkl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_obl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: build: @@ -19,6 +19,8 @@ requirements: host: - numpy - python + - openblas + - python # conda-forge::scikit-build>=0.10.0 includes MACOSX_DEPLOYMENT_TARGET # patches from https://github.com/scikit-build/scikit-build/pull/441 - scikit-build >=0.10.0 @@ -26,6 +28,7 @@ requirements: run: - python - {{ pin_compatible('numpy') }} + - libopenblas test: requires: diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml index 900224ca..d3093411 100644 --- a/conda-recipe-openblas/meta.yaml +++ b/conda-recipe-openblas/meta.yaml @@ -15,7 +15,6 @@ requirements: - {{ compiler('fortran') }} # [unix] - flang # [win] - cmake - - numpy host: - numpy From ee468071db03bc27ce48e9b656fa80778c46fb49 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Sun, 3 May 2020 22:11:50 +0200 Subject: [PATCH 160/405] force looking for and use of accelerate for apple --- conda-recipe-apple/build.sh | 3 ++- conda-recipe-apple/meta.yaml | 4 +--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/conda-recipe-apple/build.sh b/conda-recipe-apple/build.sh index 2f751531..c3b0fe61 100644 --- a/conda-recipe-apple/build.sh +++ b/conda-recipe-apple/build.sh @@ -12,4 +12,5 @@ fi $PYTHON setup.py build_ext install -- \ -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ - -DCMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} + -DCMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} \ + -DBLA_VENDOR=Apple diff --git a/conda-recipe-apple/meta.yaml b/conda-recipe-apple/meta.yaml index e5bd4e1e..0e44b35e 100644 --- a/conda-recipe-apple/meta.yaml +++ b/conda-recipe-apple/meta.yaml @@ -7,7 +7,7 @@ source: build: number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_obl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_apple_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} requirements: build: @@ -19,7 +19,6 @@ requirements: host: - numpy - python - - openblas - python # conda-forge::scikit-build>=0.10.0 includes MACOSX_DEPLOYMENT_TARGET # patches from https://github.com/scikit-build/scikit-build/pull/441 @@ -28,7 +27,6 @@ requirements: run: - python - {{ pin_compatible('numpy') }} - - libopenblas test: requires: From 73e969ad4c7dbb0d19e321ec0b4907dbb535c75c Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 4 May 2020 00:05:30 +0200 Subject: [PATCH 161/405] add exception classes --- slycot/exceptions.py | 48 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) create mode 100755 slycot/exceptions.py diff --git a/slycot/exceptions.py b/slycot/exceptions.py new file mode 100755 index 00000000..54f2d220 --- /dev/null +++ b/slycot/exceptions.py @@ -0,0 +1,48 @@ +""" +exceptions.py + +Copyright 2020 Slycot team + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License version 2 as +published by the Free Software Foundation. + +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, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +MA 02110-1301, USA. +""" + + +class SlycotError(ValueError): + """Slycot exception""" + + def __init__(self, message, info): + super(SlycotError, self).__init__(message) + self.info = info + + +class SlycotParameterError(SlycotError): + """Slycot info parameter exception. + + In case of a wrong input value, the SLICOT routines return a negative + info parameter indicating which parameter was illegal. + """ + + def __init__(self, info, arg_list): + fmt = "The following argument had an illegal value: {}" + super(SlycotParameterError, self).__init__( + fmt.format(arg_list[-info-1]), info) + + +class SlycotArithmeticError(ArithmeticError): + """A Slycot computation failed""" + + def __init__(self, message, info): + super(SlycotArithmeticError, self).__init__(message) + self.info = info From e07206a5a66c916dce19ebb3ae4759a11489ee22 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 4 May 2020 00:05:48 +0200 Subject: [PATCH 162/405] migrate analysis to new exceptions --- slycot/analysis.py | 329 +++++++++++++++++++-------------------------- 1 file changed, 139 insertions(+), 190 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 76c63ba8..d9ce82e6 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -18,6 +18,8 @@ # MA 02110-1301, USA. from . import _wrapper +from .exceptions import SlycotError, SlycotParameterError, \ + SlycotArithmeticError import warnings def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): @@ -121,28 +123,21 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): if jobz == 'N': out = _wrapper.ab01nd_n(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - raise ValueError(error_text) + raise SlycotParameterError(out[-1], arg_list) # sets Z to None out[5] = None return out[:-1] if jobz == 'I': out = _wrapper.ab01nd_i(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] if jobz == 'F': out = _wrapper.ab01nd_f(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] - raise ValueError('jobz must be either N, I or F') + raise SlycotError('jobz must be either N, I or F', 0) def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): """ n,a,b,c,d = ab05md(n1,m1,p1,n2,p2,a1,b1,c1,d1,a2,b2,c2,d2,[uplo]) @@ -226,10 +221,7 @@ def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): 'ldwork', 'info'+hidden ] out = _wrapper.ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo=uplo) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): @@ -312,14 +304,11 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): ldwork = max(p1*p1,m1*m1,n1*p1) out = _wrapper.ab05nd(n1,m1,p1,n2,alpha,A1,B1,C1,D1,A2,B2,C2,D2,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0: - e = ArithmeticError('The resulting system is not completely controllable.') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The resulting system is not completely controllable.', + out[-1]) return out[:-1] def ab07nd(n,m,A,B,C,D,ldwork=None): @@ -373,18 +362,16 @@ def ab07nd(n,m,A,B,C,D,ldwork=None): ldwork = max(1,4*m) out = _wrapper.ab07nd(n,m,A,B,C,D,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == m+1: - e = ValueError('Entry matrix D is numerically singular.') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'Entry matrix D is numerically singular.', + out[-1]) if out[-1] > 0: - e = ValueError('Entry matrix D is exactly singular, the (%i,%i) diagonal element is zero.' %(out[-1],out[-1])) - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'Entry matrix D is exactly singular, the ({0:},{0:}) diagonal ' + 'element is zero.'.format(out[-1]), + out[-1]) return out[:-1] def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): @@ -469,10 +456,7 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): ldwork = n+3*max(m,p) #only an upper bound out = _wrapper.ab08nd(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): @@ -578,11 +562,7 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, zwork, info \ = out if info < 0: - error_text = "The following argument had an illegal value: " + \ - arg_list[info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, int(zwork[0].real)) @@ -679,11 +659,11 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise ValueError('Parameter dico had an illegal value') + raise SlycotError('Parameter dico had an illegal value', 0) if job != 'B' and job != 'N': - raise ValueError('Parameter job had an illegal value') + raise SlycotError('Parameter job had an illegal value', 0) if equil != 'S' and equil != 'N': - raise ValueError('Parameter equil had an illegal value') + raise SlycotError('Parameter equil had an illegal value', 0) out = _wrapper.ab09ad(dico,job,equil,ordsel,n,m,p,nr,A,B,C,tol,ldwork) if out[-2] == 1: warnings.warn("The selected order nr is greater\ @@ -692,22 +672,19 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): corresponding to the order of a minimal realization\ of the system") if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('The reduction of A to the real Schur form failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The reduction of A to the real Schur form failed', + out[-1]) if out[-1] == 2: - e = ArithmeticError('The state matrix A is not stable or not convergent') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The state matrix A is not stable or not convergent', + out[-1]) if out[-1] == 3: - e = ArithmeticError('The computation of Hankel singular values failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The computation of Hankel singular values failed', + out[-1]) Nr,A,B,C,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], hsv @@ -813,9 +790,9 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise ValueError('Parameter dico had an illegal value') + raise SlycotError('Parameter dico had an illegal value', 0) if job != 'B' and job != 'N': - raise ValueError('Parameter job had an illegal value') + raise SlycotError('Parameter job had an illegal value', 0) out = _wrapper.ab09ax(dico,job,ordsel,n,m,p,nr,A,B,C,tol,ldwork) if out[-2] == 1: warnings.warn("The selected order nr is greater\ @@ -824,18 +801,15 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): corresponding to the order of a minimal realization\ of the system") if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('The state matrix A is not stable or not convergent') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The state matrix A is not stable or not convergent', + out[-1]) if out[-1] == 2: - e = ArithmeticError('The computation of Hankel singular values failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The computation of Hankel singular values failed', + out[-1]) nr,A,B,C,hsv,T,Ti = out[:-2] return nr, A[:nr,:nr], B[:nr,:], C[:,:nr], hsv, T[:,:nr], Ti[:nr,:] @@ -956,11 +930,11 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise ValueError('Parameter dico had an illegal value') + raise SlycotError('Parameter dico had an illegal value', 0) if job != 'B' and job != 'N': - raise ValueError('Parameter job had an illegal value') + raise SlycotError('Parameter job had an illegal value', 0) if equil != 'S' and equil != 'N': - raise ValueError('Parameter equil had an illegal value') + raise SlycotError('Parameter equil had an illegal value', 0) out = _wrapper.ab09bd(dico,job,equil,ordsel,n,m,p,nr,A,B,C,D,tol1,tol2,ldwork) if out[-2] == 1: warnings.warn("The selected order nr is greater\ @@ -969,22 +943,20 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): corresponding to the order of a minimal realization\ of the system") if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('The reduction of A to the real Schur form failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The reduction of A to the real Schur form failed', + out[-1]) if out[-1] == 2: - e = ArithmeticError('The state matrix A is not stable (if dico = C) or not convergent (if dico = D)') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The state matrix A is not stable (if dico = C) ' + 'or not convergent (if dico = D)', + out[-1]) if out[-1] == 3: - e = ArithmeticError('The computation of Hankel singular values failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The computation of Hankel singular values failed', + out[-1]) Nr,A,B,C,D,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr],D[:,:], hsv @@ -1122,16 +1094,16 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise ValueError('Parameter dico had an illegal value') + raise SlycotError('Parameter dico had an illegal value', 0) if alpha is None: if dico == 'C': alpha = 0. elif dico == 'D': alpha = 1. if job != 'B' and job != 'N': - raise ValueError('Parameter job had an illegal value') + raise SlycotError('Parameter job had an illegal value', 0) if equil != 'S' and equil != 'N': - raise ValueError('Parameter equil had an illegal value') + raise SlycotError('Parameter equil had an illegal value', 0) out = _wrapper.ab09md(dico,job,equil,ordsel,n,m,p,nr,alpha,A,B,C,tol,ldwork) if out[-2] == 1: warnings.warn("with ordsel = 'F', the selected order nr is greater\ @@ -1146,23 +1118,20 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): given system. In this case nr is set equal to the\ order of the alpha-unstable part.") if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('The reduction of A to the real Schur form failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The reduction of A to the real Schur form failed', + out[-1]) if out[-1] == 2: - e = ArithmeticError('the separation of the alpha-stable/unstable diagonal\ - blocks failed because of very close eigenvalues;') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'the separation of the alpha-stable/unstable diagonal ' + 'blocks failed because of very close eigenvalues', + out[-1]) if out[-1] == 3: - e = ArithmeticError('The computation of Hankel singular values failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The computation of Hankel singular values failed', + out[-1]) Nr,A,B,C,Ns,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], Ns, hsv @@ -1296,16 +1265,16 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise ValueError('Parameter dico had an illegal value') + raise SlycotError('Parameter dico had an illegal value', 0) if alpha is None: if dico == 'C': alpha = 0. elif dico == 'D': alpha = 1. if job != 'B' and job != 'N': - raise ValueError('Parameter job had an illegal value') + raise SlycotError('Parameter job had an illegal value', 0) if equil != 'S' and equil != 'N': - raise ValueError('Parameter equil had an illegal value') + raise SlycotError('Parameter equil had an illegal value', 0) out = _wrapper.ab09nd(dico,job,equil,ordsel,n,m,p,nr,alpha,A,B,C,D,tol1,tol2,ldwork) if out[-2] == 1: warnings.warn("with ordsel = 'F', the selected order nr is greater\ @@ -1320,23 +1289,20 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= given system. In this case nr is set equal to the\ order of the alpha-unstable part.") if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('The reduction of A to the real Schur form failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The reduction of A to the real Schur form failed', + out[-1]) if out[-1] == 2: - e = ArithmeticError('the separation of the alpha-stable/unstable diagonal\ - blocks failed because of very close eigenvalues;') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'the separation of the alpha-stable/unstable diagonal ' + 'blocks failed because of very close eigenvalues', + out[-1]) if out[-1] == 3: - e = ArithmeticError('The computation of Hankel singular values failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'The computation of Hankel singular values failed', + out[-1]) Nr,A,B,C,D,Ns,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], D, Ns, hsv @@ -1384,9 +1350,9 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): """ if dico != 'C' and dico != 'D': - raise ValueError('dico must be "C" or "D"') + raise SlycotError('dico must be "C" or "D"', 0) if jobn != 'H' and jobn != 'L': - raise ValueError('jobn must be "H" or "L"') + raise SlycotError('jobn must be "H" or "L"', 0) out = _wrapper.ab13bd(dico, jobn, n, m, p, A, B, C, D, tol) if out[-1] == 0: # success @@ -1396,37 +1362,35 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): arg_list = ['dico', 'jobn', 'n', 'm', 'p', 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nq'+hidden,'tol', 'dwork'+hidden, 'ldwork'+hidden, 'iwarn'+hidden, 'info'+hidden] - error_text = "The following argument had an illegal value: " + arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) elif out[-1] == 1: - e = ArithmeticError("the reduction of A to a real Schur form failed") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the reduction of A to a real Schur form failed", + out[-1]) elif out[-1] == 2: - e = ArithmeticError("a failure was detected during the reordering of the real Schur form of A, " - "or in the iterative process for reordering the eigenvalues of " - "Z'*(A + B*F)*Z along the diagonal") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "a failure was detected during the reordering of the real Schur form of A, " + "or in the iterative process for reordering the eigenvalues of " + "Z'*(A + B*F)*Z along the diagonal", + out[-1]) elif out[-1] == 3: - e = ArithmeticError("the matrix A has a controllable eigenvalue on the " + - ( "imaginary axis" if dico == 'C' else "unit circle" )) - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the matrix A has a controllable eigenvalue on the " + + ("imaginary axis" if dico == 'C' else "unit circle"), + out[-1]) elif out[-1] == 4: - e = ArithmeticError("the solution of Lyapunov equation failed because the equation is singular") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the solution of Lyapunov equation failed because the equation is " + "singular", + out[-1]) elif out[-1] == 5: - e = ArithmeticError("DICO = 'C' and D is a nonzero matrix") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "DICO = 'C' and D is a nonzero matrix", + out[-1]) elif out[-1] == 6: - e = ArithmeticError("JOBN = 'H' and the system is unstable") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "JOBN = 'H' and the system is unstable", + out[-1]) else: raise RuntimeError("unknown error code %r" % out[-1]) @@ -1506,13 +1470,13 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): """ if dico != 'C' and dico != 'D': - raise ValueError('dico must be "C" or "D"') + raise SlycotError('dico must be "C" or "D"', 0) if jobe != 'G' and jobe != 'I': - raise ValueError('jobe must be "G" or "I"') + raise SlycotError('jobe must be "G" or "I"', 0) if equil != 'S' and equil != 'N': - raise ValueError('equil must be "S" or "N"') + raise SlycotError('equil must be "S" or "N"', 0) if jobd != 'D' and jobd != 'Z': - raise ValueError('jobd must be "D" or "Z"') + raise SlycotError('jobd must be "D" or "Z"', 0) out = _wrapper.ab13dd(dico, jobe, equil, jobd, n, m, p, [0.0, 1.0], A, E, B, C, D, tol) if out[-1] == 0: # success @@ -1525,26 +1489,24 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'gpeak'+hidden, 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden] - error_text = "The following argument had an illegal value: " + arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) elif out[-1] == 1: - e = ArithmeticError("the matrix E is (numerically) singular") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the matrix E is (numerically) singular", + out[-1]) elif out[-1] == 2: - e = ArithmeticError("the (periodic) QR (or QZ) algorithm for computing eigenvalues did not converge") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the (periodic) QR (or QZ) algorithm for computing eigenvalues " + "did not converge", + out[-1]) elif out[-1] == 3: - e = ArithmeticError("the SVD algorithm for computing singular values did not converge") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the SVD algorithm for computing singular values did not converge", + out[-1]) elif out[-1] == 4: - e = ArithmeticError("the tolerance is too small and the algorithm did not converge") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the tolerance is too small and the algorithm did not converge", + out[-1]) else: raise RuntimeError("unknown error code %r" % out[-1]) @@ -1601,14 +1563,11 @@ def ab13ed(n, A, tol = 9.0): hidden = ' (hidden by the wrapper)' arg_list = ['n', 'A', 'lda'+hidden, 'low'+hidden, 'high'+hidden, 'tol', 'dwork'+hidden, 'ldwork'+hidden, 'info'+hidden] - error_text = "The following argument had an illegal value: " + arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) elif out[-1] == 1: - e = ArithmeticError("the QR algorithm fails to converge") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "the QR algorithm fails to converge", + out[-1]) else: raise RuntimeError("unknown error code %r" % out[-1]) @@ -1668,17 +1627,14 @@ def ab13fd(n, A, tol = 0.0): hidden = ' (hidden by the wrapper)' arg_list = ['n', 'A', 'lda'+hidden, 'beta'+hidden, 'omega'+hidden, 'tol', 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden] - error_text = "The following argument had an illegal value: " + arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) elif out[-1] == 1: warnings.warn("the routine fails to compute beta(A) within the specified tolerance") return out[0], out[1] # the returned value is an upper bound on beta(A) elif out[-1] == 2: - e = ArithmeticError("either the QR or SVD algorithm fails to converge") - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "either the QR or SVD algorithm fails to converge", + out[-1]) else: raise RuntimeError("unknown error code %r" % out[-1]) @@ -1772,7 +1728,7 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): arg_list = ['equil', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nfz', 'nrank', 'niz', 'dinfz', 'nkror', 'ninfe', 'nkrol', 'infz', 'kronr', 'infe', 'kronl', 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] if equil != 'S' and equil != 'N': - raise ValueError('Parameter equil had an illegal value') + raise SlycotError('Parameter equil had an illegal value', 0) if ldwork is None: ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)) @@ -1784,15 +1740,8 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): [Af,Ef,nfz,nrank,niz,dinfz,nkror,ninfe,nkrol,infz,kronr,infe,kronl,info]= _wrapper.ag08bd(equil,l,n,m,p,A,E,B,C,D,tol,ldwork) if info < 0: - error_text = "The following argument had an illegal value: "+arg_list[-info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if info != 0: - e = ArithmeticError('ag08bd failed') - e.info = info - raise e + raise SlycotArithmeticError('ag08bd failed', info) return Af[:nfz,:nfz],Ef[:nfz,:nfz],nrank,niz,infz[:dinfz],kronr[:nkror],infe[:ninfe],kronl[:nkrol] - -# to be replaced by python wrappers From 1f356f242fe6faece68fa609a60f6d86e4de994d Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 4 May 2020 00:38:52 +0200 Subject: [PATCH 163/405] migrate math to new exceptions --- slycot/math.py | 73 +++++++++++++------------------------------------- 1 file changed, 19 insertions(+), 54 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 94a9e98b..ec047323 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -18,6 +18,8 @@ # MA 02110-1301, USA. from . import _wrapper +from .exceptions import SlycotError, SlycotParameterError, \ + SlycotArithmeticError import warnings import numpy as np @@ -236,10 +238,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): jobx, sort, n, pmax, A, X, tol) if info < 0: - fmt = "The following argument had an illegal value: '{}'" - e = ValueError(fmt.format(arg_list[-info - 1])) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if jobx == 'N': Xr = None else: @@ -306,12 +305,6 @@ def mb03vd(n, ilo, ihi, A): scalar factors of the elementary reflectors used to form the matrix Q_j, j = 1, ..., p. See FURTHER COMMENTS. - Raises - ------ - - ValueError : e - e.info contains information about the exact type of exception - Further Comments ---------------- @@ -372,11 +365,8 @@ def mb03vd(n, ilo, ihi, A): HQ, Tau, info = _wrapper.mb03vd(n, ilo, ihi, A) - if info != 0: - e = ValueError( - "Argument '{}' had an illegal value".format(arg_list[-info-1])) - e.info = info - raise e + if info < 0: + raise SlycotParameterError(info, arg_list) return (HQ, Tau) @@ -423,12 +413,6 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): 3D array with same shape as A. Q[:n,:n,j-1] contains the N-by-N orthogonal matrix Q_j, j = 1, ..., p. - Raises - ------ - - ValueError : - e.info contains the number of the argument that was invalid - """ hidden = ' (hidden by the wrapper)' @@ -442,11 +426,8 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): Q, info = _wrapper.mb03vy(n, ilo, ihi, A, Tau, ldwork) - if info != 0: - e = ValueError( - "Argument '{}' had an illegal value".format(arg_list[-info-1])) - e.info = info - raise e + if info < 0: + raise SlycotParameterError(info, arg_list) return Q @@ -562,12 +543,6 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): If JOB = 'S', the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H. - Raises - ------ - - ValueError : e - e.info contains information about the exact type of exception - """ hidden = ' (hidden by the wrapper)' arg_list = ['job', 'compz', 'n', 'p' + hidden, @@ -585,10 +560,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) if info < 0: - e = ValueError( - "Argument '{}' had an illegal value".format(arg_list[-info-1])) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) elif info > 0: warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " "in a total of 30*({ihi}-{ilo}+1) iterations " @@ -684,17 +656,16 @@ def mb05md(a, delta, balanc='N'): VAL = VALr return (Ar, Vr, Yr, VAL) elif INFO < 0: - error_text = "The following argument had an illegal value: " \ - + arg_list[-INFO-1] + raise SlycotParameterError(INFO, arg_list) elif INFO > 0 and INFO <= n: - error_text = "Incomplete eigenvalue calculation, missing %i eigenvalues" % INFO + raise SlycotArithmeticError("Incomplete eigenvalue calculation, " + "missing {} eigenvalues".format(INFO), + INFO) elif INFO == n+1: - error_text = "Eigenvector matrix singular" + raise SlycotArithmeticError("Eigenvector matrix singular", INFO) elif INFO == n+2: - error_text = "A matrix defective" - e = ValueError(error_text) - e.info = INFO - raise e + raise SlycotArithmeticError("Matrix A is defective, " + "possibly due to rounding errors.", INFO) def mb05nd(a, delta, tol=1e-7): @@ -729,13 +700,10 @@ def mb05nd(a, delta, tol=1e-7): if out[-1] == 0: return out[:-1] elif out[-1] < 0: - error_text = "The following argument had an illegal value: " \ - + arg_list[-out[-1]-1] + raise SlycotParameterError(out[-1], arg_list) elif out[-1] == n+1: - error_text = "Delta too large" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotError("Delta too large", out[-1]) + def mc01td(dico, dp, p): @@ -781,10 +749,7 @@ def mc01td(dico, dp, p): 'IWARN', 'INFO'] (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) if info < 0: - fmt = "The following argument had an illegal value: '{}'" - e = ValueError(fmt.format(arg_list[-info - 1])) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if info == 1: warnings.warn('entry P(x) is the zero polynomial.') if info == 2: From a8edfb43922102de4eff9167c53048909c289f65 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 4 May 2020 01:56:30 +0200 Subject: [PATCH 164/405] migrate synthesis to the new exceptions --- slycot/synthesis.py | 755 +++++++++++++++++++++----------------------- 1 file changed, 364 insertions(+), 391 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 8526398e..95c04a3c 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -20,6 +20,8 @@ from . import _wrapper +from .exceptions import SlycotError, SlycotParameterError, \ + SlycotArithmeticError import numpy as _np import warnings @@ -101,19 +103,23 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - = 1: the reduction of A to a real Schur form failed; - = 2: a failure was detected during the ordering of the + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + the reduction of A to a real Schur form failed; + :e.info = 2: + a failure was detected during the ordering of the real Schur form of A, or in the iterative process for reordering the eigenvalues of Z'*(A + B*F)*Z along the diagonal. - = 3: the number of eigenvalues to be assigned is less + :e.info = 3: + the number of eigenvalues to be assigned is less than the number of possibly assignable eigenvalues; nap eigenvalues have been properly assigned, but some assignable eigenvalues remain unmodified. - = 4: an attempt is made to place a complex conjugate + :e.info = 4: + an attempt is made to place a complex conjugate pair on the location of a real eigenvalue. This situation can only appear when n-nfp is odd, np > n-nfp-nup is even, and for the last real @@ -145,26 +151,21 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): ldwork = max(1,5*m,5*n,2*n+4*m) A_z,wr,wi,nfp,nap,nup,F,Z,warn,info = _wrapper.sb01bd(dico,n,m,np,alpha,A,B,w.real,w.imag,tol=tol,ldwork=ldwork) if info < 0: - error_text = "The following argument had an illegal value: "+arg_list[-info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if info == 1: - e = ValueError('the reduction of A to a real Schur form failed') - e.info = info - raise e + raise SlycotArithmeticError( + 'the reduction of A to a real Schur form failed', + info) if info == 2: - e = ValueError('a failure was detected during the ordering of eigenvalues') - e.info = info - raise e + raise SlycotArithmeticError('a failure was detected during the ordering of eigenvalues', info) if info == 3: - e = ValueError('the number of eigenvalues to be assigned is less than the number of possibly assignable eigenvalues') - e.info = info - raise e + raise SlycotArithmeticError( + 'the number of eigenvalues to be assigned is less than the number of possibly assignable eigenvalues', + info) if info == 4: - e = ValueError('an attempt was made to place a complex conjugate pair on the location of a real eigenvalue') - e.info = info - raise e + raise SlycotArithmeticError( + 'an attempt was made to place a complex conjugate pair on the location of a real eigenvalue', + info) if warn != 0: warnings.warn('%i violations of the numerical stability condition occured during the assignment of eigenvalues' % warn) # put togheter wr and wi into a complex array of eigenvalues @@ -286,18 +287,23 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - = 1: if matrix A is (numerically) singular in discrete- + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + if matrix A is (numerically) singular in discrete- time case; - = 2: if the Hamiltonian or symplectic matrix H cannot be + :e.info = 2: + if the Hamiltonian or symplectic matrix H cannot be reduced to real Schur form; - = 3: if the real Schur form of the Hamiltonian or + :e.info = 3: + if the real Schur form of the Hamiltonian or symplectic matrix H cannot be appropriately ordered; - = 4: if the Hamiltonian or symplectic matrix H has less + :e.info = 4: + if the Hamiltonian or symplectic matrix H has less than n stable eigenvalues; - = 5: if the n-th order system of linear algebraic + :e.info = 5: + if the n-th order system of linear algebraic equations, from which the solution matrix X would be obtained, is singular to working precision. @@ -327,30 +333,27 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): ldwork = max(3,6*n) A_inv,X,rcond,wr,wi,S,U,info = _wrapper.sb02md(dico,n,A,G,Q,hinv=hinv,uplo=uplo,scal=scal,sort=sort,ldwork=ldwork) if info < 0: - error_text = "The following argument had an illegal value: "+arg_list[-info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if info == 1: - e = ValueError('matrix A is (numerically) singular in discrete-time case') - e.info = info - raise e + raise SlycotArithmeticError( + 'matrix A is (numerically) singular in discrete-time case', + info) if info == 2: - e = ValueError('the Hamiltonian or symplectic matrix H cannot be reduced to real Schur form') - e.info = info - raise e + raise SlycotArithmeticError( + 'the Hamiltonian or symplectic matrix H cannot be reduced to real Schur form', + info) if info == 3: - e = ValueError('the real Schur form of the Hamiltonian or symplectic matrix H cannot be appropriately ordered') - e.info = info - raise e + raise SlycotArithmeticError( + 'the real Schur form of the Hamiltonian or symplectic matrix H cannot be appropriately ordered', + info) if info == 4: - e = ValueError('the Hamiltonian or symplectic matrix H has less than n stable eigenvalues') - e.info = info - raise e + raise SlycotArithmeticError( + 'the Hamiltonian or symplectic matrix H has less than n stable eigenvalues', + info) if info == 5: - e = ValueError('if the N-th order system of linear algebraic equations is singular to working precision') - e.info = info - raise e + raise SlycotArithmeticError( + 'if the N-th order system of linear algebraic equations is singular to working precision', + info) w = _np.zeros(2*n,'complex64') w.real = wr[0:2*n] w.imag = wi[0:2*n] @@ -466,14 +469,16 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - = i: if the i-th element (1 <= i <= m) of the d factor is + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = i: + if the i-th element (1 <= i <= m) of the d factor is exactly zero; the UdU' (or LdL') factorization has been completed, but the block diagonal matrix d is exactly singular; - = m+1: if the matrix R is numerically singular. + :e.info = m+1: + if the matrix R is numerically singular. """ hidden = ' (hidden by the wrapper)' arg_list = ['JOBG'+hidden, 'jobl', 'fact', 'uplo', 'n', 'm', 'A', @@ -489,35 +494,31 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): if fact == 'N': out = _wrapper.sb02mt_n(n,m,B,R,uplo=uplo,ldwork=ldwork) if out is None: - e = ValueError('fact must be either C or N.') - e.info = -3 - raise e + raise SlycotError( + 'fact must be either C or N.', + -3) else: if A is None or Q is None or L is None: - e = ValueError('matrices A,Q and L are required if jobl is not Z.') - e.info = -7 - raise e + raise SlycotError( + 'matrices A,Q and L are required if jobl is not Z.', + -7) if fact == 'C': out = _wrapper.sb02mt_cl(n,m,A,B,Q,R,L,uplo=uplo) if fact == 'N': out = _wrapper.sb02mt_nl(n,m,A,B,Q,R,L,uplo=uplo,ldwork=ldwork) if out is None: - e = ValueError('fact must be either C or N.') - e.info = -3 - raise e + raise SlycotError( + 'fact must be either C or N.', + -3) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: - e = ValueError('the %i-th elemend of d in the UdU (LdL) factorization is zero.'%out[-1]) - e.info = out[-1] - raise e + raise SlycotArithmeticError('the {}-th element of d in the UdU (LdL) ' + 'factorization is zero.'.format(out[-1]), + out[-1]) if out[-1] == m+1: - e = ValueError('matrix R is numerically singular.') - e.info = out[-1] - raise e + raise SlycotArithmeticError('matrix R is numerically singular.', + out[-1]) return out[:-1] def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldwork=None): @@ -643,21 +644,27 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - = 1: if the computed extended matrix pencil is singular, + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + if the computed extended matrix pencil is singular, possibly due to rounding errors; - = 2: if the QZ (or QR) algorithm failed; - = 3: if reordering of the (generalized) eigenvalues failed; - = 4: if after reordering, roundoff changed values of + :e.info = 2: + if the QZ (or QR) algorithm failed; + :e.info = 3: + if reordering of the (generalized) eigenvalues failed; + :e.info = 4: + if after reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the (generalized) Schur form no longer satisfy the stability condition; this could also be caused due to scaling; - = 5: if the computed dimension of the solution does not + :e.info = 5: + if the computed dimension of the solution does not equal n; - = 6: if a singular matrix was encountered during the + :e.info = 6: + if a singular matrix was encountered during the computation of the solution matrix X. Example @@ -706,34 +713,31 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw p = _np.shape(Q)[0] out = _wrapper.sb02od_b(dico,n,m,p,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ValueError('the computed extended matrix pencil is singular, possibly due to rounding errors') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'the computed extended matrix pencil is singular, possibly due to rounding errors', + out[-1]) if out[-1] == 2: - e = ValueError('the QZ (or QR) algorithm failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'the QZ (or QR) algorithm failed', + out[-1]) if out[-1] == 3: - e = ValueError('reordering of the (generalized) eigenvalues failed') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'reordering of the (generalized) eigenvalues failed', + out[-1]) if out[-1] == 4: - e = ValueError('stability condition failed due to roudoff errors') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'stability condition failed due to roudoff errors', + out[-1]) if out[-1] == 5: - e = ValueError('the computed dimension of the solution does not equal N') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'the computed dimension of the solution does not equal N', + out[-1]) if out[-1] == 6: - e = ValueError('a singular matrix was encountered during the computation') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'a singular matrix was encountered during the computation', + out[-1]) rcond,X,alphar,alphai,beta,S,T = out[:-1] w = _np.zeros(2*n,'complex64') w.real = alphar[0:2*n]/beta[0:2*n] @@ -833,14 +837,16 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - > 0: if info = i, the QR algorithm failed to compute all + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info > 0: + if info = i, the QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES); elements i+1:n of w contain eigenvalues which have converged, and A contains the partially converged Schur form; - = N+1: if dico = 'C', and the matrices A and -A' have + :e.info = N+1: + if dico = 'C', and the matrices A and -A' have common or very close eigenvalues, or if dico = 'D', and matrix A has almost reciprocal eigenvalues (that is, lambda(i) = 1/lambda(j) for @@ -856,32 +862,24 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): if ldwork is None: ldwork = max(2*n*n,3*n) if dico != 'C' and dico != 'D': - e = ValueError('dico must be either D or C') - e.info = -1 - raise e + raise SlycotError('dico must be either D or C', -1) out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == n+1: if dico == 'D': error_text = 'The matrix A has eigenvalues that are almost reciprocal.' else: error_text = 'The matrix A and -A have common or very close eigenvalues.' - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) else: if out[-1] > 0: - error_text = """The QR algorithm failed to compute all the eigenvalues -(see LAPACK Library routine DGEES); elements %i:%i of w contains -eigenvalues which have converged, A contains the partially -converged Shur form'""" %(out[-1],n) # not sure about the indenting here - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "The QR algorithm failed to compute all the eigenvalues " + "(see LAPACK Library routine DGEES); elements {}:{} of w " + "contains eigenvalues which have converged, A contains the " + "partially converged Shur form".format(out[-1],n), + out[-1]) X,scale,sep,ferr,wr,wi = out[:-1] w = _np.zeros(n,'complex64') w.real = wr[0:n] @@ -993,12 +991,13 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): If fact = 'N', this array contains the eigenvalues of A. Raises - ______ + ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - = 1: if the Lyapunov equation is (nearly) singular + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + if the Lyapunov equation is (nearly) singular (warning indicator); if DICO = 'C' this means that while the matrix A (or the factor S) has computed eigenvalues with @@ -1013,28 +1012,33 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): in A can make one or more of the eigenvalues lie outside the unit circle; perturbed values were used to solve the equation; - = 2: if FACT = 'N' and DICO = 'C', but the matrix A is + :e.info = 2: + if FACT = 'N' and DICO = 'C', but the matrix A is not stable (that is, one or more of the eigenvalues of A has a non-negative real part), or DICO = 'D', but the matrix A is not convergent (that is, one or more of the eigenvalues of A lies outside the unit circle); however, A will still have been factored and the eigenvalues of A returned in WR and WI. - = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S + :e.info = 3: + if FACT = 'F' and DICO = 'C', but the Schur factor S supplied in the array A is not stable (that is, one or more of the eigenvalues of S has a non-negative real part), or DICO = 'D', but the Schur factor S supplied in the array A is not convergent (that is, one or more of the eigenvalues of S lies outside the unit circle); - = 4: if FACT = 'F' and the Schur factor S supplied in + :e.info = 4: + if FACT = 'F' and the Schur factor S supplied in the array A has two or more consecutive non-zero elements on the first sub-diagonal, so that there is a block larger than 2-by-2 on the diagonal; - = 5: if FACT = 'F' and the Schur factor S supplied in + :e.info = 5: + if FACT = 'F' and the Schur factor S supplied in the array A has a 2-by-2 diagonal block with real eigenvalues instead of a complex conjugate pair; - = 6: if FACT = 'N' and the LAPACK Library routine DGEES + :e.info = 6: + if FACT = 'N' and the LAPACK Library routine DGEES has failed to converge. This failure is not likely to occur. The matrix B will be unaltered but A will be destroyed. @@ -1049,15 +1053,10 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): elif m == 0: ldwork = 1 if dico != 'C' and dico != 'D': - e = ValueError('dico must be either D or C') - e.info = -1 - raise e + raise SlycotError('dico must be either D or C', -1) out = _wrapper.sb03od(dico,n,m,A,Q,B,fact=fact,trans=trans,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: if dico == 'D': error_text = """this means that while the matrix A @@ -1074,9 +1073,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): sense that small perturbations in A can make one or more of the eigenvalues have a non-negative real part;""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 2: if dico == 'D': error_text = """the matrix A is not convergent (that is, one or @@ -1087,9 +1084,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): error_text = """the matrix A is not stable (that is, one or more of the eigenvalues of A has a non-negative real part).""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 3: if dico == 'D': error_text = """the Schur factor S @@ -1101,35 +1096,27 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): supplied in the array A is not stable (that is, one or more of the eigenvalues of S has a non-negative real part).""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 4: if fact == 'F': error_text = """the Schur factor S supplied in the array A has two or more consecutive non-zero elements on the first sub-diagonal, so that there is a block larger than 2-by-2 on the diagonal.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 5: if fact == 'F': error_text = """the Schur factor S supplied in the array A has a 2-by-2 diagonal block with real eigenvalues instead of a complex conjugate pair.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 6: if fact == 'N': error_text = """the LAPACK Library routine DGEES has failed to converge. This failure is not likely to occur. The matrix B will be unaltered but A will be destroyed.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) U,scale,wr,wi = out[:-1] w = _np.zeros(n,'complex64') w.real = wr[0:n] @@ -1163,13 +1150,15 @@ def sb04md(n,m,A,B,C,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - > 0: if info = i, 1 <= i <= m, the QR algorithm failed to + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info > 0: + if info = i, 1 <= i <= m, the QR algorithm failed to compute all the eigenvalues of B (see LAPACK Library routine DGEES) - > m: if a singular matrix was encountered whilst solving + :e.info > m: + if a singular matrix was encountered whilst solving for the (info-m)-th column of matrix X. """ hidden = ' (hidden by the wrapper)' @@ -1181,22 +1170,15 @@ def sb04md(n,m,A,B,C,ldwork=None): else: out = _wrapper.sb04md(n,m,A,B,C,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value:"+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) elif out[-1] > m: error_text = """a singular matrix was encountered whilst solving for the %i-th column of matrix X.""" % (out[-1]-m) - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[2] def sb04qd(n,m,A,B,C,ldwork=None): @@ -1228,13 +1210,15 @@ def sb04qd(n,m,A,B,C,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value - > 0: if info = i, 1 <= i <= m, the QR algorithm failed to + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info => 0: + if info = i, 1 <= i <= m, the QR algorithm failed to compute all the eigenvalues of B (see LAPACK Library routine DGEES) - > m: if a singular matrix was encountered whilst solving + :e.info > m: + if a singular matrix was encountered whilst solving for the (info-m)-th column of matrix X. """ hidden = ' (hidden by the wrapper)' @@ -1246,22 +1230,15 @@ def sb04qd(n,m,A,B,C,ldwork=None): else: out = _wrapper.sb04qd(n,m,A,B,C,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value:"+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) elif out[-1] > m: error_text = """a singular matrix was encountered whilst solving for the %i-th column of matrix X.""" % (out[-1]-m) - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[2] def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None,ldwork=None): @@ -1387,39 +1364,49 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal - value; - = 1: if the matrix | A-j*omega*I B2 | had not full - | C1 D12 | - column rank in respect to the tolerance eps; - = 2: if the matrix | A-j*omega*I B1 | had not full row - | C2 D21 | - rank in respect to the tolerance eps; - = 3: if the matrix D12 had not full column rank in - respect to the tolerance SQRT(eps); - = 4: if the matrix D21 had not full row rank in respect - to the tolerance SQRT(eps); - = 5: if the singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21); - |C1 D12| |C2 D21| - = 6: if the controller is not admissible (too small value - of gamma); - = 7: if the X-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - = 8: if the Y-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is - zero [3]; - = 10: if there are numerical problems when estimating - singular values of D1111, D1112, D1111', D1121'; - = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22 - are singular to working precision; - = 12: if a stabilizing controller cannot be found. + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + if the matrix | A-j*omega*I B2 | had not full + | C1 D12 | + column rank in respect to the tolerance eps; + :e.info = 2: + if the matrix | A-j*omega*I B1 | had not full row + | C2 D21 | + rank in respect to the tolerance eps; + :e.info = 3: + if the matrix D12 had not full column rank in + respect to the tolerance SQRT(eps); + :e.info = 4: + if the matrix D21 had not full row rank in respect + to the tolerance SQRT(eps); + :e.info = 5: + if the singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices |A B2 |, |A B1 |, D12 or D21); + |C1 D12| |C2 D21| + :e.info = 6: + if the controller is not admissible (too small value of gamma); + :e.info = 7: + if the X-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :e.info = 8: + if the Y-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :e.info = 9: + if the determinant of Im2 + Tu*D11HAT*Ty*D22 is + zero [3]; + :e.info = 10: + if there are numerical problems when estimating + singular values of D1111, D1112, D1111', D1121'; + :e.info = 11: + if the matrices Inp2 - D22*DK or Im2 - DK*D22 + are singular to working precision; + :e.info = 12: + if a stabilizing controller cannot be found. """ hidden = ' (hidden by the wrapper)' @@ -1498,9 +1485,7 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, to working precision." if out[-1] == 12: error_text = "A stabilizing controller cannot be found." - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[:-1] @@ -1621,33 +1606,40 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if INFO = -i, the i-th argument had an illegal - value; - j*Theta - = 1: if the matrix | A-e *I B2 | had not full - | C1 D12 | + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1 + j*Theta + if the matrix | A-e *I B2 | had not full + | C1 D12 | column rank; - j*Theta - = 2: if the matrix | A-e *I B1 | had not full - | C2 D21 | - row rank; - = 3: if the matrix D12 had not full column rank; - = 4: if the matrix D21 had not full row rank; - = 5: if the controller is not admissible (too small value - of gamma); - = 6: if the X-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - = 7: if the Z-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - = 8: if the matrix Im2 + DKHAT*D22 is singular. - = 9: if the singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21). - |C1 D12| |C2 D21| + :e.info = 2 + j*Theta + if the matrix | A-e *I B1 | had not full + | C2 D21 | + row rank; + :e.info = 3: + if the matrix D12 had not full column rank; + :e.info = 4: + if the matrix D21 had not full row rank; + :e.info = 5: + if the controller is not admissible (too small value of gamma); + :e.info = 6: + if the X-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :e.info = 7: + if the Z-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :e.info = 8: + if the matrix Im2 + DKHAT*D22 is singular. + :e.info = 9: + if the singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices |A B2 |, |A B1 |, D12 or D21). + |C1 D12| |C2 D21| """ hidden = ' (hidden by the wrapper)' @@ -1702,9 +1694,7 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): did not converge (when computing the SVD of one of\ the matrices |A B2 |, |A B1 |, D12 or D21).\ |C1 D12| |C2 D21|" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[:-1] @@ -1793,21 +1783,23 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal - value; - = 1: if the matrix D12 had not full column rank in - respect to the tolerance tol; - = 2: if the matrix D21 had not full row rank in respect - to the tolerance tol; - = 3: if the singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices D12 or D21). - = 4: if the X-Riccati equation was not solved - successfully; - = 5: if the Y-Riccati equation was not solved - successfully. + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + if the matrix D12 had not full column rank in + respect to the tolerance tol; + :e.info = 2: + if the matrix D21 had not full row rank in respect + to the tolerance tol; + :e.info = 3: + if the singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices D12 or D21). + :e.info = 4: + if the X-Riccati equation was not solved successfully; + :e.info = 5: + if the Y-Riccati equation was not solved successfully. """ hidden = ' (hidden by the wrapper)' @@ -1842,9 +1834,7 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): error_text = "The Y-Riccati equation was not solved successfully\ (the controller is not admissible or there are numerical\ difficulties)." - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[:-1] @@ -1912,18 +1902,11 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): A,B,C,D,nsys,info = _wrapper.sb10jd(n,m,np,A,B,C,D,E,ldwork) if info < 0: - error_text = "The following argument had an illegal value: "+arg_list[-info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) elif info == 1: - e = ArithmeticError("The sb10jd algorithm did not converge") - e.info = 1 - raise e + raise SlycotArithmeticError("The sb10jd algorithm did not converge", 1) elif info != 0: - e = ArithmeticError('sb10jd failed') - e.info = info - raise e + raise SlycotArithmeticError('sb10jd failed', info) return A[:nsys,:nsys],B[:nsys,:m],C[:np, :nsys],D[:np, :m] @@ -2118,30 +2101,33 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal - value; - = 1: FACT = 'F' and the matrix contained in the upper - Hessenberg part of the array A is not in upper - quasitriangular form; - = 2: FACT = 'N' and the pencil A - lambda * E cannot be - reduced to generalized Schur form: LAPACK routine - DGEGS has failed to converge; - = 3: DICO = 'D' and the pencil A - lambda * E has a - pair of reciprocal eigenvalues. That is, lambda_i = - 1/lambda_j for some i and j, where lambda_i and - lambda_j are eigenvalues of A - lambda * E. Hence, - equation (2) is singular; perturbed values were - used to solve the equation (but the matrices A and - E are unchanged); - = 4: DICO = 'C' and the pencil A - lambda * E has a - degenerate pair of eigenvalues. That is, lambda_i = - -lambda_j for some i and j, where lambda_i and - lambda_j are eigenvalues of A - lambda * E. Hence, - equation (1) is singular; perturbed values were - used to solve the equation (but the matrices A and - E are unchanged). + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + FACT = 'F' and the matrix contained in the upper + Hessenberg part of the array A is not in upper + quasitriangular form; + :e.info = 2: + FACT = 'N' and the pencil A - lambda * E cannot be + reduced to generalized Schur form: LAPACK routine + DGEGS has failed to converge; + :e.info = 3: + DICO = 'D' and the pencil A - lambda * E has a + pair of reciprocal eigenvalues. That is, lambda_i = + 1/lambda_j for some i and j, where lambda_i and + lambda_j are eigenvalues of A - lambda * E. Hence, + equation (2) is singular; perturbed values were + used to solve the equation (but the matrices A and + E are unchanged); + :e.info = 4: + DICO = 'C' and the pencil A - lambda * E has a + degenerate pair of eigenvalues. That is, lambda_i = + -lambda_j for some i and j, where lambda_i and + lambda_j are eigenvalues of A - lambda * E. Hence, + equation (1) is singular; perturbed values were + used to solve the equation (but the matrices A and + E are unchanged). """ hidden = ' (hidden by the wrapper)' @@ -2190,10 +2176,7 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): equation (1) is singular; perturbed values were \ used to solve the equation (but the matrices A and \ E are unchanged)" - - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[:-1] @@ -2500,25 +2483,31 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if INFO = -i, the i-th argument had an illegal - value; - = 1: if the computed extended matrix pencil is singular, - possibly due to rounding errors; - = 2: if the QZ algorithm failed; - = 3: if reordering of the generalized eigenvalues failed; - = 4: if after reordering, roundoff changed values of - some complex eigenvalues so that leading eigenvalues - in the generalized Schur form no longer satisfy the - stability condition; this could also be caused due - to scaling; - = 5: if the computed dimension of the solution does not - equal N; - = 6: if the spectrum is too close to the boundary of - the stability domain; - = 7: if a singular matrix was encountered during the - computation of the solution matrix X. + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + if the computed extended matrix pencil is singular, + possibly due to rounding errors; + :e.info = 2: + if the QZ algorithm failed; + :e.info = 3: + if reordering of the generalized eigenvalues failed; + :e.info = 4: + if after reordering, roundoff changed values of + some complex eigenvalues so that leading eigenvalues + in the generalized Schur form no longer satisfy the + stability condition; this could also be caused due + to scaling; + :e.info = 5: + if the computed dimension of the solution does not + equal N; + :e.info = 6: + if the spectrum is too close to the boundary of + the stability domain; + :e.info = 7: + if a singular matrix was encountered during the + computation of the solution matrix X. """ hidden = ' (hidden by the wrapper)' @@ -2575,9 +2564,7 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, elif out[-1] == 7: error_text = "A singular matrix was encountered during the\ computation of the solution matrix X" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) return out[:-1] @@ -2721,34 +2708,39 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): eigenvalues of the matrix pencil A - lambda * E. Raises - ______ - - ValueError : e - e.info contains information about the exact type of exception - = 0: successful exit; - < 0: if info = -i, the i-th argument had an illegal - value; - = 1: the pencil A - lambda * E is (nearly) singular; - perturbed values were used to solve the equation - (but the reduced (quasi)triangular matrices A and E - are unchanged); - = 2: fact = 'F' and the matrix contained in the upper - Hessenberg part of the array A is not in upper - quasitriangular form; - = 3: fact = 'F' and there is a 2-by-2 block on the main - diagonal of the pencil A_s - lambda * E_s whose - eigenvalues are not conjugate complex; - = 4: fact = 'N' and the pencil A - lambda * E cannot be - reduced to generalized Schur form: LAPACK routine - DGEGS (or DGGES) has failed to converge; - = 5: dico = 'C' and the pencil A - lambda * E is not - c-stable; - = 6: dico = 'D' and the pencil A - lambda * E is not - d-stable; - = 7: the LAPACK routine DSYEVX utilized to factorize M3 - failed to converge in the discrete-time case (see - section METHOD for SLICOT Library routine SG03BU). - This error is unlikely to occur. + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + the pencil A - lambda * E is (nearly) singular; + perturbed values were used to solve the equation + (but the reduced (quasi)triangular matrices A and E + are unchanged); + :e.info = 2: + fact = 'F' and the matrix contained in the upper + Hessenberg part of the array A is not in upper + quasitriangular form; + :e.info = 3: + fact = 'F' and there is a 2-by-2 block on the main + diagonal of the pencil A_s - lambda * E_s whose + igenvalues are not conjugate complex; + :e.info = 4: + fact = 'N' and the pencil A - lambda * E cannot be + reduced to generalized Schur form: LAPACK routine + DGEGS (or DGGES) has failed to converge; + :e.info = 5: + dico = 'C' and the pencil A - lambda * E is not + c-stable; + :e.info = 6: + dico = 'D' and the pencil A - lambda * E is not + d-stable; + :e.info = 7: + the LAPACK routine DSYEVX utilized to factorize M3 + failed to converge in the discrete-time case (see + section METHOD for SLICOT Library routine SG03BU). + This error is unlikely to occur. """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'fact', 'trans', 'n', 'm', 'A', 'LDA'+hidden, 'E', @@ -2758,64 +2750,45 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): if ldwork is None: ldwork = max(1,4*n,6*n-6) if dico != 'C' and dico != 'D': - e = ValueError('dico must be either D or C') - e.info = -1 - raise e + raise SlycotError('dico must be either D or C', -1) out = _wrapper.sg03bd(dico,n,m,A,E,Q,Z,B,fact=fact,trans=trans,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: error_text = """the pencil A - lambda * E is (nearly) singular; perturbed values were used to solve the equation (but the reduced (quasi)triangular matrices A and E are unchanged).""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 2: error_text = """the matrix contained in the upper Hessenberg part of the array A is not in upper quasitriangular form.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 3: error_text = """there is a 2-by-2 block on the main diagonal of the pencil A_s - lambda * E_s whose eigenvalues are not conjugate complex.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 4: error_text = """the pencil A - lambda * E cannot be reduced to generalized Schur form: LAPACK routine DGEGS (or DGGES) has failed to converge.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 5: error_text = """the pencil A - lambda * E is not c-stable.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 6: error_text = """the pencil A - lambda * E is not d-stable.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 7: error_text = """the LAPACK routine DSYEVX utilized to factorize M3 failed to converge in the discrete-time case (see section METHOD for SLICOT Library routine SG03BU). This error is unlikely to occur.""" - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) U,scale,alphar,alphai,beta = out[:-1] alpha = _np.zeros(n,'complex64') alpha.real = alphar[0:n] From de6e3dfdd7ad8de11d534ad0142d5430820fdae6 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 4 May 2020 13:34:58 +0200 Subject: [PATCH 165/405] migrate transform to new exceptions --- slycot/transform.py | 296 ++++++++++++++++++-------------------------- 1 file changed, 119 insertions(+), 177 deletions(-) diff --git a/slycot/transform.py b/slycot/transform.py index 0e758f60..85f3367c 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -18,6 +18,9 @@ # MA 02110-1301, USA. from . import _wrapper +from .exceptions import SlycotError, SlycotParameterError, \ + SlycotArithmeticError + import numpy as _np def tb01id(n,m,p,maxred,a,b,c,job='A'): @@ -96,10 +99,7 @@ def tb01id(n,m,p,maxred,a,b,c,job='A'): 'LDB'+hidden, 'C', 'LDC'+hidden, 'scale', 'INFO'+hidden] out = _wrapper.tb01id(n,m,p,maxred,a,b,c,job=job) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): @@ -214,30 +214,24 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): ldwork = max( 2*n + 3*max(m,p), p*(p+2)) out = _wrapper.tb03ad_l(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0: - e = ArithmeticError('a singular matrix was encountered during the computation') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'a singular matrix was encountered during the computation', + out[-1]) return out[:-1] if leri == 'R': if ldwork is None: ldwork = max( 2*n + 3*max(m,p), m*(m+2)) out = _wrapper.tb03ad_r(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0: - e = ArithmeticError('a singular matrix was encountered during the computation') - e.info = out[-1] - raise e + raise SlycotArithmeticError( + 'a singular matrix was encountered during the computation', + out[-1]) return out[:-1] - raise ValueError('leri must be either L or R') + raise SlycotError('leri must be either L or R', -1) def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): """ Ar,Br,Cr,nr,denom_degs,denom_coeffs,num_coeffs = tb04ad(n,m,p,A,B,C,D,[tol1,tol2,ldwork]) @@ -294,11 +288,6 @@ def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): ucoeff : rank-3 array, shape (p,m,max(index)+1) array of numerator coefficients - Raises - ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; """ hidden = ' (hidden by the wrapper)' arg_list = ['rowcol','n','m','p','A','lda'+hidden,'B','ldb'+hidden,'C','ldc'+hidden,'D', 'ldd'+hidden, @@ -308,25 +297,23 @@ def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): porm, porp = p, m if ldwork is None: ldwork = max(1,n*(n+1)+max(n*mp+2*n+max(n,mp),3*mp,pm)) - if B.shape != (n,m): - e = ValueError("The shape of B is ("+str(B.shape[0])+","+str(B.shape[1])+"), but expected ("+str(n)+","+str(m)+")") - e.info = -7 - raise e - if C.shape != (p,n): - e = ValueError("The shape of C is ("+str(C.shape[0])+","+str(C.shape[1])+"), but expected ("+str(p)+","+str(n)+")") - e.info = -9 - raise e - if D.shape != (max(1,p),m): - e = ValueError("The shape of D is ("+str(B.shape[0])+","+str(B.shape[1])+"), but expected ("+str(max(1,p))+","+str(m)+")") - e.info = -11 - raise e + if B.shape != (n, m): + raise SlycotError("The shape of B is ({}, {}), " + "but expected ({}, {})".format(*B.shape, n, m), + -7) + if C.shape != (p, n): + raise SlycotError("The shape of C is ({}, {}), " + "but expected ({}, {})".format(*C.shape, p, n), + -9) + if D.shape != (max(1, p), m): + raise SlycotError("The shape of D is ({}, {}), " + "but expected ({}, {})".format(*D.shape, + max(1, p), m), + -11) out = _wrapper.tb04ad_r(n,m,p,A,B,C,D,tol1,tol2,ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) A,B,C,Nr,index,dcoeff,ucoeff = out[:-1] kdcoef = max(index)+1 @@ -469,13 +456,17 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): Raises ------ - ValueError : e - e.info contains information about the exact type of exception. - < 0 : if info = -i, the ith argument had an illegal value; - = 1 : More than 30 iterations were required to isolate the - eigenvalues of A. The computation is continued ?. - = 2 : Either FREQ is too near to an eigenvalue of A, or RCOND - is less than the machine precision EPS. + + SlycotParameterError : e + :e.info = -i: + the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + More than 30 iterations were required to isolate the + eigenvalues of A. The computation is continued ?. + :e.info = 2: + Either FREQ is too near to an eigenvalue of A, or RCOND + is less than the machine precision EPS. Example ------- @@ -494,26 +485,16 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): """ def error_handler(out, arg_list): if out[-1] < 0: - # Conform fortran 1-based argument indexing to - # to python zero indexing. - error_text = ("The following argument had an illegal value: " - + arg_list[-out[-1]-1]) - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: error_text = ("More than 30 iterations are required " "to isolate the eigenvalue of A; the computations " "are continued.") - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) if out[-1] == 2: error_text = ("Either FREQ is too near to an eigenvalue of A, or " "RCOND is less than the machine precision EPS.") - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError(error_text, out[-1]) hidden = ' (hidden by the wrapper)' arg_list = ['baleig'+hidden, 'inita'+hidden, 'n', 'm', 'p', 'freq', 'a', @@ -527,21 +508,17 @@ def error_handler(out, arg_list): # Sanity check on matrix dimensions if A.shape != (n, n): - e = ValueError("The shape of A is (" + str(A.shape[0]) + "," + - str(A.shape[1]) + "), but expected (" + str(n) + - "," + str(n) + ")") - raise e - + raise SlycotError("The shape of A is ({0:}, {1:}), " + "but expected ({2:}, {2:})".format(*A.shape, n), + -7) if B.shape != (n, m): - e = ValueError("The shape of B is (" + str(B.shape[0]) + "," + - str(B.shape[1]) + "), but expected (" + str(n) + - "," + str(m) + ")") - raise e + raise SlycotError("The shape of B is ({0:}, {1:}), " + "but expected ({2:}, {3:})".format(*B.shape, n, m), + -9) if C.shape != (p, n): - e = ValueError("The shape of C is (" + str(C.shape[0]) + "," + - str(C.shape[1]) + "), but expected (" + str(p) + - "," + str(n) + ")") - raise e + raise SlycotError("The shape of C is ({0:}, {1:}), " + "but expected ({2:}, {3:})".format(*C.shape, p, n), + -11) # ---------------------------------------------------- # Checks done, do computation. @@ -569,10 +546,9 @@ def error_handler(out, arg_list): info = out[-1] return g_i, hinvb, info else: - error_text = ("Unrecognized job. Expected job = 'AG' or " - "job='NG' or job = 'NH' but received job=%s"%job) - e = ValueError(error_text) - raise e + raise SlycotError("Unrecognized job. Expected job = 'AG' or " + "job='NG' or job = 'NH' but received job=%s" % job, + 0) def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): @@ -629,15 +605,16 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): Raises ------ - ValueError : e - e.info contains information about the exact type of exception - < 0: if info = -i, the i-th argument had an illegal value; - > 0: if info = i, then i is the first integer for which - abs( dcoeff(i,1) ) is so small that the calculations - would overflow (see SLICOT Library routine TD03AY); - that is, the leading coefficient of a polynomial is - nearly zero; no state-space representation is - calculated. + SlycotParameterError : e + :e.info = -i: + the i-th argument had an illegal value; + SlycotArithmeticError : e + if e.info = i, then i is the first integer for which + abs( dcoeff(i,1) ) is so small that the calculations + would overflow (see SLICOT Library routine TD03AY); + that is, the leading coefficient of a polynomial is + nearly zero; no state-space representation is + calculated. """ hidden = ' (hidden by the wrapper)' arg_list = ['rowcol','m','p','index','dcoeff','lddcoe'+hidden, 'ucoeff', 'lduco1'+hidden,'lduco2'+hidden, @@ -650,48 +627,48 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): kdcoef = max(index)+1 if rowcol == 'R': if ucoeff.ndim != 3: - e = ValueError("The numerator is not a 3D array!") - e.info = -7 - raise e - if ucoeff.shape != (max(1,p),max(1,m),kdcoef): - e = ValueError("The numerator shape is ("+str(ucoeff.shape[0])+","+str(ucoeff.shape[1])+","+str(ucoeff.shape[2])+"), but expected ("+str(max(1,p))+","+str(max(1,m))+","+str(kdcoef)+")") - e.info = -7 - raise e - if dcoeff.shape != (max(1,p),kdcoef): - e = ValueError("The denominator shape is ("+str(dcoeff.shape[0])+","+str(dcoeff.shape[1])+"), but expected ("+str(max(1,p))+","+str(kdcoef)+")") - e.info = -5 - raise e + raise SlycotError("The numerator is not a 3D array!", -7) + expectedshape = (max(1, p), max(1, m), kdcoef) + if ucoeff.shape != expectedshape: + raise SlycotError("The numerator shape is ({}, {}, {}), " + "but expected ({}, {}, {})" + "".format(*ucoeff.shape, *expectedshape), + -7) + expectedshape = (max(1, p), kdcoef) + if dcoeff.shape != expectedshape: + raise SlycotError("The denominator shape is ({}, {}), " + "but expected ({}, {})" + "".format(*dcoeff.shape, *expectedshape), + -5) out = _wrapper.td04ad_r(m,p,index,dcoeff,ucoeff,n,tol,ldwork) elif rowcol == 'C': if ucoeff.ndim != 3: - e = ValueError("The numerator is not a 3D array!") - e.info = -7 - raise e - if ucoeff.shape != (max(1,m,p),max(1,m,p),kdcoef): - e = ValueError("The numerator shape is ("+str(ucoeff.shape[0])+","+str(ucoeff.shape[1])+","+str(ucoeff.shape[2])+"), but expected ("+str(max([1,m,p]))+","+str(max([1,m,p]))+","+str(kdcoef)+")") - e.info = -7 - raise e - if dcoeff.shape != (max(1,m),kdcoef): - e = ValueError("The denominator shape is ("+str(dcoeff.shape[0])+","+str(dcoeff.shape[1])+"), but expected ("+str(max(1,m))+","+str(kdcoef)+")") - e.info = -5 - raise e + raise SlycotError("The numerator is not a 3D array!", -7) + expectedshape = (max(1, m, p), max(1, m, p), kdcoef) + if ucoeff.shape != expectedshape: + raise SlycotError("The numerator shape is ({}, {}, {}), " + "but expected ({}, {}, {})" + "".format(*ucoeff.shape, *expectedshape), + -7) + expectedshape = (max(1, m), kdcoef) + if dcoeff.shape != expectedshape: + raise SlycotError("The denominator shape is ({}, {}), " + "but expected ({}, {})" + "".format(*dcoeff.shape, *expectedshape), + -5) out = _wrapper.td04ad_c(m,p,index,dcoeff,ucoeff,n,tol,ldwork) else: - e = ValueError("Parameter rowcol had an illegal value") - e.info = -1 - raise e + raise SlycotError("Parameter rowcol had an illegal value", -1) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] > 0: - error_text = "The leading coefficient of a denominator polynomial is nearly zero; calculations would overflow; no state-space representation was calculated. ABS(DCOEFF("+str(out[-1])+",1))="+str(abs(dcoeff[out[-1],1]))+" is too small." - print(dcoeff) - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotArithmeticError( + "The leading coefficient of a denominator polynomial is nearly " + "zero; calculations would overflow; no state-space representation " + "was calculated. ABS(DCOEFF({},1))={} is too small." + "".format(out[-1],(abs(dcoeff[out[-1],1]))), + out[-1]) Nr, A, B, C, D = out[:-1] return Nr, A[:Nr,:Nr], B[:Nr,:m], C[:p,:Nr], D[:p,:m] @@ -781,28 +758,18 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): if leri == 'L': out = _wrapper.tc04ad_l(m,p,index,pcoeff,qcoeff,n) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('P(s) is not row proper') - e.info = out[-1] - raise e + raise SlycotArithmeticError('P(s) is not row proper', out[-1]) return out[:-1] if leri == 'R': out = _wrapper.tc04ad_r(m,p,index,pcoeff,qcoeff,n) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) if out[-1] == 1: - e = ArithmeticError('P(s) is not column proper') - e.info = out[-1] - raise e + raise SlycotArithmeticError('P(s) is not column proper', out[-1]) return out[:-1] - raise ValueError('leri must be either L or R') + raise SlycotError('leri must be either L or R', -1) def tc01od(m,p,indlin,pcoeff,qcoeff,leri): """ pcoeff,qcoeff = tc01od_l(m,p,indlim,pcoeff,qcoeff,leri) @@ -853,20 +820,14 @@ def tc01od(m,p,indlin,pcoeff,qcoeff,leri): if leri == 'L': out = _wrapper.tc01od_l(m,p,indlin,pcoeff,qcoeff) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] if leri == 'R': out = _wrapper.tc01od_r(m,p,indlin,pcoeff,qcoeff) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] - raise ValueError('leri must be either L or R') + raise SlycotError('leri must be either L or R', -1) def tf01md(n,m,p,N,A,B,C,D,u,x0): """ xf,y = tf01md(n,m,p,N,A,B,C,D,u,x0) @@ -908,10 +869,7 @@ def tf01md(n,m,p,N,A,B,C,D,u,x0): out = _wrapper.tf01md(n,m,p,N,A,B,C,D,u,x0) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] def tf01rd(n,m,p,N,A,B,C,ldwork=None): @@ -956,10 +914,7 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): else: out = _wrapper.tf01rd(n,m,p,N,A,B,C,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: "+arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[0] def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): @@ -1035,16 +990,12 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): if ldwork is None: ldwork = max(1, n+max(n,3*m,3*p)) elif ldwork < max(1, n+max(n,3*m,3*p)): - raise ValueError("ldwork is too small") + raise SlycotError("ldwork is too small", -15) out = _wrapper.tb01pd(n=n,m=m,p=p,a=A,b=B,c=C, job=job,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - error_text = "The following argument had an illegal value: " + \ - arg_list[-out[-1]-1] - e = ValueError(error_text) - e.info = out[-1] - raise e + raise SlycotParameterError(out[-1], arg_list) return out[:-1] def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): @@ -1139,19 +1090,14 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): arg_list = ['job', 'l', 'n', 'm', 'p', 'thresh', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden, 'lscale', 'rscale', 'dwork'+hidden, 'info'] if job != 'A' and job != 'B' and job != 'C' and job != 'N': - raise ValueError('Parameter job had an illegal value') + raise SlycotError('Parameter job had an illegal value', -1) A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) if info < 0: - error_text = "The following argument had an illegal value: "+arg_list[-info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if info != 0: - e = ArithmeticError('tg01ad failed') - e.info = info - raise e + raise SlycotArithmeticError('tg01ad failed', info) return A,E,B,C,lscale,rscale @@ -1312,13 +1258,13 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld if compq != 'N' and compq != 'I' and compq != 'U': - raise ValueError('Parameter compq had an illegal value') + raise SlycotError('Parameter compq had an illegal value', -1) if compz != 'N' and compz != 'I' and compz != 'U': - raise ValueError('Parameter compz had an illegal value') + raise SlycotError('Parameter compz had an illegal value', -2) if joba != 'N' and joba != 'R' and joba != 'T': - raise ValueError('Parameter joba had an illegal value') + raise SlycotError('Parameter joba had an illegal value', -3) if ldwork is None: ldwork = max(1, n+p, min(l,n) + max(3*n-1, m, l)) @@ -1333,17 +1279,13 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld elif compq == 'U' and compz == 'U': A,E,B,C,Q,Z,ranke,rnka22,info = _wrapper.tg01fd_uu(joba,l,n,m,p,A,E,B,C,Q,Z,tol,ldwork) else: - raise ValueError("The combination of compq and compz in not implemented") + raise SlycotError( + "The combination of compq and compz is not implemented", -1) if info < 0: - error_text = "The following argument had an illegal value: "+arg_list[-info-1] - e = ValueError(error_text) - e.info = info - raise e + raise SlycotParameterError(info, arg_list) if info != 0: - e = ArithmeticError('tg01fd failed') - e.info = info - raise e + raise SlycotArithmeticError('tg01fd failed', info) if joba == 'N': rnka22 = None From 37e45d10af21e42788b960c8ed75bdc7c4d72d3c Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 4 May 2020 16:10:01 +0200 Subject: [PATCH 166/405] unify exception call signature --- slycot/analysis.py | 89 +++++++++++++-------------- slycot/exceptions.py | 23 ++++--- slycot/math.py | 20 +++---- slycot/synthesis.py | 43 ++++++------- slycot/transform.py | 139 ++++++++++++++++++++++--------------------- 5 files changed, 157 insertions(+), 157 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index d9ce82e6..a8ada448 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -20,6 +20,7 @@ from . import _wrapper from .exceptions import SlycotError, SlycotParameterError, \ SlycotArithmeticError + import warnings def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): @@ -123,21 +124,21 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): if jobz == 'N': out = _wrapper.ab01nd_n(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) # sets Z to None out[5] = None return out[:-1] if jobz == 'I': out = _wrapper.ab01nd_i(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] if jobz == 'F': out = _wrapper.ab01nd_f(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] - raise SlycotError('jobz must be either N, I or F', 0) + raise SlycotParameterError('jobz must be either N, I or F', -1) def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): """ n,a,b,c,d = ab05md(n1,m1,p1,n2,p2,a1,b1,c1,d1,a2,b2,c2,d2,[uplo]) @@ -221,7 +222,7 @@ def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): 'ldwork', 'info'+hidden ] out = _wrapper.ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo=uplo) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): @@ -304,7 +305,7 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): ldwork = max(p1*p1,m1*m1,n1*p1) out = _wrapper.ab05nd(n1,m1,p1,n2,alpha,A1,B1,C1,D1,A2,B2,C2,D2,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'The resulting system is not completely controllable.', @@ -362,7 +363,7 @@ def ab07nd(n,m,A,B,C,D,ldwork=None): ldwork = max(1,4*m) out = _wrapper.ab07nd(n,m,A,B,C,D,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == m+1: raise SlycotArithmeticError( 'Entry matrix D is numerically singular.', @@ -456,7 +457,7 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): ldwork = n+3*max(m,p) #only an upper bound out = _wrapper.ab08nd(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): @@ -562,7 +563,7 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, zwork, info \ = out if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, int(zwork[0].real)) @@ -659,11 +660,11 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise SlycotError('Parameter dico had an illegal value', 0) + raise SlycotParameterError('Parameter dico had an illegal value', -1) if job != 'B' and job != 'N': - raise SlycotError('Parameter job had an illegal value', 0) + raise SlycotParameterError('Parameter job had an illegal value', -2) if equil != 'S' and equil != 'N': - raise SlycotError('Parameter equil had an illegal value', 0) + raise SlycotParameterError('Parameter equil had an illegal value', -3) out = _wrapper.ab09ad(dico,job,equil,ordsel,n,m,p,nr,A,B,C,tol,ldwork) if out[-2] == 1: warnings.warn("The selected order nr is greater\ @@ -672,7 +673,7 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): corresponding to the order of a minimal realization\ of the system") if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError( 'The reduction of A to the real Schur form failed', @@ -790,9 +791,9 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise SlycotError('Parameter dico had an illegal value', 0) + raise SlycotParameterError('Parameter dico had an illegal value', -1) if job != 'B' and job != 'N': - raise SlycotError('Parameter job had an illegal value', 0) + raise SlycotParameterError('Parameter job had an illegal value', -2) out = _wrapper.ab09ax(dico,job,ordsel,n,m,p,nr,A,B,C,tol,ldwork) if out[-2] == 1: warnings.warn("The selected order nr is greater\ @@ -801,7 +802,7 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): corresponding to the order of a minimal realization\ of the system") if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError( 'The state matrix A is not stable or not convergent', @@ -930,11 +931,11 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise SlycotError('Parameter dico had an illegal value', 0) + raise SlycotParameterError('Parameter dico had an illegal value', -1) if job != 'B' and job != 'N': - raise SlycotError('Parameter job had an illegal value', 0) + raise SlycotParameterError('Parameter job had an illegal value', -2) if equil != 'S' and equil != 'N': - raise SlycotError('Parameter equil had an illegal value', 0) + raise SlycotParameterError('Parameter equil had an illegal value', -3) out = _wrapper.ab09bd(dico,job,equil,ordsel,n,m,p,nr,A,B,C,D,tol1,tol2,ldwork) if out[-2] == 1: warnings.warn("The selected order nr is greater\ @@ -943,7 +944,7 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): corresponding to the order of a minimal realization\ of the system") if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError( 'The reduction of A to the real Schur form failed', @@ -1094,16 +1095,16 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise SlycotError('Parameter dico had an illegal value', 0) + raise SlycotParameterError('Parameter dico had an illegal value', -1) if alpha is None: if dico == 'C': alpha = 0. elif dico == 'D': alpha = 1. if job != 'B' and job != 'N': - raise SlycotError('Parameter job had an illegal value', 0) + raise SlycotParameterError('Parameter job had an illegal value', -2) if equil != 'S' and equil != 'N': - raise SlycotError('Parameter equil had an illegal value', 0) + raise SlycotParameterError('Parameter equil had an illegal value', -3) out = _wrapper.ab09md(dico,job,equil,ordsel,n,m,p,nr,alpha,A,B,C,tol,ldwork) if out[-2] == 1: warnings.warn("with ordsel = 'F', the selected order nr is greater\ @@ -1118,7 +1119,7 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): given system. In this case nr is set equal to the\ order of the alpha-unstable part.") if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError( 'The reduction of A to the real Schur form failed', @@ -1265,16 +1266,16 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= else: ordsel = 'F' if dico != 'C' and dico != 'D': - raise SlycotError('Parameter dico had an illegal value', 0) + raise SlycotParameterError('Parameter dico had an illegal value', -1) if alpha is None: if dico == 'C': alpha = 0. elif dico == 'D': alpha = 1. if job != 'B' and job != 'N': - raise SlycotError('Parameter job had an illegal value', 0) + raise SlycotParameterError('Parameter job had an illegal value', -2) if equil != 'S' and equil != 'N': - raise SlycotError('Parameter equil had an illegal value', 0) + raise SlycotParameterError('Parameter equil had an illegal value', -3) out = _wrapper.ab09nd(dico,job,equil,ordsel,n,m,p,nr,alpha,A,B,C,D,tol1,tol2,ldwork) if out[-2] == 1: warnings.warn("with ordsel = 'F', the selected order nr is greater\ @@ -1289,7 +1290,7 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= given system. In this case nr is set equal to the\ order of the alpha-unstable part.") if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError( 'The reduction of A to the real Schur form failed', @@ -1350,9 +1351,9 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): """ if dico != 'C' and dico != 'D': - raise SlycotError('dico must be "C" or "D"', 0) + raise SlycotParameterError('dico must be "C" or "D"', -1) if jobn != 'H' and jobn != 'L': - raise SlycotError('jobn must be "H" or "L"', 0) + raise SlycotParameterError('jobn must be "H" or "L"', -2) out = _wrapper.ab13bd(dico, jobn, n, m, p, A, B, C, D, tol) if out[-1] == 0: # success @@ -1362,7 +1363,7 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): arg_list = ['dico', 'jobn', 'n', 'm', 'p', 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nq'+hidden,'tol', 'dwork'+hidden, 'ldwork'+hidden, 'iwarn'+hidden, 'info'+hidden] - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) elif out[-1] == 1: raise SlycotArithmeticError( "the reduction of A to a real Schur form failed", @@ -1392,7 +1393,7 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): "JOBN = 'H' and the system is unstable", out[-1]) else: - raise RuntimeError("unknown error code %r" % out[-1]) + raise SlycotError("unknown error code %r" % out[-1], out[-1]) def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): """gpeak, fpeak = ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, [tol]) @@ -1470,13 +1471,13 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): """ if dico != 'C' and dico != 'D': - raise SlycotError('dico must be "C" or "D"', 0) + raise SlycotParameterError('dico must be "C" or "D"', -1) if jobe != 'G' and jobe != 'I': - raise SlycotError('jobe must be "G" or "I"', 0) + raise SlycotParameterError('jobe must be "G" or "I"', -2) if equil != 'S' and equil != 'N': - raise SlycotError('equil must be "S" or "N"', 0) + raise SlycotParameterError('equil must be "S" or "N"', -3) if jobd != 'D' and jobd != 'Z': - raise SlycotError('jobd must be "D" or "Z"', 0) + raise SlycotParameterError('jobd must be "D" or "Z"', -4) out = _wrapper.ab13dd(dico, jobe, equil, jobd, n, m, p, [0.0, 1.0], A, E, B, C, D, tol) if out[-1] == 0: # success @@ -1489,7 +1490,7 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'gpeak'+hidden, 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden] - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) elif out[-1] == 1: raise SlycotArithmeticError( "the matrix E is (numerically) singular", @@ -1508,7 +1509,7 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): "the tolerance is too small and the algorithm did not converge", out[-1]) else: - raise RuntimeError("unknown error code %r" % out[-1]) + raise SlycotError("unknown error code %r" % out[-1], out[-1]) def ab13ed(n, A, tol = 9.0): """low, high = ab13ed(n, A, [tol]) @@ -1563,13 +1564,13 @@ def ab13ed(n, A, tol = 9.0): hidden = ' (hidden by the wrapper)' arg_list = ['n', 'A', 'lda'+hidden, 'low'+hidden, 'high'+hidden, 'tol', 'dwork'+hidden, 'ldwork'+hidden, 'info'+hidden] - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) elif out[-1] == 1: raise SlycotArithmeticError( "the QR algorithm fails to converge", out[-1]) else: - raise RuntimeError("unknown error code %r" % out[-1]) + raise SlycotError("unknown error code %r" % out[-1], out[-1]) def ab13fd(n, A, tol = 0.0): """beta, omega = ab13fd(n, A, [tol]) @@ -1627,7 +1628,7 @@ def ab13fd(n, A, tol = 0.0): hidden = ' (hidden by the wrapper)' arg_list = ['n', 'A', 'lda'+hidden, 'beta'+hidden, 'omega'+hidden, 'tol', 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden] - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) elif out[-1] == 1: warnings.warn("the routine fails to compute beta(A) within the specified tolerance") return out[0], out[1] # the returned value is an upper bound on beta(A) @@ -1636,7 +1637,7 @@ def ab13fd(n, A, tol = 0.0): "either the QR or SVD algorithm fails to converge", out[-1]) else: - raise RuntimeError("unknown error code %r" % out[-1]) + raise SlycotError("unknown error code %r" % out[-1], out[-1]) def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) @@ -1728,7 +1729,7 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): arg_list = ['equil', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nfz', 'nrank', 'niz', 'dinfz', 'nkror', 'ninfe', 'nkrol', 'infz', 'kronr', 'infe', 'kronl', 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] if equil != 'S' and equil != 'N': - raise SlycotError('Parameter equil had an illegal value', 0) + raise SlycotParameterError('Parameter equil had an illegal value', -1) if ldwork is None: ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)) @@ -1740,7 +1741,7 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): [Af,Ef,nfz,nrank,niz,dinfz,nkror,ninfe,nkrol,infz,kronr,infe,kronl,info]= _wrapper.ag08bd(equil,l,n,m,p,A,E,B,C,D,tol,ldwork) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if info != 0: raise SlycotArithmeticError('ag08bd failed', info) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 54f2d220..925d9a73 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -19,30 +19,29 @@ """ -class SlycotError(ValueError): - """Slycot exception""" +class SlycotError(RuntimeError): + """Slycot exception base class""" def __init__(self, message, info): super(SlycotError, self).__init__(message) self.info = info -class SlycotParameterError(SlycotError): - """Slycot info parameter exception. +class SlycotParameterError(SlycotError, ValueError): + """A Slycot input parameter had an illegal value. In case of a wrong input value, the SLICOT routines return a negative info parameter indicating which parameter was illegal. """ - def __init__(self, info, arg_list): - fmt = "The following argument had an illegal value: {}" - super(SlycotParameterError, self).__init__( - fmt.format(arg_list[-info-1]), info) + def __init__(self, message, info, arg_list=None): + if not message: + message = ("The following argument had an illegal value: {}" + "".format(arg_list[-info-1])) + super(SlycotParameterError, self).__init__(message, info) -class SlycotArithmeticError(ArithmeticError): +class SlycotArithmeticError(SlycotError, ArithmeticError): """A Slycot computation failed""" - def __init__(self, message, info): - super(SlycotArithmeticError, self).__init__(message) - self.info = info + pass diff --git a/slycot/math.py b/slycot/math.py index ec047323..b32907e8 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -18,8 +18,8 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import SlycotError, SlycotParameterError, \ - SlycotArithmeticError +from .exceptions import SlycotParameterError, SlycotArithmeticError + import warnings import numpy as np @@ -238,7 +238,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): jobx, sort, n, pmax, A, X, tol) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if jobx == 'N': Xr = None else: @@ -366,7 +366,7 @@ def mb03vd(n, ilo, ihi, A): HQ, Tau, info = _wrapper.mb03vd(n, ilo, ihi, A) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) return (HQ, Tau) @@ -427,7 +427,7 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): Q, info = _wrapper.mb03vy(n, ilo, ihi, A, Tau, ldwork) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) return Q @@ -560,7 +560,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) elif info > 0: warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " "in a total of 30*({ihi}-{ilo}+1) iterations " @@ -656,7 +656,7 @@ def mb05md(a, delta, balanc='N'): VAL = VALr return (Ar, Vr, Yr, VAL) elif INFO < 0: - raise SlycotParameterError(INFO, arg_list) + raise SlycotParameterError(None, INFO, arg_list) elif INFO > 0 and INFO <= n: raise SlycotArithmeticError("Incomplete eigenvalue calculation, " "missing {} eigenvalues".format(INFO), @@ -700,9 +700,9 @@ def mb05nd(a, delta, tol=1e-7): if out[-1] == 0: return out[:-1] elif out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) elif out[-1] == n+1: - raise SlycotError("Delta too large", out[-1]) + raise SlycotArithmeticError("Delta too large", out[-1]) @@ -749,7 +749,7 @@ def mc01td(dico, dp, p): 'IWARN', 'INFO'] (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if info == 1: warnings.warn('entry P(x) is the zero polynomial.') if info == 2: diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 95c04a3c..227bfb14 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -20,8 +20,8 @@ from . import _wrapper -from .exceptions import SlycotError, SlycotParameterError, \ - SlycotArithmeticError +from .exceptions import SlycotParameterError, SlycotArithmeticError + import numpy as _np import warnings @@ -151,7 +151,7 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): ldwork = max(1,5*m,5*n,2*n+4*m) A_z,wr,wi,nfp,nap,nup,F,Z,warn,info = _wrapper.sb01bd(dico,n,m,np,alpha,A,B,w.real,w.imag,tol=tol,ldwork=ldwork) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if info == 1: raise SlycotArithmeticError( 'the reduction of A to a real Schur form failed', @@ -333,7 +333,7 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): ldwork = max(3,6*n) A_inv,X,rcond,wr,wi,S,U,info = _wrapper.sb02md(dico,n,A,G,Q,hinv=hinv,uplo=uplo,scal=scal,sort=sort,ldwork=ldwork) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if info == 1: raise SlycotArithmeticError( 'matrix A is (numerically) singular in discrete-time case', @@ -494,24 +494,19 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): if fact == 'N': out = _wrapper.sb02mt_n(n,m,B,R,uplo=uplo,ldwork=ldwork) if out is None: - raise SlycotError( - 'fact must be either C or N.', - -3) + raise SlycotParameterError('fact must be either C or N.', -3) else: if A is None or Q is None or L is None: - raise SlycotError( - 'matrices A,Q and L are required if jobl is not Z.', - -7) + raise SlycotParameterError( + 'matrices A,Q and L are required if jobl is not Z.', -7) if fact == 'C': out = _wrapper.sb02mt_cl(n,m,A,B,Q,R,L,uplo=uplo) if fact == 'N': out = _wrapper.sb02mt_nl(n,m,A,B,Q,R,L,uplo=uplo,ldwork=ldwork) if out is None: - raise SlycotError( - 'fact must be either C or N.', - -3) + raise SlycotParameterError('fact must be either C or N.', -3) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: raise SlycotArithmeticError('the {}-th element of d in the UdU (LdL) ' 'factorization is zero.'.format(out[-1]), @@ -713,7 +708,7 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw p = _np.shape(Q)[0] out = _wrapper.sb02od_b(dico,n,m,p,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError( 'the computed extended matrix pencil is singular, possibly due to rounding errors', @@ -862,10 +857,10 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): if ldwork is None: ldwork = max(2*n*n,3*n) if dico != 'C' and dico != 'D': - raise SlycotError('dico must be either D or C', -1) + raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == n+1: if dico == 'D': error_text = 'The matrix A has eigenvalues that are almost reciprocal.' @@ -1053,10 +1048,10 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): elif m == 0: ldwork = 1 if dico != 'C' and dico != 'D': - raise SlycotError('dico must be either D or C', -1) + raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03od(dico,n,m,A,Q,B,fact=fact,trans=trans,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: if dico == 'D': error_text = """this means that while the matrix A @@ -1170,7 +1165,7 @@ def sb04md(n,m,A,B,C,ldwork=None): else: out = _wrapper.sb04md(n,m,A,B,C,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" @@ -1230,7 +1225,7 @@ def sb04qd(n,m,A,B,C,ldwork=None): else: out = _wrapper.sb04qd(n,m,A,B,C,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" @@ -1902,7 +1897,7 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): A,B,C,D,nsys,info = _wrapper.sb10jd(n,m,np,A,B,C,D,E,ldwork) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) elif info == 1: raise SlycotArithmeticError("The sb10jd algorithm did not converge", 1) elif info != 0: @@ -2750,10 +2745,10 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): if ldwork is None: ldwork = max(1,4*n,6*n-6) if dico != 'C' and dico != 'D': - raise SlycotError('dico must be either D or C', -1) + raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sg03bd(dico,n,m,A,E,Q,Z,B,fact=fact,trans=trans,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: error_text = """the pencil A - lambda * E is (nearly) singular; perturbed values were used to solve the equation diff --git a/slycot/transform.py b/slycot/transform.py index 85f3367c..ae70511b 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -18,8 +18,7 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import SlycotError, SlycotParameterError, \ - SlycotArithmeticError +from .exceptions import SlycotParameterError, SlycotArithmeticError import numpy as _np @@ -99,7 +98,7 @@ def tb01id(n,m,p,maxred,a,b,c,job='A'): 'LDB'+hidden, 'C', 'LDC'+hidden, 'scale', 'INFO'+hidden] out = _wrapper.tb01id(n,m,p,maxred,a,b,c,job=job) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): @@ -214,7 +213,7 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): ldwork = max( 2*n + 3*max(m,p), p*(p+2)) out = _wrapper.tb03ad_l(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'a singular matrix was encountered during the computation', @@ -225,13 +224,13 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): ldwork = max( 2*n + 3*max(m,p), m*(m+2)) out = _wrapper.tb03ad_r(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'a singular matrix was encountered during the computation', out[-1]) return out[:-1] - raise SlycotError('leri must be either L or R', -1) + raise SlycotParameterError('leri must be either L or R', -1) def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): """ Ar,Br,Cr,nr,denom_degs,denom_coeffs,num_coeffs = tb04ad(n,m,p,A,B,C,D,[tol1,tol2,ldwork]) @@ -298,22 +297,24 @@ def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): if ldwork is None: ldwork = max(1,n*(n+1)+max(n*mp+2*n+max(n,mp),3*mp,pm)) if B.shape != (n, m): - raise SlycotError("The shape of B is ({}, {}), " - "but expected ({}, {})".format(*B.shape, n, m), - -7) + raise SlycotParameterError("The shape of B is ({}, {}), " + "but expected ({}, {})" + "".format(*(B.shape + (n, m))), + -7) if C.shape != (p, n): - raise SlycotError("The shape of C is ({}, {}), " - "but expected ({}, {})".format(*C.shape, p, n), - -9) + raise SlycotParameterError("The shape of C is ({}, {}), " + "but expected ({}, {})" + "".format(*(C.shape + (p, n))), + -9) if D.shape != (max(1, p), m): - raise SlycotError("The shape of D is ({}, {}), " - "but expected ({}, {})".format(*D.shape, - max(1, p), m), - -11) + raise SlycotParameterError("The shape of D is ({}, {}), " + "but expected ({}, {})" + "".format(*(D.shape + (max(1, p), m))), + -11) out = _wrapper.tb04ad_r(n,m,p,A,B,C,D,tol1,tol2,ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) A,B,C,Nr,index,dcoeff,ucoeff = out[:-1] kdcoef = max(index)+1 @@ -485,7 +486,7 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): """ def error_handler(out, arg_list): if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: error_text = ("More than 30 iterations are required " "to isolate the eigenvalue of A; the computations " @@ -508,17 +509,20 @@ def error_handler(out, arg_list): # Sanity check on matrix dimensions if A.shape != (n, n): - raise SlycotError("The shape of A is ({0:}, {1:}), " - "but expected ({2:}, {2:})".format(*A.shape, n), - -7) + raise SlycotParameterError("The shape of A is ({0:}, {1:}), " + "but expected ({2:}, {2:})" + "".format(*(A.shape + (n,))), + -7) if B.shape != (n, m): - raise SlycotError("The shape of B is ({0:}, {1:}), " - "but expected ({2:}, {3:})".format(*B.shape, n, m), - -9) + raise SlycotParameterError("The shape of B is ({0:}, {1:}), " + "but expected ({2:}, {3:})" + "".format(*(B.shape + (n, m))), + -9) if C.shape != (p, n): - raise SlycotError("The shape of C is ({0:}, {1:}), " - "but expected ({2:}, {3:})".format(*C.shape, p, n), - -11) + raise SlycotParameterError("The shape of C is ({0:}, {1:}), " + "but expected ({2:}, {3:})" + "".format(*(C.shape + (p, n))), + -11) # ---------------------------------------------------- # Checks done, do computation. @@ -546,9 +550,10 @@ def error_handler(out, arg_list): info = out[-1] return g_i, hinvb, info else: - raise SlycotError("Unrecognized job. Expected job = 'AG' or " - "job='NG' or job = 'NH' but received job=%s" % job, - 0) + raise SlycotParameterError("Unrecognized job. Expected job = 'AG' or " + "job='NG' or job = 'NH' but received job={}" + "".format(job), + -1) # job is baleig and inita together def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): @@ -627,41 +632,41 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): kdcoef = max(index)+1 if rowcol == 'R': if ucoeff.ndim != 3: - raise SlycotError("The numerator is not a 3D array!", -7) + raise SlycotParameterError("The numerator is not a 3D array!", -7) expectedshape = (max(1, p), max(1, m), kdcoef) if ucoeff.shape != expectedshape: - raise SlycotError("The numerator shape is ({}, {}, {}), " - "but expected ({}, {}, {})" - "".format(*ucoeff.shape, *expectedshape), - -7) + raise SlycotParameterError("The numerator shape is ({}, {}, {}), " + "but expected ({}, {}, {})".format( + *(ucoeff.shape + expectedshape)), + -7) expectedshape = (max(1, p), kdcoef) if dcoeff.shape != expectedshape: - raise SlycotError("The denominator shape is ({}, {}), " - "but expected ({}, {})" - "".format(*dcoeff.shape, *expectedshape), - -5) + raise SlycotParameterError("The denominator shape is ({}, {}), " + "but expected ({}, {})".format( + *(dcoeff.shape + expectedshape)), + -5) out = _wrapper.td04ad_r(m,p,index,dcoeff,ucoeff,n,tol,ldwork) elif rowcol == 'C': if ucoeff.ndim != 3: - raise SlycotError("The numerator is not a 3D array!", -7) + raise SlycotParameterError("The numerator is not a 3D array!", -7) expectedshape = (max(1, m, p), max(1, m, p), kdcoef) if ucoeff.shape != expectedshape: - raise SlycotError("The numerator shape is ({}, {}, {}), " - "but expected ({}, {}, {})" - "".format(*ucoeff.shape, *expectedshape), - -7) + raise SlycotParameterError("The numerator shape is ({}, {}, {}), " + "but expected ({}, {}, {})".format( + *(ucoeff.shape + expectedshape)), + -7) expectedshape = (max(1, m), kdcoef) if dcoeff.shape != expectedshape: - raise SlycotError("The denominator shape is ({}, {}), " - "but expected ({}, {})" - "".format(*dcoeff.shape, *expectedshape), - -5) + raise SlycotParameterError("The denominator shape is ({}, {}), " + "but expected ({}, {})".format( + *(dcoeff.shape + expectedshape)), + -5) out = _wrapper.td04ad_c(m,p,index,dcoeff,ucoeff,n,tol,ldwork) else: - raise SlycotError("Parameter rowcol had an illegal value", -1) + raise SlycotParameterError("Parameter rowcol had an illegal value", -1) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( "The leading coefficient of a denominator polynomial is nearly " @@ -758,18 +763,18 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): if leri == 'L': out = _wrapper.tc04ad_l(m,p,index,pcoeff,qcoeff,n) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError('P(s) is not row proper', out[-1]) return out[:-1] if leri == 'R': out = _wrapper.tc04ad_r(m,p,index,pcoeff,qcoeff,n) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError('P(s) is not column proper', out[-1]) return out[:-1] - raise SlycotError('leri must be either L or R', -1) + raise SlycotParameterError('leri must be either L or R', -1) def tc01od(m,p,indlin,pcoeff,qcoeff,leri): """ pcoeff,qcoeff = tc01od_l(m,p,indlim,pcoeff,qcoeff,leri) @@ -820,14 +825,14 @@ def tc01od(m,p,indlin,pcoeff,qcoeff,leri): if leri == 'L': out = _wrapper.tc01od_l(m,p,indlin,pcoeff,qcoeff) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] if leri == 'R': out = _wrapper.tc01od_r(m,p,indlin,pcoeff,qcoeff) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] - raise SlycotError('leri must be either L or R', -1) + raise SlycotParameterError('leri must be either L or R', -1) def tf01md(n,m,p,N,A,B,C,D,u,x0): """ xf,y = tf01md(n,m,p,N,A,B,C,D,u,x0) @@ -869,7 +874,7 @@ def tf01md(n,m,p,N,A,B,C,D,u,x0): out = _wrapper.tf01md(n,m,p,N,A,B,C,D,u,x0) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] def tf01rd(n,m,p,N,A,B,C,ldwork=None): @@ -914,7 +919,7 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): else: out = _wrapper.tf01rd(n,m,p,N,A,B,C,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[0] def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): @@ -990,12 +995,12 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): if ldwork is None: ldwork = max(1, n+max(n,3*m,3*p)) elif ldwork < max(1, n+max(n,3*m,3*p)): - raise SlycotError("ldwork is too small", -15) + raise SlycotParameterError("ldwork is too small", -15) out = _wrapper.tb01pd(n=n,m=m,p=p,a=A,b=B,c=C, job=job,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(out[-1], arg_list) + raise SlycotParameterError(None, out[-1], arg_list) return out[:-1] def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): @@ -1090,12 +1095,12 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): arg_list = ['job', 'l', 'n', 'm', 'p', 'thresh', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden, 'lscale', 'rscale', 'dwork'+hidden, 'info'] if job != 'A' and job != 'B' and job != 'C' and job != 'N': - raise SlycotError('Parameter job had an illegal value', -1) + raise SlycotParameterError('Parameter job had an illegal value', -1) A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if info != 0: raise SlycotArithmeticError('tg01ad failed', info) @@ -1258,13 +1263,13 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld if compq != 'N' and compq != 'I' and compq != 'U': - raise SlycotError('Parameter compq had an illegal value', -1) + raise SlycotParameterError('Parameter compq had an illegal value', -1) if compz != 'N' and compz != 'I' and compz != 'U': - raise SlycotError('Parameter compz had an illegal value', -2) + raise SlycotParameterError('Parameter compz had an illegal value', -2) if joba != 'N' and joba != 'R' and joba != 'T': - raise SlycotError('Parameter joba had an illegal value', -3) + raise SlycotParameterError('Parameter joba had an illegal value', -3) if ldwork is None: ldwork = max(1, n+p, min(l,n) + max(3*n-1, m, l)) @@ -1279,11 +1284,11 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld elif compq == 'U' and compz == 'U': A,E,B,C,Q,Z,ranke,rnka22,info = _wrapper.tg01fd_uu(joba,l,n,m,p,A,E,B,C,Q,Z,tol,ldwork) else: - raise SlycotError( + raise SlycotParameterError( "The combination of compq and compz is not implemented", -1) if info < 0: - raise SlycotParameterError(info, arg_list) + raise SlycotParameterError(None, info, arg_list) if info != 0: raise SlycotArithmeticError('tg01fd failed', info) From 2f4475334504d07e623a361cebb2a25a3b1eb661 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 16:27:31 +0200 Subject: [PATCH 167/405] exception messages extracted from docstrings --- slycot/analysis.py | 363 ++++++++++++++++++++++--------------------- slycot/exceptions.py | 59 ++++++- slycot/math.py | 17 +- slycot/synthesis.py | 351 +++++++---------------------------------- slycot/transform.py | 50 +++--- 5 files changed, 323 insertions(+), 517 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index a8ada448..5b6b698b 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -18,8 +18,8 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import SlycotError, SlycotParameterError, \ - SlycotArithmeticError +from .exceptions import raise_if_slycot_error, \ + SlycotParameterError, SlycotArithmeticError import warnings @@ -124,19 +124,19 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): if jobz == 'N': out = _wrapper.ab01nd_n(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) # sets Z to None out[5] = None return out[:-1] if jobz == 'I': out = _wrapper.ab01nd_i(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] if jobz == 'F': out = _wrapper.ab01nd_f(n,m,A,B,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] raise SlycotParameterError('jobz must be either N, I or F', -1) @@ -222,7 +222,7 @@ def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): 'ldwork', 'info'+hidden ] out = _wrapper.ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo=uplo) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): @@ -305,7 +305,7 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): ldwork = max(p1*p1,m1*m1,n1*p1) out = _wrapper.ab05nd(n1,m1,p1,n2,alpha,A1,B1,C1,D1,A2,B2,C2,D2,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'The resulting system is not completely controllable.', @@ -363,7 +363,7 @@ def ab07nd(n,m,A,B,C,D,ldwork=None): ldwork = max(1,4*m) out = _wrapper.ab07nd(n,m,A,B,C,D,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == m+1: raise SlycotArithmeticError( 'Entry matrix D is numerically singular.', @@ -457,7 +457,7 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): ldwork = n+3*max(m,p) #only an upper bound out = _wrapper.ab08nd(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): @@ -563,7 +563,7 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, zwork, info \ = out if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, int(zwork[0].real)) @@ -647,6 +647,18 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): the original system ordered decreasingly. ``HSV(1)`` is the Hankel norm of the system. + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The reduction of A to the real Schur form failed + :e.info = 2: + The state matrix A is not stable or not convergent + :e.info = 3: + The computation of Hankel singular values failed """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'A', @@ -672,20 +684,7 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): given system. It was set automatically to a value\ corresponding to the order of a minimal realization\ of the system") - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError( - 'The reduction of A to the real Schur form failed', - out[-1]) - if out[-1] == 2: - raise SlycotArithmeticError( - 'The state matrix A is not stable or not convergent', - out[-1]) - if out[-1] == 3: - raise SlycotArithmeticError( - 'The computation of Hankel singular values failed', - out[-1]) + raise_if_slycot_error(out[-1], arg_list, ab09ad.__doc__) Nr,A,B,C,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], hsv @@ -777,6 +776,17 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): Ti : rank-2 array('d') with bounds ``(nr,n)`` This array contains the left truncation matrix `Ti` of the reduced order system. + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The state matrix A is not stable or not convergent + :e.info = 2: + The computation of Hankel singular values failed """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'job', 'ordsel', 'n', 'm', 'p', 'nr', 'A', @@ -801,16 +811,8 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): given system. It was set automatically to a value\ corresponding to the order of a minimal realization\ of the system") - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError( - 'The state matrix A is not stable or not convergent', - out[-1]) - if out[-1] == 2: - raise SlycotArithmeticError( - 'The computation of Hankel singular values failed', - out[-1]) + raise_if_slycot_error(out[-1], arg_list, ab09ax.__doc__) + nr,A,B,C,hsv,T,Ti = out[:-2] return nr, A[:nr,:nr], B[:nr,:], C[:,:nr], hsv, T[:,:nr], Ti[:nr,:] @@ -917,6 +919,20 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): If info = 0, it contains the Hankel singular values of the original system ordered decreasingly. hsv(1) is the Hankel norm of the system. + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The reduction of A to the real Schur form failed + :e.info = 2: + The state matrix A is not stable (if dico = C) ' + 'or not convergent (if dico = D) + :e.info = 3: + The computation of Hankel singular values failed """ hidden = ' (hidden by the wrapper)' @@ -943,21 +959,7 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): given system. It was set automatically to a value\ corresponding to the order of a minimal realization\ of the system") - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError( - 'The reduction of A to the real Schur form failed', - out[-1]) - if out[-1] == 2: - raise SlycotArithmeticError( - 'The state matrix A is not stable (if dico = C) ' - 'or not convergent (if dico = D)', - out[-1]) - if out[-1] == 3: - raise SlycotArithmeticError( - 'The computation of Hankel singular values failed', - out[-1]) + raise_if_slycot_error(out[-1], arg_list, ab09bd.__doc__) Nr,A,B,C,D,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr],D[:,:], hsv @@ -1082,6 +1084,20 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): Hankel singular values of the alpha-stable part of the original system ordered decreasingly. hsv(1) is the Hankel norm of the alpha-stable subsystem. + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The reduction of A to the real Schur form failed + :e.info = 2: + The separation of the alpha-stable/unstable diagonal + blocks failed because of very close eigenvalues + :e.info = 3: + The computation of Hankel singular values failed """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'alpha', 'A', @@ -1118,21 +1134,8 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): than the order of the alpha-unstable part of the\ given system. In this case nr is set equal to the\ order of the alpha-unstable part.") - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError( - 'The reduction of A to the real Schur form failed', - out[-1]) - if out[-1] == 2: - raise SlycotArithmeticError( - 'the separation of the alpha-stable/unstable diagonal ' - 'blocks failed because of very close eigenvalues', - out[-1]) - if out[-1] == 3: - raise SlycotArithmeticError( - 'The computation of Hankel singular values failed', - out[-1]) + + raise_if_slycot_error(out[-1], arg_list, ab09md.__doc__) Nr,A,B,C,Ns,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], Ns, hsv @@ -1253,6 +1256,20 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= If info = 0, it contains the Hankel singular values of the original system ordered decreasingly. hsv(1) is the Hankel norm of the system. + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The reduction of A to the real Schur form failed + :e.info = 2: + The state matrix A is not stable (if dico = C) ' + 'or not convergent (if dico = D) + :e.info = 3: + The computation of Hankel singular values failed """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'alpha', 'A', @@ -1289,21 +1306,9 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= than the order of the alpha-unstable part of the\ given system. In this case nr is set equal to the\ order of the alpha-unstable part.") - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError( - 'The reduction of A to the real Schur form failed', - out[-1]) - if out[-1] == 2: - raise SlycotArithmeticError( - 'the separation of the alpha-stable/unstable diagonal ' - 'blocks failed because of very close eigenvalues', - out[-1]) - if out[-1] == 3: - raise SlycotArithmeticError( - 'The computation of Hankel singular values failed', - out[-1]) + + raise_if_slycot_error(out[-1], arg_list, ab09nd.__doc__) + Nr,A,B,C,D,Ns,hsv = out[:-2] return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], D, Ns, hsv @@ -1316,7 +1321,9 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): a discrete-time system. If the H2-norm is computed, the system must be stable. - Required arguments: + Required arguments + ------------------ + dico : {'D', 'C'} input string(len=1) Indicate whether the system is discrete 'D' or continuous 'C'. jobn : {'H', 'L'} input string(len=1) @@ -1340,7 +1347,9 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): The leading p-by-m part of this array must contain the direct transmission matrix D of the system. - Optional arguments: + Optional arguments + ------------------ + tol : The absolute tolerance level below which the elements of B are considered zero (used for controllability tests). If the user sets tol <= 0, then an implicitly computed, @@ -1348,6 +1357,36 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): is used instead, where eps is the machine precision (see LAPACK Library routine DLAMCH) and norm(B) denotes the 1-norm of B. + + Returns + ------- + + norm: H2 or L2 norm of thes ystem (A,B,C,D) + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The reduction of A to a real Schur form failed + :e.info = 2: + A failure was detected during the reordering of the + real Schur form of A, or in the iterative process for + reordering the eigenvalues of Z'*(A + B*F)*Z along the + diagonal + :e.info = 3: + The matrix A has a controllable eigenvalue on the + imaginary axis if dico == 'C' or the unit circle + if dico = 'D' + :e.info = 4: + The solution of Lyapunov equation failed because the + equation is singular + :e.info = 5: + dico = 'C' and D is a nonzero matrix + :e.info = 6: + jobn = 'H' and the system is unstable """ if dico != 'C' and dico != 'D': @@ -1355,45 +1394,15 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): if jobn != 'H' and jobn != 'L': raise SlycotParameterError('jobn must be "H" or "L"', -2) out = _wrapper.ab13bd(dico, jobn, n, m, p, A, B, C, D, tol) - if out[-1] == 0: - # success - return out[0] - elif out[-1] < 0: - hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'jobn', 'n', 'm', 'p', - 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, - 'nq'+hidden,'tol', 'dwork'+hidden, 'ldwork'+hidden, 'iwarn'+hidden, 'info'+hidden] - raise SlycotParameterError(None, out[-1], arg_list) - elif out[-1] == 1: - raise SlycotArithmeticError( - "the reduction of A to a real Schur form failed", - out[-1]) - elif out[-1] == 2: - raise SlycotArithmeticError( - "a failure was detected during the reordering of the real Schur form of A, " - "or in the iterative process for reordering the eigenvalues of " - "Z'*(A + B*F)*Z along the diagonal", - out[-1]) - elif out[-1] == 3: - raise SlycotArithmeticError( - "the matrix A has a controllable eigenvalue on the " + - ("imaginary axis" if dico == 'C' else "unit circle"), - out[-1]) - elif out[-1] == 4: - raise SlycotArithmeticError( - "the solution of Lyapunov equation failed because the equation is " - "singular", - out[-1]) - elif out[-1] == 5: - raise SlycotArithmeticError( - "DICO = 'C' and D is a nonzero matrix", - out[-1]) - elif out[-1] == 6: - raise SlycotArithmeticError( - "JOBN = 'H' and the system is unstable", - out[-1]) - else: - raise SlycotError("unknown error code %r" % out[-1], out[-1]) + + hidden = ' (hidden by the wrapper)' + arg_list = ('dico', 'jobn', 'n', 'm', 'p', + 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, + 'D', 'ldd'+hidden, 'nq'+hidden,'tol', 'dwork'+hidden, + 'ldwork'+hidden, 'iwarn'+hidden, 'info'+hidden) + raise_if_slycot_error(out[-1], arg_list, ab13bd.__doc__) + + return out[0] def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): """gpeak, fpeak = ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, [tol]) @@ -1468,6 +1477,23 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): j*fpeak || G ( e ) || = gpeak , if dico = 'D'. + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The matrix E is (numerically) singular + :e.info = 2: + The (periodic) QR (or QZ) algorithm for computing + eigenvalues did not converge + :e.info = 3: + The SVD algorithm for computing singular values did + not converge + :e.info = 4: + The tolerance is too small and the algorithm did not converge """ if dico != 'C' and dico != 'D': @@ -1484,32 +1510,15 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): fpeak = out[0][0] if out[0][1] > 0 else float('inf') gpeak = out[1][0] if out[1][1] > 0 else float('inf') return gpeak, fpeak - elif out[-1] < 0: - hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'jobe', 'equil', 'jobd', 'n', 'm', 'p', 'fpeak'+hidden, - 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, - 'gpeak'+hidden, 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork'+hidden, - 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden] - raise SlycotParameterError(None, out[-1], arg_list) - elif out[-1] == 1: - raise SlycotArithmeticError( - "the matrix E is (numerically) singular", - out[-1]) - elif out[-1] == 2: - raise SlycotArithmeticError( - "the (periodic) QR (or QZ) algorithm for computing eigenvalues " - "did not converge", - out[-1]) - elif out[-1] == 3: - raise SlycotArithmeticError( - "the SVD algorithm for computing singular values did not converge", - out[-1]) - elif out[-1] == 4: - raise SlycotArithmeticError( - "the tolerance is too small and the algorithm did not converge", - out[-1]) - else: - raise SlycotError("unknown error code %r" % out[-1], out[-1]) + + hidden = ' (hidden by the wrapper)' + arg_list = ('dico', 'jobe', 'equil', 'jobd', 'n', 'm', 'p', + 'fpeak'+hidden, + 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, + 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, + 'gpeak'+hidden, 'tol', 'iwork'+hidden, 'dwork'+hidden, + 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden) + raise_if_slycot_error(out[-1], arg_list, ab13dd.__doc__) def ab13ed(n, A, tol = 9.0): """low, high = ab13ed(n, A, [tol]) @@ -1555,22 +1564,25 @@ def ab13ed(n, A, tol = 9.0): A lower bound for beta(A). high : float An upper bound for beta(A). + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The QR algorithm fails to converge """ out = _wrapper.ab13ed(n, A, tol) if out[-1] == 0: # success return out[0], out[1] - elif out[-1] < 0: - hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'A', 'lda'+hidden, 'low'+hidden, 'high'+hidden, 'tol', - 'dwork'+hidden, 'ldwork'+hidden, 'info'+hidden] - raise SlycotParameterError(None, out[-1], arg_list) - elif out[-1] == 1: - raise SlycotArithmeticError( - "the QR algorithm fails to converge", - out[-1]) - else: - raise SlycotError("unknown error code %r" % out[-1], out[-1]) + + hidden = ' (hidden by the wrapper)' + arg_list = ['n', 'A', 'lda'+hidden, 'low'+hidden, 'high'+hidden, 'tol', + 'dwork'+hidden, 'ldwork'+hidden, 'info'+hidden] + raise_if_slycot_error(out[-1], arg_list, ab13ed.__doc__) def ab13fd(n, A, tol = 0.0): """beta, omega = ab13fd(n, A, [tol]) @@ -1619,25 +1631,31 @@ def ab13fd(n, A, tol = 0.0): AB13FD to fail for smaller values of tol, nevertheless, it usually succeeds. Regardless of success or failure, the first inequality holds. + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 2: + Either the QR or SVD algorithm fails to converge """ out = _wrapper.ab13fd(n, A, tol) if out[-1] == 0: # success return out[0], out[1] - elif out[-1] < 0: - hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'A', 'lda'+hidden, 'beta'+hidden, 'omega'+hidden, 'tol', - 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden] - raise SlycotParameterError(None, out[-1], arg_list) - elif out[-1] == 1: - warnings.warn("the routine fails to compute beta(A) within the specified tolerance") + + if out[-1] == 1: + warnings.warn("the routine fails to compute beta(A) within the" + " specified tolerance") return out[0], out[1] # the returned value is an upper bound on beta(A) - elif out[-1] == 2: - raise SlycotArithmeticError( - "either the QR or SVD algorithm fails to converge", - out[-1]) - else: - raise SlycotError("unknown error code %r" % out[-1], out[-1]) + + hidden = ' (hidden by the wrapper)' + arg_list = ['n', 'A', 'lda'+hidden, 'beta'+hidden, 'omega'+hidden, 'tol', + 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, + 'lcwork'+hidden, 'info'+hidden] + raise_if_slycot_error(out[-1], arg_list, ab13fd.__dict__) def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) @@ -1740,9 +1758,6 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): [Af,Ef,nfz,nrank,niz,dinfz,nkror,ninfe,nkrol,infz,kronr,infe,kronl,info]= _wrapper.ag08bd(equil,l,n,m,p,A,E,B,C,D,tol,ldwork) - if info < 0: - raise SlycotParameterError(None, info, arg_list) - if info != 0: - raise SlycotArithmeticError('ag08bd failed', info) + raise_if_slycot_error(info, arg_list, '') return Af[:nfz,:nfz],Ef[:nfz,:nfz],nrank,niz,infz[:dinfz],kronr[:nkror],infe[:ninfe],kronl[:nkrol] diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 925d9a73..7cd8b0d0 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -34,14 +34,61 @@ class SlycotParameterError(SlycotError, ValueError): info parameter indicating which parameter was illegal. """ - def __init__(self, message, info, arg_list=None): - if not message: - message = ("The following argument had an illegal value: {}" - "".format(arg_list[-info-1])) - super(SlycotParameterError, self).__init__(message, info) - + pass class SlycotArithmeticError(SlycotError, ArithmeticError): """A Slycot computation failed""" pass + +def filter_docstring_exceptions(docstring): + """Check a docstring to find exception descriptions""" + + # check-count the message indices + index = 0 + exdict = {} + msg = [] + for l in docstring.split('\n'): + l = l.strip() + if l[:10] == ":e.info = " and l[-1] == ":": + try: + idx = int(l[10:-1]) + if msg: + exdict[index] = '\n'.join(msg) + msg = [] + index = idx + except ValueError: + if msg: + exdict[index] = '\n'.join(msg) + msg = [] + index = 0 + elif index: + msg.append(l.strip()) + if msg: + exdict[index] = '\n'.join(msg) + return exdict + +def raise_if_slycot_error(info, arg_list, docstring=None): + """Raise exceptions if slycot info returned is non-zero + + For negative info, the argument as indicated in arg_list was erroneous + + For positive info, the matching exception text is recovered from + the docstring, which may in many cases simply be the python interface + routine docstring + """ + + if info < 0: + message = ("The following argument had an illegal value: {}" + "".format(arg_list[-info-1])) + raise SlycotParameterError(message, info) + elif info > 0: + # process the docstring for the error message + messages = filter_docstring_exceptions(docstring) + try: + raise SlycotParameterError(messages[info-1], info) + except: + raise SlycotParameterError( + "Slycot returned an unhandled error code {}".format(info), + info) + diff --git a/slycot/math.py b/slycot/math.py index b32907e8..0cf0a156 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -18,7 +18,7 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import SlycotParameterError, SlycotArithmeticError +from .exceptions import raise_if_slycot_error, SlycotArithmeticError import warnings @@ -238,7 +238,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): jobx, sort, n, pmax, A, X, tol) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) if jobx == 'N': Xr = None else: @@ -366,7 +366,7 @@ def mb03vd(n, ilo, ihi, A): HQ, Tau, info = _wrapper.mb03vd(n, ilo, ihi, A) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) return (HQ, Tau) @@ -427,7 +427,7 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): Q, info = _wrapper.mb03vy(n, ilo, ihi, A, Tau, ldwork) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) return Q @@ -560,7 +560,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) elif info > 0: warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " "in a total of 30*({ihi}-{ilo}+1) iterations " @@ -656,7 +656,7 @@ def mb05md(a, delta, balanc='N'): VAL = VALr return (Ar, Vr, Yr, VAL) elif INFO < 0: - raise SlycotParameterError(None, INFO, arg_list) + raise_if_slycot_error(info, arg_list) elif INFO > 0 and INFO <= n: raise SlycotArithmeticError("Incomplete eigenvalue calculation, " "missing {} eigenvalues".format(INFO), @@ -700,7 +700,7 @@ def mb05nd(a, delta, tol=1e-7): if out[-1] == 0: return out[:-1] elif out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) elif out[-1] == n+1: raise SlycotArithmeticError("Delta too large", out[-1]) @@ -742,14 +742,13 @@ def mc01td(dico, dp, p): Equal to 1 if `P(x)` is stable, 0 otherwise. nz : int The number of unstable zeros. - """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, 'IWARN', 'INFO'] (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) if info == 1: warnings.warn('entry P(x) is the zero polynomial.') if info == 2: diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 227bfb14..127548bf 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -20,7 +20,8 @@ from . import _wrapper -from .exceptions import SlycotParameterError, SlycotArithmeticError +from .exceptions import raise_if_slycot_error, \ + SlycotParameterError, SlycotArithmeticError import numpy as _np import warnings @@ -150,22 +151,9 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): if ldwork is None: ldwork = max(1,5*m,5*n,2*n+4*m) A_z,wr,wi,nfp,nap,nup,F,Z,warn,info = _wrapper.sb01bd(dico,n,m,np,alpha,A,B,w.real,w.imag,tol=tol,ldwork=ldwork) - if info < 0: - raise SlycotParameterError(None, info, arg_list) - if info == 1: - raise SlycotArithmeticError( - 'the reduction of A to a real Schur form failed', - info) - if info == 2: - raise SlycotArithmeticError('a failure was detected during the ordering of eigenvalues', info) - if info == 3: - raise SlycotArithmeticError( - 'the number of eigenvalues to be assigned is less than the number of possibly assignable eigenvalues', - info) - if info == 4: - raise SlycotArithmeticError( - 'an attempt was made to place a complex conjugate pair on the location of a real eigenvalue', - info) + + raise_if_slycot_error(out[-1], arg_list, sb01bd.__doc__) + if warn != 0: warnings.warn('%i violations of the numerical stability condition occured during the assignment of eigenvalues' % warn) # put togheter wr and wi into a complex array of eigenvalues @@ -332,28 +320,9 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): if ldwork is None: ldwork = max(3,6*n) A_inv,X,rcond,wr,wi,S,U,info = _wrapper.sb02md(dico,n,A,G,Q,hinv=hinv,uplo=uplo,scal=scal,sort=sort,ldwork=ldwork) - if info < 0: - raise SlycotParameterError(None, info, arg_list) - if info == 1: - raise SlycotArithmeticError( - 'matrix A is (numerically) singular in discrete-time case', - info) - if info == 2: - raise SlycotArithmeticError( - 'the Hamiltonian or symplectic matrix H cannot be reduced to real Schur form', - info) - if info == 3: - raise SlycotArithmeticError( - 'the real Schur form of the Hamiltonian or symplectic matrix H cannot be appropriately ordered', - info) - if info == 4: - raise SlycotArithmeticError( - 'the Hamiltonian or symplectic matrix H has less than n stable eigenvalues', - info) - if info == 5: - raise SlycotArithmeticError( - 'if the N-th order system of linear algebraic equations is singular to working precision', - info) + + raise_if_slycot_error(info, arg_list, sb02md.__doc__) + w = _np.zeros(2*n,'complex64') w.real = wr[0:2*n] w.imag = wi[0:2*n] @@ -506,7 +475,7 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): if out is None: raise SlycotParameterError('fact must be either C or N.', -3) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: raise SlycotArithmeticError('the {}-th element of d in the UdU (LdL) ' 'factorization is zero.'.format(out[-1]), @@ -707,32 +676,9 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw if p is None: p = _np.shape(Q)[0] out = _wrapper.sb02od_b(dico,n,m,p,A,B,Q,R,L,uplo=uplo,jobl=jobl,sort=sort,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError( - 'the computed extended matrix pencil is singular, possibly due to rounding errors', - out[-1]) - if out[-1] == 2: - raise SlycotArithmeticError( - 'the QZ (or QR) algorithm failed', - out[-1]) - if out[-1] == 3: - raise SlycotArithmeticError( - 'reordering of the (generalized) eigenvalues failed', - out[-1]) - if out[-1] == 4: - raise SlycotArithmeticError( - 'stability condition failed due to roudoff errors', - out[-1]) - if out[-1] == 5: - raise SlycotArithmeticError( - 'the computed dimension of the solution does not equal N', - out[-1]) - if out[-1] == 6: - raise SlycotArithmeticError( - 'a singular matrix was encountered during the computation', - out[-1]) + + raise_if_slycot_error(out[-1], arg_list, sb02od.__doc__) + rcond,X,alphar,alphai,beta,S,T = out[:-1] w = _np.zeros(2*n,'complex64') w.real = alphar[0:2*n]/beta[0:2*n] @@ -860,7 +806,7 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == n+1: if dico == 'D': error_text = 'The matrix A has eigenvalues that are almost reciprocal.' @@ -1050,8 +996,9 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03od(dico,n,m,A,Q,B,fact=fact,trans=trans,ldwork=ldwork) + if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == 1: if dico == 'D': error_text = """this means that while the matrix A @@ -1164,8 +1111,9 @@ def sb04md(n,m,A,B,C,ldwork=None): out = _wrapper.sb04md(n,m,A,B,C) else: out = _wrapper.sb04md(n,m,A,B,C,ldwork=ldwork) + if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" @@ -1225,7 +1173,7 @@ def sb04qd(n,m,A,B,C,ldwork=None): else: out = _wrapper.sb04qd(n,m,A,B,C,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" @@ -1363,46 +1311,45 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, :e.info = -i: the i-th argument had an illegal value; SlycotArithmeticError : e :e.info = 1: - if the matrix | A-j*omega*I B2 | had not full + The matrix | A-j*omega*I B2 | had not full | C1 D12 | column rank in respect to the tolerance eps; :e.info = 2: - if the matrix | A-j*omega*I B1 | had not full row + The matrix | A-j*omega*I B1 | had not full row | C2 D21 | rank in respect to the tolerance eps; :e.info = 3: - if the matrix D12 had not full column rank in + The matrix D12 had not full column rank in respect to the tolerance SQRT(eps); :e.info = 4: - if the matrix D21 had not full row rank in respect + The matrix D21 had not full row rank in respect to the tolerance SQRT(eps); :e.info = 5: - if the singular value decomposition (SVD) algorithm + The singular value decomposition (SVD) algorithm did not converge (when computing the SVD of one of the matrices |A B2 |, |A B1 |, D12 or D21); |C1 D12| |C2 D21| :e.info = 6: - if the controller is not admissible (too small value of gamma); + The controller is not admissible (too small value of gamma); :e.info = 7: - if the X-Riccati equation was not solved + The X-Riccati equation was not solved successfully (the controller is not admissible or there are numerical difficulties); :e.info = 8: - if the Y-Riccati equation was not solved + The Y-Riccati equation was not solved successfully (the controller is not admissible or there are numerical difficulties); :e.info = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero [3]; :e.info = 10: - if there are numerical problems when estimating + There are numerical problems when estimating singular values of D1111, D1112, D1111', D1121'; :e.info = 11: - if the matrices Inp2 - D22*DK or Im2 - DK*D22 + The matrices Inp2 - D22*DK or Im2 - DK*D22 are singular to working precision; :e.info = 12: - if a stabilizing controller cannot be found. - + A stabilizing controller cannot be found. """ hidden = ' (hidden by the wrapper)' arg_list = ['job', 'n', 'm', 'np', 'ncon', 'nmeas', 'gamma', @@ -1438,49 +1385,7 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, ldwork = LW1 + max(1, LW2, LW3, LW4, LW5 + max(LW6,LW7)) out = _wrapper.sb10ad(job,n,m,np,ncon,nmeas,gamma,A,B,C,D,gtol,actol,liwork,ldwork) - if out[-1] != 0: - if out[-1] < 0: - error_text = "The following argument had an illegal value: "\ - +arg_list[-out[-1]-1] - if out[-1] == 1: - error_text = "The matrix [A-j*omega*I, B2 ; C1, D12] does not\ - have full column rank with respect to the tolerance eps." - if out[-1] == 2: - error_text = "The matrix [A-j*omega*I, B1 ; C2, D21] does not\ - have full row rank with respect to the tolerance eps." - if out[-1] == 3: - error_text = "The matrix D12 does not have full column rank with\ - respect to tolerance sqrt(eps)." - if out[-1] == 4: - error_text = "The matrix D21 does not have full column rank with\ - respect to tolerance sqrt(eps)." - if out[-1] == 5: - error_text = "The singular value decomposition (SVD) algorithm did\ - not converge (when computing the SVD of one of the matrices\ - [A, B2; C1, D12], [A, B1; C2, D21] , D12 or D21." - if out[-1] == 6: - error_text = "The controller is not admissible (too small value of\ - gamma)." - if out[-1] == 7: - error_text = "The X-Riccati equation was not solved successfully\ - (the controller is not admissible or there are numerical\ - difficulties)." - if out[-1] == 8: - error_text = "The Y-Riccati equation was not solved successfully\ - (the controller is not admissible or there are numerical\ - difficulties)." - if out[-1] == 9: - error_text = "The determinant of Im2 + Tu*D11Hat*Ty*D22 is zero,\ - see ref [3] in SLICOT doc." - if out[-1] == 10: - error_text = "There are numerical problems when estimating singular\ - values of D1111, D1112, D1111', D1121'." - if out[-1] == 11: - error_text = "The matrices Inp2 - D22*DK or Im2 - DK*D22 are singular\ - to working precision." - if out[-1] == 12: - error_text = "A stabilizing controller cannot be found." - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sb10ad.__doc__) return out[:-1] @@ -1604,12 +1509,12 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): SlycotParameterError : e :e.info = -i: the i-th argument had an illegal value; SlycotArithmeticError : e - :e.info = 1 + :e.info = 1: j*Theta if the matrix | A-e *I B2 | had not full | C1 D12 | column rank; - :e.info = 2 + :e.info = 2: j*Theta if the matrix | A-e *I B1 | had not full | C2 D21 | @@ -1656,40 +1561,7 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): ldwork = max(LW1,LW2,LW3,LW4) out = _wrapper.sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol,ldwork) - if out[-1] != 0: - if out[-1] < 0: - error_text = "The following argument had an illegal value: "\ - +arg_list[-out[-1]-1] - if out[-1] == 1: - error_text = " j*Theta\ - The matrix | A-e *I B2 | had not full column rank.\ - | C1 D12 |" - if out[-1] == 2: - error_text = " j*Theta\ - The matrix | A-e *I B2 | had not full row rank.\ - | C1 D12 |" - if out[-1] == 3: - error_text = "The matrix D12 had not full column rank." - if out[-1] == 4: - error_text = "The matrix D21 had not full row rank." - if out[-1] == 5: - error_text = "The controller is not admissible (too small value of gamma)" - if out[-1] == 6: - error_text = "The X-Riccati equation was not solved\ - successfully (the controller is not admissible or\ - there are numerical difficulties)." - if out[-1] == 7: - error_text = "The Z-Riccati equation was not solved\ - successfully (the controller is not admissible or\ - there are numerical difficulties)." - if out[-1] == 8: - error_text = "The matrix Im2 + DKHAT*D22 is singular." - if out[-1] == 9: - error_text = "the singular value decomposition (SVD) algorithm\ - did not converge (when computing the SVD of one of\ - the matrices |A B2 |, |A B1 |, D12 or D21).\ - |C1 D12| |C2 D21|" - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sb10dd.__doc__) return out[:-1] @@ -1787,13 +1659,13 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): :e.info = 2: if the matrix D21 had not full row rank in respect to the tolerance tol; - :e.info = 3: + :e.info = 3: if the singular value decomposition (SVD) algorithm did not converge (when computing the SVD of one of the matrices D12 or D21). - :e.info = 4: + :e.info = 4: if the X-Riccati equation was not solved successfully; - :e.info = 5: + :e.info = 5: if the Y-Riccati equation was not solved successfully. """ @@ -1808,28 +1680,7 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): ldwork = 2*Q*(3*Q+2*n)+max(1,Q*(Q+max(n,5)+1),n*(14*n+12+2*Q)+5) out = _wrapper.sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol,ldwork) - if out[-1] != 0: - if out[-1] < 0: - error_text = "The following argument had an illegal value: "\ - +arg_list[-out[-1]-1] - if out[-1] == 1: - error_text = "The matrix D12 does not have full column rank with\ - respect to the tolerance tol." - if out[-1] == 2: - error_text = "The matrix D21 does not have full row rank with\ - respect to the tolerance tol." - if out[-1] == 3: - error_text = "The singular value decomposition (SVD) algorithm\ - did not converge (when computing the SVD of one of the matrices\ - D12 or D21.)" - if out[-1] == 4: - error_text = "The X-Riccati equation was not solved successfully\ - (the controller is not admissible or there are numerical difficulties)." - if out[-1] == 5: - error_text = "The Y-Riccati equation was not solved successfully\ - (the controller is not admissible or there are numerical\ - difficulties)." - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sb10hd.__doc__) return out[:-1] @@ -1896,12 +1747,7 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): A,B,C,D,nsys,info = _wrapper.sb10jd(n,m,np,A,B,C,D,E,ldwork) - if info < 0: - raise SlycotParameterError(None, info, arg_list) - elif info == 1: - raise SlycotArithmeticError("The sb10jd algorithm did not converge", 1) - elif info != 0: - raise SlycotArithmeticError('sb10jd failed', info) + raise_if_slycot_error(info, arg_list, sb10jd.__doc__) return A[:nsys,:nsys],B[:nsys,:m],C[:np, :nsys],D[:np, :m] @@ -2143,35 +1989,7 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): out = _wrapper.sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork) - if out[-1] != 0: - if out[-1] < 0: - error_text = "The following argument had an illegal value: "\ - +arg_list[-out[-1]-1] - elif out[-1] == 1: - error_text = "FACT = 'F' and the matrix contained in the upper \ - Hessenberg part of the array A is not in upper \ - quasitriangular form" - elif out[-1] == 2: - error_text = "FACT = 'N' and the pencil A - lambda * E cannot be \ - reduced to generalized Schur form: LAPACK routine \ - DGEGS has failed to converge" - elif out[-1] == 3: - error_text = "DICO = 'D' and the pencil A - lambda * E has a \ - pair of reciprocal eigenvalues. That is, lambda_i = \ - 1/lambda_j for some i and j, where lambda_i and \ - lambda_j are eigenvalues of A - lambda * E. Hence, \ - equation (2) is singular; perturbed values were \ - used to solve the equation (but the matrices A and \ - E are unchanged)" - elif out[-1] == 4: - error_text = "TDICO = 'C' and the pencil A - lambda * E has a \ - degenerate pair of eigenvalues. That is, lambda_i = \ - -lambda_j for some i and j, where lambda_i and \ - lambda_j are eigenvalues of A - lambda * E. Hence, \ - equation (1) is singular; perturbed values were \ - used to solve the equation (but the matrices A and \ - E are unchanged)" - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sg03ad.__dict__) return out[:-1] @@ -2482,27 +2300,27 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, :e.info = -i: the i-th argument had an illegal value; SlycotArithmeticError : e :e.info = 1: - if the computed extended matrix pencil is singular, - possibly due to rounding errors; + The computed extended matrix pencil is singular, + possibly due to rounding errors :e.info = 2: - if the QZ algorithm failed; + The QZ algorithm failed :e.info = 3: - if reordering of the generalized eigenvalues failed; + Reordering of the generalized eigenvalues failed :e.info = 4: - if after reordering, roundoff changed values of + After reordering, roundoff changed values of some complex eigenvalues so that leading eigenvalues in the generalized Schur form no longer satisfy the stability condition; this could also be caused due - to scaling; + to scaling :e.info = 5: - if the computed dimension of the solution does not - equal N; + The computed dimension of the solution does not + equal N :e.info = 6: - if the spectrum is too close to the boundary of - the stability domain; + The spectrum is too close to the boundary of + the stability domain :e.info = 7: - if a singular matrix was encountered during the - computation of the solution matrix X. + A singular matrix was encountered during the + computation of the solution matrix X """ hidden = ' (hidden by the wrapper)' @@ -2533,33 +2351,7 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, elif (fact == 'B'): out = _wrapper.sg02ad_bb(dico,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,tol,ldwork) - if out[-1] != 0: - if out[-1] < 0: - error_text = "The following argument had an illegal value: "\ - +arg_list[-out[-1]-1] - elif out[-1] == 1: - error_text = "The computed extended matrix pencil is singular,\ - possibly due to rounding errors" - elif out[-1] == 2: - error_text = "The QZ algorithm failed" - elif out[-1] == 3: - error_text = "Reordering of the generalized eigenvalues failed" - elif out[-1] == 4: - error_text = "After reordering, roundoff changed values of\ - some complex eigenvalues so that leading eigenvalues\ - in the generalized Schur form no longer satisfy the\ - stability condition; this could also be caused due\ - to scaling" - elif out[-1] == 5: - error_text = "The computed dimension of the solution does not\ - equal N" - elif out[-1] == 6: - error_text = "The spectrum is too close to the boundary of\ - the stability domain" - elif out[-1] == 7: - error_text = "A singular matrix was encountered during the\ - computation of the solution matrix X" - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sg02ad.__doc__) return out[:-1] @@ -2747,43 +2539,8 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sg03bd(dico,n,m,A,E,Q,Z,B,fact=fact,trans=trans,ldwork=ldwork) - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - error_text = """the pencil A - lambda * E is (nearly) singular; - perturbed values were used to solve the equation - (but the reduced (quasi)triangular matrices A and E - are unchanged).""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 2: - error_text = """the matrix contained in the upper - Hessenberg part of the array A is not in upper - quasitriangular form.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 3: - error_text = """there is a 2-by-2 block on the main - diagonal of the pencil A_s - lambda * E_s whose - eigenvalues are not conjugate complex.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 4: - error_text = """the pencil A - lambda * E cannot be - reduced to generalized Schur form: LAPACK routine - DGEGS (or DGGES) has failed to converge.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 5: - error_text = """the pencil A - lambda * E is not - c-stable.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 6: - error_text = """the pencil A - lambda * E is not - d-stable.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 7: - error_text = """the LAPACK routine DSYEVX utilized to factorize M3 - failed to converge in the discrete-time case (see - section METHOD for SLICOT Library routine SG03BU). - This error is unlikely to occur.""" - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sg03bd.__doc__) + U,scale,alphar,alphai,beta = out[:-1] alpha = _np.zeros(n,'complex64') alpha.real = alphar[0:n] diff --git a/slycot/transform.py b/slycot/transform.py index ae70511b..25313ce9 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -18,7 +18,8 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import SlycotParameterError, SlycotArithmeticError +from .exceptions import raise_if_slycot_error, \ + SlycotParameterError, SlycotArithmeticError import numpy as _np @@ -98,7 +99,7 @@ def tb01id(n,m,p,maxred,a,b,c,job='A'): 'LDB'+hidden, 'C', 'LDC'+hidden, 'scale', 'INFO'+hidden] out = _wrapper.tb01id(n,m,p,maxred,a,b,c,job=job) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise raise_if_slycot_error(out[-1], arg_list) return out[:-1] def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): @@ -213,7 +214,7 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): ldwork = max( 2*n + 3*max(m,p), p*(p+2)) out = _wrapper.tb03ad_l(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'a singular matrix was encountered during the computation', @@ -224,7 +225,7 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): ldwork = max( 2*n + 3*max(m,p), m*(m+2)) out = _wrapper.tb03ad_r(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'a singular matrix was encountered during the computation', @@ -314,7 +315,7 @@ def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): out = _wrapper.tb04ad_r(n,m,p,A,B,C,D,tol1,tol2,ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) A,B,C,Nr,index,dcoeff,ucoeff = out[:-1] kdcoef = max(index)+1 @@ -484,19 +485,6 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): >>> g_2, hinv2,info = slycot.tb05ad(n, m, p, jw_s[1], at, bt, ct, job='NH') """ - def error_handler(out, arg_list): - if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) - if out[-1] == 1: - error_text = ("More than 30 iterations are required " - "to isolate the eigenvalue of A; the computations " - "are continued.") - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 2: - error_text = ("Either FREQ is too near to an eigenvalue of A, or " - "RCOND is less than the machine precision EPS.") - raise SlycotArithmeticError(error_text, out[-1]) - hidden = ' (hidden by the wrapper)' arg_list = ['baleig'+hidden, 'inita'+hidden, 'n', 'm', 'p', 'freq', 'a', 'lda'+hidden, 'b', 'ldb'+hidden, 'c', 'ldc'+hidden, 'rcond', @@ -528,7 +516,7 @@ def error_handler(out, arg_list): # Checks done, do computation. if job == 'AG': out = _wrapper.tb05ad_ag(n, m, p, jomega, A, B, C) - error_handler(out, arg_list) + raise_if_slycot_error(out[-1], arg_list, tb05ad.__doc__) At, Bt, Ct, rcond, g_jw, evre, evim, hinvb = out[:-1] ev = _np.zeros(n, 'complex64') ev.real = evre @@ -539,13 +527,13 @@ def error_handler(out, arg_list): # use tb05ad_ng, for 'NONE' , and 'General', because balancing # (option 'A' for 'ALL') seems to have a bug. out = _wrapper.tb05ad_ng(n, m, p, jomega, A, B, C) - error_handler(out, arg_list) + raise_if_slycot_error(out[-1], arg_list, tb05ad.__doc__) At, Bt, Ct, g_jw, hinvb = out[:-1] info = out[-1] return At, Bt, Ct, g_jw, hinvb, info elif job == 'NH': out = _wrapper.tb05ad_nh(n, m, p, jomega, A, B, C) - error_handler(out, arg_list) + raise_if_slycot_error(out[-1], arg_list, tb05ad.__doc__) g_i, hinvb = out[:-1] info = out[-1] return g_i, hinvb, info @@ -666,7 +654,7 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): raise SlycotParameterError("Parameter rowcol had an illegal value", -1) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( "The leading coefficient of a denominator polynomial is nearly " @@ -763,14 +751,14 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): if leri == 'L': out = _wrapper.tc04ad_l(m,p,index,pcoeff,qcoeff,n) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError('P(s) is not row proper', out[-1]) return out[:-1] if leri == 'R': out = _wrapper.tc04ad_r(m,p,index,pcoeff,qcoeff,n) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError('P(s) is not column proper', out[-1]) return out[:-1] @@ -825,12 +813,12 @@ def tc01od(m,p,indlin,pcoeff,qcoeff,leri): if leri == 'L': out = _wrapper.tc01od_l(m,p,indlin,pcoeff,qcoeff) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] if leri == 'R': out = _wrapper.tc01od_r(m,p,indlin,pcoeff,qcoeff) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] raise SlycotParameterError('leri must be either L or R', -1) @@ -874,7 +862,7 @@ def tf01md(n,m,p,N,A,B,C,D,u,x0): out = _wrapper.tf01md(n,m,p,N,A,B,C,D,u,x0) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def tf01rd(n,m,p,N,A,B,C,ldwork=None): @@ -919,7 +907,7 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): else: out = _wrapper.tf01rd(n,m,p,N,A,B,C,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[0] def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): @@ -1000,7 +988,7 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): job=job,equil=equil,tol=tol,ldwork=ldwork) if out[-1] < 0: - raise SlycotParameterError(None, out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): @@ -1100,7 +1088,7 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) if info != 0: raise SlycotArithmeticError('tg01ad failed', info) @@ -1288,7 +1276,7 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld "The combination of compq and compz is not implemented", -1) if info < 0: - raise SlycotParameterError(None, info, arg_list) + raise_if_slycot_error(info, arg_list) if info != 0: raise SlycotArithmeticError('tg01fd failed', info) From 89429ad39d8658046a5434074f1c55491d516362 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 16:28:40 +0200 Subject: [PATCH 168/405] count exception messages in synthesis --- slycot/tests/test_sb.py | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) mode change 100644 => 100755 slycot/tests/test_sb.py diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py old mode 100644 new mode 100755 index 1322360d..759fc47f --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -4,7 +4,7 @@ from slycot import synthesis from numpy import array, eye, zeros from numpy.testing import assert_allclose - +from slycot.exceptions import filter_docstring_exceptions def test_sb02mt(): """Test if sb02mt is callable @@ -97,3 +97,19 @@ def test_sb10jd(): assert_allclose(B_r, Bexp, atol=1e-5) assert_allclose(C_r, Cexp, atol=1e-5) assert_allclose(D_r, Dexp, atol=1e-5) + +def test_exceptionstrings(): + assert(len(filter_docstring_exceptions(synthesis.sb01bd.__doc__)) == 4) + assert(len(filter_docstring_exceptions(synthesis.sb02md.__doc__)) == 5) + assert(len(filter_docstring_exceptions(synthesis.sb02od.__doc__)) == 6) + assert(len(filter_docstring_exceptions(synthesis.sb03md.__doc__)) == 0) + assert(len(filter_docstring_exceptions(synthesis.sb03od.__doc__)) == 6) + assert(len(filter_docstring_exceptions(synthesis.sb04md.__doc__)) == 0) + assert(len(filter_docstring_exceptions(synthesis.sb04qd.__doc__)) == 0) + assert(len(filter_docstring_exceptions(synthesis.sb10ad.__doc__)) == 12) + assert(len(filter_docstring_exceptions(synthesis.sb10dd.__doc__)) == 9) + assert(len(filter_docstring_exceptions(synthesis.sb10hd.__doc__)) == 5) + assert(len(filter_docstring_exceptions(synthesis.sb10jd.__doc__)) == 0) + assert(len(filter_docstring_exceptions(synthesis.sg03ad.__doc__)) == 4) + assert(len(filter_docstring_exceptions(synthesis.sg02ad.__doc__)) == 7) + assert(len(filter_docstring_exceptions(synthesis.sg03bd.__doc__)) == 7) From 0fd2ea5105eea5195206c8b3508d41b61106bd03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 16:36:29 +0200 Subject: [PATCH 169/405] Only on indexError should we report unhandled code --- slycot/exceptions.py | 2 +- slycot/tests/__init__.py | 0 slycot/tests/test_examples.py | 0 slycot/tests/test_mb.py | 0 slycot/tests/test_sb.py | 0 slycot/tests/test_sg02ad.py | 0 6 files changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 slycot/tests/__init__.py mode change 100755 => 100644 slycot/tests/test_examples.py mode change 100755 => 100644 slycot/tests/test_mb.py mode change 100755 => 100644 slycot/tests/test_sb.py mode change 100755 => 100644 slycot/tests/test_sg02ad.py diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 7cd8b0d0..b797d296 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -87,7 +87,7 @@ def raise_if_slycot_error(info, arg_list, docstring=None): messages = filter_docstring_exceptions(docstring) try: raise SlycotParameterError(messages[info-1], info) - except: + except IndexError: raise SlycotParameterError( "Slycot returned an unhandled error code {}".format(info), info) diff --git a/slycot/tests/__init__.py b/slycot/tests/__init__.py old mode 100644 new mode 100755 diff --git a/slycot/tests/test_examples.py b/slycot/tests/test_examples.py old mode 100755 new mode 100644 diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py old mode 100755 new mode 100644 diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py old mode 100755 new mode 100644 diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py old mode 100755 new mode 100644 From d1b9ab175c5e7bd3f18bfe943b43c1c4ee607271 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 5 May 2020 17:24:54 +0200 Subject: [PATCH 170/405] simplify negative info parameter checks --- slycot/analysis.py | 31 ++++++++++++------------------ slycot/math.py | 46 +++++++++++++++++++++------------------------ slycot/synthesis.py | 15 +++++---------- slycot/transform.py | 39 +++++++++++++------------------------- 4 files changed, 51 insertions(+), 80 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 5b6b698b..fd733de1 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -123,20 +123,17 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): ldwork = max(n,3*m) if jobz == 'N': out = _wrapper.ab01nd_n(n,m,A,B,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) # sets Z to None out[5] = None return out[:-1] if jobz == 'I': out = _wrapper.ab01nd_i(n,m,A,B,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] if jobz == 'F': out = _wrapper.ab01nd_f(n,m,A,B,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] raise SlycotParameterError('jobz must be either N, I or F', -1) @@ -221,8 +218,7 @@ def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): 'LDB'+hidden, 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, 'DWORK'+hidden, 'ldwork', 'info'+hidden ] out = _wrapper.ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo=uplo) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): @@ -304,8 +300,7 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): if ldwork is None: ldwork = max(p1*p1,m1*m1,n1*p1) out = _wrapper.ab05nd(n1,m1,p1,n2,alpha,A1,B1,C1,D1,A2,B2,C2,D2,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'The resulting system is not completely controllable.', @@ -362,8 +357,7 @@ def ab07nd(n,m,A,B,C,D,ldwork=None): if ldwork is None: ldwork = max(1,4*m) out = _wrapper.ab07nd(n,m,A,B,C,D,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == m+1: raise SlycotArithmeticError( 'Entry matrix D is numerically singular.', @@ -456,8 +450,7 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): if ldwork is None: ldwork = n+3*max(m,p) #only an upper bound out = _wrapper.ab08nd(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): @@ -558,12 +551,12 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): lzwork = max(min(p, m) + max(3*m-1, n), min(p, n) + max(3*p-1, n+p, n+m), min(m, n) + max(3*m-1, n+m)) - out = _wrapper.ab08nz(n, m, p, A, B, C, D, - equil=equil, tol=tol, lzwork=lzwork) + nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, zwork, info \ - = out - if info < 0: - raise_if_slycot_error(info, arg_list) + = _wrapper.ab08nz(n, m, p, A, B, C, D, + equil=equil, tol=tol, lzwork=lzwork) + + raise_if_slycot_error(info, arg_list) return (nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, Af, Bf, int(zwork[0].real)) diff --git a/slycot/math.py b/slycot/math.py index 0cf0a156..49113429 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -237,8 +237,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): Ar, Xr, nblcks, blsize, wr, wi, info = _wrapper.mb03rd( jobx, sort, n, pmax, A, X, tol) - if info < 0: - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(info, arg_list) if jobx == 'N': Xr = None else: @@ -365,8 +364,7 @@ def mb03vd(n, ilo, ihi, A): HQ, Tau, info = _wrapper.mb03vd(n, ilo, ihi, A) - if info < 0: - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(info, arg_list) return (HQ, Tau) @@ -426,8 +424,7 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): Q, info = _wrapper.mb03vy(n, ilo, ihi, A, Tau, ldwork) - if info < 0: - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(info, arg_list) return Q @@ -559,9 +556,9 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): T, Z, Wr, Wi, info = _wrapper.mb03wd( job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) - if info < 0: - raise_if_slycot_error(info, arg_list) - elif info > 0: + raise_if_slycot_error(info, arg_list) + + if info > 0: warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " "in a total of 30*({ihi}-{ilo}+1) iterations " "the elements {i}:{ihi} of Wr contain those " @@ -649,15 +646,10 @@ def mb05md(a, delta, balanc='N'): n=n, delta=delta, a=a) - if INFO == 0: - if not all(VALi == 0): - VAL = VALr + 1J*VALi - else: - VAL = VALr - return (Ar, Vr, Yr, VAL) - elif INFO < 0: - raise_if_slycot_error(info, arg_list) - elif INFO > 0 and INFO <= n: + + raise_if_slycot_error(info, arg_list) + + if INFO > 0 and INFO <= n: raise SlycotArithmeticError("Incomplete eigenvalue calculation, " "missing {} eigenvalues".format(INFO), INFO) @@ -666,6 +658,12 @@ def mb05md(a, delta, balanc='N'): elif INFO == n+2: raise SlycotArithmeticError("Matrix A is defective, " "possibly due to rounding errors.", INFO) + if not all(VALi == 0): + VAL = VALr + 1J*VALi + else: + VAL = VALr + return (Ar, Vr, Yr, VAL) + def mb05nd(a, delta, tol=1e-7): @@ -697,12 +695,11 @@ def mb05nd(a, delta, tol=1e-7): 'dwork'+hidden, 'ldwork'+hidden] n = min(a.shape) out = _wrapper.mb05nd(n=n, delta=delta, a=a, tol=tol) - if out[-1] == 0: - return out[:-1] - elif out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) - elif out[-1] == n+1: + + raise_if_slycot_error(out[-1], arg_list) + if out[-1] == n+1: raise SlycotArithmeticError("Delta too large", out[-1]) + return out[:-1] @@ -747,8 +744,7 @@ def mc01td(dico, dp, p): arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, 'IWARN', 'INFO'] (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) - if info < 0: - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(info, arg_list) if info == 1: warnings.warn('entry P(x) is the zero polynomial.') if info == 2: diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 127548bf..38df780f 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -474,8 +474,7 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): out = _wrapper.sb02mt_nl(n,m,A,B,Q,R,L,uplo=uplo,ldwork=ldwork) if out is None: raise SlycotParameterError('fact must be either C or N.', -3) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: raise SlycotArithmeticError('the {}-th element of d in the UdU (LdL) ' 'factorization is zero.'.format(out[-1]), @@ -805,8 +804,7 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == n+1: if dico == 'D': error_text = 'The matrix A has eigenvalues that are almost reciprocal.' @@ -997,8 +995,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03od(dico,n,m,A,Q,B,fact=fact,trans=trans,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == 1: if dico == 'D': error_text = """this means that while the matrix A @@ -1112,8 +1109,7 @@ def sb04md(n,m,A,B,C,ldwork=None): else: out = _wrapper.sb04md(n,m,A,B,C,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" @@ -1172,8 +1168,7 @@ def sb04qd(n,m,A,B,C,ldwork=None): out = _wrapper.sb04qd(n,m,A,B,C) else: out = _wrapper.sb04qd(n,m,A,B,C,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0 and out[-1] <= m: error_text = """The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES)""" diff --git a/slycot/transform.py b/slycot/transform.py index 25313ce9..0e76d73b 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -213,8 +213,7 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): if ldwork is None: ldwork = max( 2*n + 3*max(m,p), p*(p+2)) out = _wrapper.tb03ad_l(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'a singular matrix was encountered during the computation', @@ -224,8 +223,7 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): if ldwork is None: ldwork = max( 2*n + 3*max(m,p), m*(m+2)) out = _wrapper.tb03ad_r(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( 'a singular matrix was encountered during the computation', @@ -314,8 +312,7 @@ def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): -11) out = _wrapper.tb04ad_r(n,m,p,A,B,C,D,tol1,tol2,ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) A,B,C,Nr,index,dcoeff,ucoeff = out[:-1] kdcoef = max(index)+1 @@ -653,8 +650,7 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): else: raise SlycotParameterError("Parameter rowcol had an illegal value", -1) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] > 0: raise SlycotArithmeticError( "The leading coefficient of a denominator polynomial is nearly " @@ -750,15 +746,13 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): n = sum(index) if leri == 'L': out = _wrapper.tc04ad_l(m,p,index,pcoeff,qcoeff,n) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError('P(s) is not row proper', out[-1]) return out[:-1] if leri == 'R': out = _wrapper.tc04ad_r(m,p,index,pcoeff,qcoeff,n) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) if out[-1] == 1: raise SlycotArithmeticError('P(s) is not column proper', out[-1]) return out[:-1] @@ -812,13 +806,11 @@ def tc01od(m,p,indlin,pcoeff,qcoeff,leri): 'INFO'+hidden] if leri == 'L': out = _wrapper.tc01od_l(m,p,indlin,pcoeff,qcoeff) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] if leri == 'R': out = _wrapper.tc01od_r(m,p,indlin,pcoeff,qcoeff) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] raise SlycotParameterError('leri must be either L or R', -1) @@ -861,8 +853,7 @@ def tf01md(n,m,p,N,A,B,C,D,u,x0): 'y'+hidden,'ldy'+hidden,'dwork'+hidden,'info'+hidden] out = _wrapper.tf01md(n,m,p,N,A,B,C,D,u,x0) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def tf01rd(n,m,p,N,A,B,C,ldwork=None): @@ -906,8 +897,7 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): out = _wrapper.tf01rd(n,m,p,N,A,B,C) else: out = _wrapper.tf01rd(n,m,p,N,A,B,C,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[0] def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): @@ -987,8 +977,7 @@ def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): out = _wrapper.tb01pd(n=n,m=m,p=p,a=A,b=B,c=C, job=job,equil=equil,tol=tol,ldwork=ldwork) - if out[-1] < 0: - raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): @@ -1087,8 +1076,7 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) - if info < 0: - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(info, arg_list) if info != 0: raise SlycotArithmeticError('tg01ad failed', info) @@ -1275,8 +1263,7 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld raise SlycotParameterError( "The combination of compq and compz is not implemented", -1) - if info < 0: - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(info, arg_list) if info != 0: raise SlycotArithmeticError('tg01fd failed', info) From dbf643b6824fef7fa2cd299423ed6f5244b864c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 17:16:54 +0200 Subject: [PATCH 171/405] actually test error message/info matching. Did reveal some fixes to exception parsing code --- slycot/exceptions.py | 7 ++++++- slycot/tests/test_tb05ad.py | 19 +++++++++++++++++++ slycot/transform.py | 2 +- 3 files changed, 26 insertions(+), 2 deletions(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index b797d296..be3efc8b 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -62,6 +62,11 @@ def filter_docstring_exceptions(docstring): exdict[index] = '\n'.join(msg) msg = [] index = 0 + elif not l: + if msg: + exdict[index] = '\n'.join(msg) + msg = [] + index = 0 elif index: msg.append(l.strip()) if msg: @@ -86,7 +91,7 @@ def raise_if_slycot_error(info, arg_list, docstring=None): # process the docstring for the error message messages = filter_docstring_exceptions(docstring) try: - raise SlycotParameterError(messages[info-1], info) + raise SlycotParameterError(messages[info], info) except IndexError: raise SlycotParameterError( "Slycot returned an unhandled error code {}".format(info), diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index df7ac42e..c17ed244 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -3,6 +3,7 @@ import unittest from slycot import transform import numpy as np +from slycot.exceptions import SlycotError from numpy.testing import assert_raises, assert_almost_equal @@ -154,6 +155,24 @@ def check_tb05ad_errors(self, sys): assert_raises(ValueError, transform.tb05ad, n, m, p, jomega, sys['A'], sys['B'], sys['C'], job='a') + def test_tb05ad_resonance(self): + ''' + Actually test one of the exception messages. For many routines these are + parsed from the docstring, tests both the info index and the message + ''' + A = np.array([ [0, -1], [1, 0] ]) + B = np.array([ [1],[0] ]) + C = np.array([ [0, 1 ]]) + jomega = 1j + from numpy.linalg import eig + print( eig(A)) + try: + transform.tb05ad(2, 1, 1, jomega, A, B, C, job='NH') + except SlycotError as e: + assert(str(e) == \ + """Either FREQ is too near to an eigenvalue of A, or RCOND +is less than the machine precision EPS.""") + assert(e.info == 2) if __name__ == "__main__": unittest.main() diff --git a/slycot/transform.py b/slycot/transform.py index 0e76d73b..14e78d40 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -462,7 +462,7 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): SlycotArithmeticError : e :e.info = 1: More than 30 iterations were required to isolate the - eigenvalues of A. The computation is continued ?. + eigenvalues of A. The computations are continued. :e.info = 2: Either FREQ is too near to an eigenvalue of A, or RCOND is less than the machine precision EPS. From 42cfb49b8c4eb453d98d3d49559b77465dba8509 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 5 May 2020 17:29:13 +0200 Subject: [PATCH 172/405] only check docstring if provided --- slycot/exceptions.py | 2 +- slycot/math.py | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index be3efc8b..82a8905c 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -87,7 +87,7 @@ def raise_if_slycot_error(info, arg_list, docstring=None): message = ("The following argument had an illegal value: {}" "".format(arg_list[-info-1])) raise SlycotParameterError(message, info) - elif info > 0: + elif info > 0 and docstring: # process the docstring for the error message messages = filter_docstring_exceptions(docstring) try: diff --git a/slycot/math.py b/slycot/math.py index 49113429..d5b8ac0c 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -557,7 +557,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) raise_if_slycot_error(info, arg_list) - + if info > 0: warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " "in a total of 30*({ihi}-{ilo}+1) iterations " @@ -647,7 +647,7 @@ def mb05md(a, delta, balanc='N'): delta=delta, a=a) - raise_if_slycot_error(info, arg_list) + raise_if_slycot_error(INFO, arg_list) if INFO > 0 and INFO <= n: raise SlycotArithmeticError("Incomplete eigenvalue calculation, " @@ -695,7 +695,7 @@ def mb05nd(a, delta, tol=1e-7): 'dwork'+hidden, 'ldwork'+hidden] n = min(a.shape) out = _wrapper.mb05nd(n=n, delta=delta, a=a, tol=tol) - + raise_if_slycot_error(out[-1], arg_list) if out[-1] == n+1: raise SlycotArithmeticError("Delta too large", out[-1]) From b9bfaae2f351146fd839d944498d2852045d93d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 17:23:53 +0200 Subject: [PATCH 173/405] correct sb01bd copy and paste error --- slycot/synthesis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 38df780f..c01376e6 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -152,7 +152,7 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): ldwork = max(1,5*m,5*n,2*n+4*m) A_z,wr,wi,nfp,nap,nup,F,Z,warn,info = _wrapper.sb01bd(dico,n,m,np,alpha,A,B,w.real,w.imag,tol=tol,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list, sb01bd.__doc__) + raise_if_slycot_error(info, arg_list, sb01bd.__doc__) if warn != 0: warnings.warn('%i violations of the numerical stability condition occured during the assignment of eigenvalues' % warn) From 8b5b8f9c4a15d2a71b80058026717995ce262791 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 May 2020 01:58:16 +0200 Subject: [PATCH 174/405] rework exception docstring parser --- slycot/exceptions.py | 195 ++++++++++++++++++++++++++---------- slycot/synthesis.py | 4 +- slycot/tests/test_sb.py | 35 +++---- slycot/tests/test_tb05ad.py | 57 ++++++----- 4 files changed, 197 insertions(+), 94 deletions(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 82a8905c..14107685 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -18,6 +18,8 @@ MA 02110-1301, USA. """ +import re + class SlycotError(RuntimeError): """Slycot exception base class""" @@ -36,64 +38,153 @@ class SlycotParameterError(SlycotError, ValueError): pass + class SlycotArithmeticError(SlycotError, ArithmeticError): """A Slycot computation failed""" pass -def filter_docstring_exceptions(docstring): - """Check a docstring to find exception descriptions""" - - # check-count the message indices - index = 0 - exdict = {} - msg = [] - for l in docstring.split('\n'): - l = l.strip() - if l[:10] == ":e.info = " and l[-1] == ":": - try: - idx = int(l[10:-1]) - if msg: - exdict[index] = '\n'.join(msg) - msg = [] - index = idx - except ValueError: - if msg: - exdict[index] = '\n'.join(msg) - msg = [] - index = 0 - elif not l: - if msg: - exdict[index] = '\n'.join(msg) - msg = [] - index = 0 - elif index: - msg.append(l.strip()) - if msg: - exdict[index] = '\n'.join(msg) - return exdict - -def raise_if_slycot_error(info, arg_list, docstring=None): - """Raise exceptions if slycot info returned is non-zero - - For negative info, the argument as indicated in arg_list was erroneous - - For positive info, the matching exception text is recovered from - the docstring, which may in many cases simply be the python interface - routine docstring + +def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): + """Raise exceptions if slycot info returned is non-zero. + + Parameters + ---------- + info: int + The parameter INFO returned by the SLICOT subroutine + arg_list: list of str, optional + A list of arguments (possibly hidden by the wrapper) of the SLICOT + subroutine + docstring: str, optional + The docstring of the Slycot function + checkvars: dict, optional + dict of variables for evaluation of and formatting the + exception message + + Notes + ----- + If the numpydoc compliant docstring has a "Raises" section with one or + multiple definition terms ``SlycotError : e`` or a subclass of it, + the matching exception text is used. + + The definition body must contain a reST compliant field list with + '::' as field name, where specifies the valid values + for `e.ìnfo` in a python parseable expression using the variables provided + in `checkvars`. A single " = " is treated as " == ". + + The body of the field list contains the exception message and can contain + replacement fields in format string syntax using the variables in + `checkvars`. + + For negative info, the argument as indicated in arg_list was erroneous and + a generic SlycotParameterError is raised if no custom text was defined in + the docstring or no docstring is provided. + + Example + ------- + >>> def fun(info): + ... \"""Example function + ... + ... Raises + ... ------ + ... SlycotArithmeticError : e + ... :e.info = 1: Info is 1 + ... :e.info > 1 and e.info < n: + ... Info is {e.info}, which is between 1 and {n} + ... :n <= e.info < m: + ... {e.info} is between {n} and {m:10.2g}! + ... \""" + ... n, m = 4, 1.2e2 + ... raise_if_slycot_error(info, + ... arg_list=["a", "b", "c"], + ... docstring=fun.__doc__, + ... checkvars=locals()) + ... + >>> fun(0) + >>> fun(-1) + SlycotParameterError: The following argument had an illegal value: a + >>> fun(1) + SlycotArithmeticError: Info is 1 + >>> fun(2) + SlycotArithmeticError: Info is 2, which is between 1 and 4 + >>> fun(5) + SlycotArithmeticError: 4 is between 4 and 1.2e+02! """ + if docstring: + slycot_error_map = {"SlycotError": SlycotError, + "SlycotParameterError": SlycotParameterError, + "SlycotArithmeticError": SlycotArithmeticError} - if info < 0: + docline = iter(docstring.splitlines()) + info_eval = False + try: + while "Raises" not in next(docline): + continue + + section_indent = next(docline).index("-") + + slycot_error = None + for l in docline: + print(l) + # ignore blank lines + if not l.strip(): + continue + + + # reached end of Raises section without match + if not l[:section_indent].isspace(): + return None + + # Exception Type + ematch = re.match( + r'(\s*)(Slycot(Parameter|Arithmetic)?Error) : e', l) + if ematch: + error_indent = len(ematch[1]) + slycot_error = ematch[2] + + # new infospec + if slycot_error: + imatch = re.match( + r'(\s{' + str(error_indent + 1) + r',}):(.*):\s*(.*)', + l) + if imatch: + infospec_indent = len(imatch[1]) + infospec = imatch[2] + # Don't handle the standard case unless we have i + if infospec == "e.info = -i": + if 'i' not in checkvars.keys(): + continue + infospec_ = infospec.replace(" = ", " == ") + checkvars['e'] = SlycotError("", info) + try: + info_eval = eval(infospec_, checkvars) + except NameError: + raise RuntimeError("Unknown variable in infospec: " + + infospec) + except SyntaxError: + raise RuntimeError("Invalid infospec: " + + infospec) + if info_eval: + message = imatch[3].strip() + '\n' + mmatch = re.match( + r'(\s{' + str(infospec_indent+1) + r',})(.*)', + next(docline)) + if not mmatch: + break # docstring + body_indent = len(mmatch[1]) + message += mmatch[2] + '\n' + for l in docline: + if l and not l[:body_indent].isspace(): + break # message body + message += l[body_indent:] + '\n' + break # docstring + except StopIteration: + pass + if info_eval and message: + fmessage = '\n' + message.format(**checkvars).strip() + raise slycot_error_map[slycot_error](fmessage, info) + + if info < 0 and arg_list: message = ("The following argument had an illegal value: {}" - "".format(arg_list[-info-1])) + "".format(arg_list[-info-1])) raise SlycotParameterError(message, info) - elif info > 0 and docstring: - # process the docstring for the error message - messages = filter_docstring_exceptions(docstring) - try: - raise SlycotParameterError(messages[info], info) - except IndexError: - raise SlycotParameterError( - "Slycot returned an unhandled error code {}".format(info), - info) - diff --git a/slycot/synthesis.py b/slycot/synthesis.py index c01376e6..9518548b 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2490,7 +2490,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): eigenvalues of the matrix pencil A - lambda * E. Raises - ------ + ------ SlycotParameterError : e :e.info = -i: the i-th argument had an illegal value; @@ -2507,7 +2507,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): :e.info = 3: fact = 'F' and there is a 2-by-2 block on the main diagonal of the pencil A_s - lambda * E_s whose - igenvalues are not conjugate complex; + eigenvalues are not conjugate complex; :e.info = 4: fact = 'N' and the pencil A - lambda * E cannot be reduced to generalized Schur form: LAPACK routine diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 759fc47f..570f7493 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -2,9 +2,13 @@ # sb* synthesis tests from slycot import synthesis +from slycot.exceptions import raise_if_slycot_error, SlycotError, \ + SlycotParameterError, SlycotArithmeticError + from numpy import array, eye, zeros -from numpy.testing import assert_allclose -from slycot.exceptions import filter_docstring_exceptions +from numpy.testing import assert_allclose, assert_raises +import pytest + def test_sb02mt(): """Test if sb02mt is callable @@ -98,18 +102,15 @@ def test_sb10jd(): assert_allclose(C_r, Cexp, atol=1e-5) assert_allclose(D_r, Dexp, atol=1e-5) -def test_exceptionstrings(): - assert(len(filter_docstring_exceptions(synthesis.sb01bd.__doc__)) == 4) - assert(len(filter_docstring_exceptions(synthesis.sb02md.__doc__)) == 5) - assert(len(filter_docstring_exceptions(synthesis.sb02od.__doc__)) == 6) - assert(len(filter_docstring_exceptions(synthesis.sb03md.__doc__)) == 0) - assert(len(filter_docstring_exceptions(synthesis.sb03od.__doc__)) == 6) - assert(len(filter_docstring_exceptions(synthesis.sb04md.__doc__)) == 0) - assert(len(filter_docstring_exceptions(synthesis.sb04qd.__doc__)) == 0) - assert(len(filter_docstring_exceptions(synthesis.sb10ad.__doc__)) == 12) - assert(len(filter_docstring_exceptions(synthesis.sb10dd.__doc__)) == 9) - assert(len(filter_docstring_exceptions(synthesis.sb10hd.__doc__)) == 5) - assert(len(filter_docstring_exceptions(synthesis.sb10jd.__doc__)) == 0) - assert(len(filter_docstring_exceptions(synthesis.sg03ad.__doc__)) == 4) - assert(len(filter_docstring_exceptions(synthesis.sg02ad.__doc__)) == 7) - assert(len(filter_docstring_exceptions(synthesis.sg03bd.__doc__)) == 7) + +@pytest.mark.parametrize( + 'fun, info, exception, checkvars', + [(synthesis.sb01bd, -1, SlycotParameterError, {}), + (synthesis.sb01bd, 1, SlycotArithmeticError, {}), + (synthesis.sb01bd, 2, SlycotArithmeticError, {}), ]) +def test_sb_exceptionstrings(fun, info, exception, checkvars): + assert_raises(exception, raise_if_slycot_error, info, arg_list=["a", "b"], + docstring=fun.__doc__, checkvars=checkvars) + + + diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index c17ed244..bc5b0b6f 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -1,11 +1,13 @@ # =================================================== # tb05ad tests -import unittest + from slycot import transform +from slycot.exceptions import SlycotArithmeticError, SlycotParameterError + import numpy as np -from slycot.exceptions import SlycotError -from numpy.testing import assert_raises, assert_almost_equal +import unittest +from numpy.testing import assert_almost_equal # set the random seed so we can get consistent results. @@ -143,36 +145,45 @@ def check_tb05ad_errors(self, sys): jomega = 10*1j # test error handling # wrong size A - assert_raises(ValueError, transform.tb05ad, n+1, m, p, - jomega, sys['A'], sys['B'], sys['C'], job='NH') + with self.assertRaises(SlycotParameterError) as cm: + transform.tb05ad( + n+1, m, p, jomega, sys['A'], sys['B'], sys['C'], job='NH') + assert cm.exception.info == -7 # wrong size B - assert_raises(ValueError, transform.tb05ad, n, m+1, p, - jomega, sys['A'], sys['B'], sys['C'], job='NH') + with self.assertRaises(SlycotParameterError) as cm: + transform.tb05ad( + n, m+1, p, jomega, sys['A'], sys['B'], sys['C'], job='NH') + assert cm.exception.info == -9 # wrong size C - assert_raises(ValueError, transform.tb05ad, n, m, p+1, - jomega, sys['A'], sys['B'], sys['C'], job='NH') + with self.assertRaises(SlycotParameterError) as cm: + transform.tb05ad( + n, m, p+1, jomega, sys['A'], sys['B'], sys['C'], job='NH') + assert cm.exception.info == -11 # unrecognized job - assert_raises(ValueError, transform.tb05ad, n, m, p, jomega, - sys['A'], sys['B'], sys['C'], job='a') + with self.assertRaises(SlycotParameterError) as cm: + transform.tb05ad( + n, m, p, jomega, sys['A'], sys['B'], sys['C'], job='a') + assert cm.exception.info == -1 def test_tb05ad_resonance(self): - ''' - Actually test one of the exception messages. For many routines these are - parsed from the docstring, tests both the info index and the message - ''' + """ Test tb05ad resonance failure. + + Actually test one of the exception messages. For many routines these + are parsed from the docstring, tests both the info index and the + message + """ A = np.array([ [0, -1], [1, 0] ]) B = np.array([ [1],[0] ]) C = np.array([ [0, 1 ]]) jomega = 1j - from numpy.linalg import eig - print( eig(A)) - try: + with self.assertRaises( + SlycotArithmeticError, + msg="\n" + "Either FREQ is too near to an eigenvalue of A, or RCOND\n" + "is less than the machine precision EPS.") as cm: transform.tb05ad(2, 1, 1, jomega, A, B, C, job='NH') - except SlycotError as e: - assert(str(e) == \ - """Either FREQ is too near to an eigenvalue of A, or RCOND -is less than the machine precision EPS.""") - assert(e.info == 2) + assert cm.exception.info == 2 + if __name__ == "__main__": unittest.main() From ed027fbff900c8c67d6f02f25bb72b914f2dab9f Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 May 2020 03:24:19 +0200 Subject: [PATCH 175/405] fix python 2 compatibility in regexp --- slycot/exceptions.py | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 14107685..26b6c5c6 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -130,7 +130,6 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): if not l.strip(): continue - # reached end of Raises section without match if not l[:section_indent].isspace(): return None @@ -139,8 +138,8 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): ematch = re.match( r'(\s*)(Slycot(Parameter|Arithmetic)?Error) : e', l) if ematch: - error_indent = len(ematch[1]) - slycot_error = ematch[2] + error_indent = len(ematch.group(1)) + slycot_error = ematch.group(2) # new infospec if slycot_error: @@ -148,8 +147,8 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): r'(\s{' + str(error_indent + 1) + r',}):(.*):\s*(.*)', l) if imatch: - infospec_indent = len(imatch[1]) - infospec = imatch[2] + infospec_indent = len(imatch.group(1)) + infospec = imatch.group(2) # Don't handle the standard case unless we have i if infospec == "e.info = -i": if 'i' not in checkvars.keys(): @@ -165,14 +164,14 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): raise RuntimeError("Invalid infospec: " + infospec) if info_eval: - message = imatch[3].strip() + '\n' + message = imatch.group(3).strip() + '\n' mmatch = re.match( r'(\s{' + str(infospec_indent+1) + r',})(.*)', next(docline)) if not mmatch: break # docstring - body_indent = len(mmatch[1]) - message += mmatch[2] + '\n' + body_indent = len(mmatch.group(1)) + message += mmatch.group(2) + '\n' for l in docline: if l and not l[:body_indent].isspace(): break # message body From 1877bc34c1627752a914625442491ea2ce074a17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Wed, 6 May 2020 12:26:58 +0200 Subject: [PATCH 176/405] adding a more extensive check of docstring parsing --- slycot/synthesis.py | 2 +- slycot/tests/CMakeLists.txt | 3 ++- slycot/tests/docstring_check.py | 47 +++++++++++++++++++++++++++++++++ slycot/tests/test_sb.py | 22 ++++++++++++--- 4 files changed, 69 insertions(+), 5 deletions(-) create mode 100644 slycot/tests/docstring_check.py diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 9518548b..1d488f06 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1152,7 +1152,7 @@ def sb04qd(n,m,A,B,C,ldwork=None): SlycotParameterError : e :e.info = -i: the i-th argument had an illegal value; SlycotArithmeticError : e - :e.info => 0: + :1 <= e.info <= m: if info = i, 1 <= i <= m, the QR algorithm failed to compute all the eigenvalues of B (see LAPACK Library routine DGEES) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index ec4b5ea1..af46312b 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -12,7 +12,8 @@ set(PYSOURCE test_tb05ad.py test_td04ad.py test_tg01ad.py - test_tg01fd.py ) + test_tg01fd.py + docstring_check.py ) install(FILES ${PYSOURCE} PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE diff --git a/slycot/tests/docstring_check.py b/slycot/tests/docstring_check.py new file mode 100644 index 00000000..17376a5e --- /dev/null +++ b/slycot/tests/docstring_check.py @@ -0,0 +1,47 @@ +""" +docstring_check.py + +Copyright 2020 Slycot team + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License version 2 as +published by the Free Software Foundation. + +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, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +MA 02110-1301, USA. +""" +from numpy.testing import assert_raises +from slycot.exceptions import SlycotError, raise_if_slycot_error + +def assert_docstring_parse(docstring, erange, checkvars={}): + """To check that a docstring can be parsed into exceptions + See also raise_if_slycot_error + + Parameters + ---------- + docstring: str + Documentation string with exception definitions + erange: int or iterable with int + Error numbers for which the documentation should have + exception text + checkvars: dict, optional + dict of variables for evaluation of and formatting the + exception message + """ + + # if erange is a simple integer, assume a continous range of errors + try: + erange = range(1,erange+1) + except TypeError: + pass + + for info in erange: + assert_raises(SlycotError, raise_if_slycot_error, info, [], + docstring, checkvars) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 570f7493..7e4989ea 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -8,7 +8,7 @@ from numpy import array, eye, zeros from numpy.testing import assert_allclose, assert_raises import pytest - +from .docstring_check import assert_docstring_parse def test_sb02mt(): """Test if sb02mt is callable @@ -112,5 +112,21 @@ def test_sb_exceptionstrings(fun, info, exception, checkvars): assert_raises(exception, raise_if_slycot_error, info, arg_list=["a", "b"], docstring=fun.__doc__, checkvars=checkvars) - - +@pytest.mark.parametrize( + 'fun, erange, checkvars', + ( ( synthesis.sb01bd, 4, {} ), + ( synthesis.sb02md, 5, {} ), + ( synthesis.sb02od, 6, {} ), + ( synthesis.sb03md, 3, { 'N': 2} ), + ( synthesis.sb03od, 6, {} ), + ( synthesis.sb04md, 2, { 'm': 1} ), + ( synthesis.sb04qd, 3, { 'm': 2} ), + ( synthesis.sb10ad, 12, {} ), + ( synthesis.sb10dd, 9, {} ), + ( synthesis.sb10hd, 4, {} ), + ( synthesis.sb10jd, 0, {} ), + ( synthesis.sg03ad, 4, {} ), + ( synthesis.sg02ad, 7, {} ), + ( synthesis.sg03bd, 7, {} ) ) ) +def test_sb_docparse(fun, erange, checkvars): + assert_docstring_parse(fun.__doc__, erange, checkvars) From d2f684d97385a315aa42c29b24ed4f37d0c17406 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 May 2020 16:35:16 +0200 Subject: [PATCH 177/405] extend the parser to warnings --- slycot/exceptions.py | 168 ++++++++++-------- slycot/math.py | 131 +++++++------- slycot/synthesis.py | 85 ++++----- slycot/tests/CMakeLists.txt | 4 +- ...{docstring_check.py => test_exceptions.py} | 33 +++- slycot/tests/test_mb.py | 24 ++- slycot/tests/test_sb.py | 51 +++--- 7 files changed, 273 insertions(+), 223 deletions(-) rename slycot/tests/{docstring_check.py => test_exceptions.py} (53%) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 26b6c5c6..e9968220 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -20,6 +20,8 @@ import re +from warnings import warn + class SlycotError(RuntimeError): """Slycot exception base class""" @@ -45,8 +47,91 @@ class SlycotArithmeticError(SlycotError, ArithmeticError): pass +class SlycotWarning(UserWarning): + """Slycot Warning""" + + def __init__(self, message, info): + super(SlycotWarning, self).__init__(message) + self.info = info + + +class SlycotResultWarning(SlycotWarning): + """Slycot computation result warning + + A Slycot routine returned a nonzero info parameter that warns about the + returned results, but the results might still be usable. + """ + + pass + + +def _parse_docsection(section_name, docstring, checkvars): + slycot_error = None + message = None + docline = iter(docstring.splitlines()) + try: + + info_eval = False + while section_name not in next(docline): + continue + section_indent = next(docline).index("-") + + for l in docline: + # ignore blank lines + if not l.strip(): + continue + + # reached next section without match + if l[section_indent] == "-": + break + + # Exception Type + ematch = re.match( + r'(\s*)(Slycot.*(Error|Warning)) : e', l) + if ematch: + error_indent = len(ematch.group(1)) + slycot_error = ematch.group(2) + + # new infospec + if slycot_error: + imatch = re.match( + r'(\s{' + str(error_indent + 1) + r',}):(.*):\s*(.*)', l) + if imatch: + infospec_indent = len(imatch.group(1)) + infospec = imatch.group(2) + # Don't handle the standard case unless we have i + if infospec == "e.info = -i": + if 'i' not in checkvars.keys(): + continue + infospec_ = infospec.replace(" = ", " == ") + try: + info_eval = eval(infospec_, checkvars) + except NameError: + raise RuntimeError("Unknown variable in infospec: " + + infospec) + except SyntaxError: + raise RuntimeError("Invalid infospec: " + infospec) + if info_eval: + message = imatch.group(3).strip() + '\n' + mmatch = re.match( + r'(\s{' + str(infospec_indent+1) + r',})(.*)', + next(docline)) + if not mmatch: + break # docstring + body_indent = len(mmatch.group(1)) + message += mmatch.group(2) + '\n' + for l in docline: + if l and not l[:body_indent].isspace(): + break # message body + message += l[body_indent:] + '\n' + break # docstring + except StopIteration: + pass + return (slycot_error, message) + + def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): - """Raise exceptions if slycot info returned is non-zero. + """Raise exceptions or warnings if slycot info returned is non-zero. Parameters ---------- @@ -80,6 +165,9 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): a generic SlycotParameterError is raised if no custom text was defined in the docstring or no docstring is provided. + To rase warnings, define a "Warns" section similarly formatted as "Raises" + using the ``SlycotResultWarning : e`` definition name. + Example ------- >>> def fun(info): @@ -111,77 +199,17 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): SlycotArithmeticError: 4 is between 4 and 1.2e+02! """ if docstring: - slycot_error_map = {"SlycotError": SlycotError, - "SlycotParameterError": SlycotParameterError, - "SlycotArithmeticError": SlycotArithmeticError} - - docline = iter(docstring.splitlines()) - info_eval = False - try: - while "Raises" not in next(docline): - continue + checkvars['e'] = SlycotError("", info) - section_indent = next(docline).index("-") - - slycot_error = None - for l in docline: - print(l) - # ignore blank lines - if not l.strip(): - continue - - # reached end of Raises section without match - if not l[:section_indent].isspace(): - return None - - # Exception Type - ematch = re.match( - r'(\s*)(Slycot(Parameter|Arithmetic)?Error) : e', l) - if ematch: - error_indent = len(ematch.group(1)) - slycot_error = ematch.group(2) - - # new infospec - if slycot_error: - imatch = re.match( - r'(\s{' + str(error_indent + 1) + r',}):(.*):\s*(.*)', - l) - if imatch: - infospec_indent = len(imatch.group(1)) - infospec = imatch.group(2) - # Don't handle the standard case unless we have i - if infospec == "e.info = -i": - if 'i' not in checkvars.keys(): - continue - infospec_ = infospec.replace(" = ", " == ") - checkvars['e'] = SlycotError("", info) - try: - info_eval = eval(infospec_, checkvars) - except NameError: - raise RuntimeError("Unknown variable in infospec: " - + infospec) - except SyntaxError: - raise RuntimeError("Invalid infospec: " - + infospec) - if info_eval: - message = imatch.group(3).strip() + '\n' - mmatch = re.match( - r'(\s{' + str(infospec_indent+1) + r',})(.*)', - next(docline)) - if not mmatch: - break # docstring - body_indent = len(mmatch.group(1)) - message += mmatch.group(2) + '\n' - for l in docline: - if l and not l[:body_indent].isspace(): - break # message body - message += l[body_indent:] + '\n' - break # docstring - except StopIteration: - pass - if info_eval and message: + exception, message = _parse_docsection("Raises", docstring, checkvars) + if exception and message: fmessage = '\n' + message.format(**checkvars).strip() - raise slycot_error_map[slycot_error](fmessage, info) + raise globals()[exception](fmessage, info) + + warning, message = _parse_docsection("Warns", docstring, checkvars) + if warning and message: + fmessage = message.format(**checkvars).strip() + warn(globals()[warning](fmessage, info)) if info < 0 and arg_list: message = ("The following argument had an illegal value: {}" diff --git a/slycot/math.py b/slycot/math.py index d5b8ac0c..217be5e8 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -578,63 +578,78 @@ def mb05md(a, delta, balanc='N'): Matrix exponential for a real non-defective matrix - To compute exp(A*delta) where A is a real N-by-N non-defective + To compute ``exp(A*delta)`` where `A` is a real N-by-N non-defective matrix with real or complex eigenvalues and delta is a scalar value. The routine also returns the eigenvalues and eigenvectors - of A as well as (if all eigenvalues are real) the matrix product - exp(Lambda*delta) times the inverse of the eigenvector matrix of - A, where Lambda is the diagonal matrix of eigenvalues. + of `A` as well as (if all eigenvalues are real) the matrix product + ``exp(Lambda*delta)`` times the inverse of the eigenvector matrix of + `A`, where `Lambda` is the diagonal matrix of eigenvalues. Optionally, the routine computes a balancing transformation to improve the conditioning of the eigenvalues and eigenvectors. - Required arguments: - A : input rank-2 array('d') with bounds (n,n) - Square matrix - delta : input 'd' - The scalar value delta of the problem. - - Optional arguments: - balanc : input char*1 - Indicates how the input matrix should be diagonally scaled - to improve the conditioning of its eigenvalues as follows: - = 'N': Do not diagonally scale; - = 'S': Diagonally scale the matrix, i.e. replace A by - D*A*D**(-1), where D is a diagonal matrix chosen - to make the rows and columns of A more equal in - norm. Do not permute. + Parameters + ---------- + A : (n, n) array_like + Square matrix + delta : float + The scalar value delta of the problem. + balanc : {'N', 'S'}, optional + Indicates how the input matrix should be diagonally scaled + to improve the conditioning of its eigenvalues as follows: + + := 'N': Do not diagonally scale; + := 'S': Diagonally scale the matrix, i.e. replace `A` by + ``D*A*D**(-1)``, where `D` is a diagonal matrix chosen + to make the rows and columns of A more equal in + norm. Do not permute. - Return objects: - Ar : output rank-2 array('d') with bounds (n,n) - Contains the solution matrix exp(A*delta) - Vr : output rank-2 array('d') with bounds (n,n) - Contains the eigenvector matrix for A. If the k-th - eigenvalue is real the k-th column of the eigenvector - matrix holds the eigenvector corresponding to the k-th - eigenvalue. Otherwise, the k-th and (k+1)-th eigenvalues - form a complex conjugate pair and the k-th and (k+1)-th - columns of the eigenvector matrix hold the real and - imaginary parts of the eigenvectors corresponding to these - eigenvalues as follows. If p and q denote the k-th and - (k+1)-th columns of the eigenvector matrix, respectively, - then the eigenvector corresponding to the complex - eigenvalue with positive (negative) imaginary value is - given by - p + q*j (p - q*j), where j^2 = -1. - Yr : output rank-2 array('d') with bounds (n,n) - contains an intermediate result for computing the matrix - exponential. Specifically, exp(A*delta) is obtained as the - product V*Y, where V is the matrix stored in the leading - N-by-N part of the array V. If all eigenvalues of A are - real, then the leading N-by-N part of this array contains - the matrix product exp(Lambda*delta) times the inverse of - the (right) eigenvector matrix of A, where Lambda is the - diagonal matrix of eigenvalues. - - VAL : output rank-1 array('c') with bounds (n) - Contains the eigenvalues of the matrix A. The eigenvalues - are unordered except that complex conjugate pairs of values - appear consecutively with the eigenvalue having positive - imaginary part first. + Returns + ------- + Ar : (n, n) ndarray + Contains the solution matrix ``exp(A*delta)`` + Vr : (n, n) ndarray + Contains the eigenvector matrix for `A`. If the `k`-th + eigenvalue is real the `k`-th column of the eigenvector + matrix holds the eigenvector corresponding to the `k`-th + eigenvalue. Otherwise, the `k`-th and `(k+1)`-th eigenvalues + form a complex conjugate pair and the k-th and `(k+1)`-th + columns of the eigenvector matrix hold the real and + imaginary parts of the eigenvectors corresponding to these + eigenvalues as follows. If `p` and `q` denote the `k`-th and + `(k+1)`-th columns of the eigenvector matrix, respectively, + then the eigenvector corresponding to the complex + eigenvalue with positive (negative) imaginary value is + given by + ``p + q*j (p - q*j), where j^2 = -1.`` + Yr : (n, n) ndarray + contains an intermediate result for computing the matrix + exponential. Specifically, ``exp(A*delta)`` is obtained as the + product ``V*Y``, where `V` is the matrix stored in the leading + `n`-by-`n` part of the array `V`. If all eigenvalues of `A` are + real, then the leading `n`-by-`n` part of this array contains + the matrix product ``exp(Lambda*delta)`` times the inverse of + the (right) eigenvector matrix of `A`, where `Lambda` is the + diagonal matrix of eigenvalues. + + VAL : (n,) real or complex ndarray + Contains the eigenvalues of the matrix `A`. The eigenvalues + are unordered except that complex conjugate pairs of values + appear consecutively with the eigenvalue having positive + imaginary part first. + + Warns + ------ + SlycotResultWarning : e + :0 < e.info <=n: + the QR algorithm failed to compute all + the eigenvalues; no eigenvectors have been computed; + w[{e.info:n}] contains eigenvalues which have converged; + :e.info == n+1: + The inverse of the eigenvector matrix could not + be formed due to an attempt to divide by zero, i.e., + the eigenvector matrix is singular; + :e.info == n+2: + Matrix A is defective, possibly due to rounding errors. """ hidden = ' (hidden by the wrapper)' arg_list = ['balanc', 'n', 'delta', 'a', 'lda'+hidden, 'v', 'ldv'+hidden, @@ -647,17 +662,9 @@ def mb05md(a, delta, balanc='N'): delta=delta, a=a) - raise_if_slycot_error(INFO, arg_list) - - if INFO > 0 and INFO <= n: - raise SlycotArithmeticError("Incomplete eigenvalue calculation, " - "missing {} eigenvalues".format(INFO), - INFO) - elif INFO == n+1: - raise SlycotArithmeticError("Eigenvector matrix singular", INFO) - elif INFO == n+2: - raise SlycotArithmeticError("Matrix A is defective, " - "possibly due to rounding errors.", INFO) + raise_if_slycot_error(INFO, arg_list, + docstring=mb05md.__doc__, checkvars=locals()) + if not all(VALi == 0): VAL = VALr + 1J*VALi else: diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 1d488f06..a913ace6 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -437,17 +437,16 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = i: - if the i-th element (1 <= i <= m) of the d factor is - exactly zero; the UdU' (or LdL') factorization has - been completed, but the block diagonal matrix d is - exactly singular; - :e.info = m+1: - if the matrix R is numerically singular. + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :1 <= e.info <= m: + The {e.info}-th element of the `d` factor is + exactly zero; the ``UdU' (or LdL')`` factorization has + been completed, but the block diagonal matrix d is + exactly singular; + :e.info = m+1: + The matrix R is numerically singular. """ hidden = ' (hidden by the wrapper)' arg_list = ['JOBG'+hidden, 'jobl', 'fact', 'uplo', 'n', 'm', 'A', @@ -474,14 +473,7 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): out = _wrapper.sb02mt_nl(n,m,A,B,Q,R,L,uplo=uplo,ldwork=ldwork) if out is None: raise SlycotParameterError('fact must be either C or N.', -3) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0 and out[-1] <= m: - raise SlycotArithmeticError('the {}-th element of d in the UdU (LdL) ' - 'factorization is zero.'.format(out[-1]), - out[-1]) - if out[-1] == m+1: - raise SlycotArithmeticError('matrix R is numerically singular.', - out[-1]) + raise_if_slycot_error(out[-1], arg_list, sb02mt.__doc__, locals()) return out[:-1] def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldwork=None): @@ -776,25 +768,28 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info > 0: - if info = i, the QR algorithm failed to compute all - the eigenvalues (see LAPACK Library routine DGEES); - elements i+1:n of w contain eigenvalues which have converged, - and A contains the partially converged Schur form; - :e.info = N+1: - if dico = 'C', and the matrices A and -A' have - common or very close eigenvalues, or - if dico = 'D', and matrix A has almost reciprocal - eigenvalues (that is, lambda(i) = 1/lambda(j) for - some i and j, where lambda(i) and lambda(j) are - eigenvalues of A and i <> j); perturbed values were - used to solve the equation (but the matrix A is - unchanged). + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + + Warns + ----- + SlycotResultWarning : e + :0 < e.info <=n: + The QR algorithm failed to compute all + the eigenvalues (see LAPACK Library routine DGEES); + w[{e.info}:{n}] contains eigenvalues which have converged, + and A contains the partially converged Shur form + :e.info == n+1 and dico == 'C': + The matrices `A` and `-A'` have common or very close eigenvalues + :e.info == n+1 and dico == 'D': + Matrix A has almost reciprocal eigenvalues + (that is, `'lambda(i) = 1/lambda(j)`` for + some `i` and `j`, where ``lambda(i)`` and ``lambda(j)`` are + eigenvalues of `A` and ``i != j``); perturbed values were + used to solve the equation (but the matrix A is unchanged). """ + + hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'job', 'fact', 'trana', 'n', 'A', 'LDA'+hidden, 'U', 'LDU'+hidden, 'C', 'LDC'+hidden, 'scale', 'sep', 'ferr', 'wr'+hidden, @@ -804,21 +799,7 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] == n+1: - if dico == 'D': - error_text = 'The matrix A has eigenvalues that are almost reciprocal.' - else: - error_text = 'The matrix A and -A have common or very close eigenvalues.' - raise SlycotArithmeticError(error_text, out[-1]) - else: - if out[-1] > 0: - raise SlycotArithmeticError( - "The QR algorithm failed to compute all the eigenvalues " - "(see LAPACK Library routine DGEES); elements {}:{} of w " - "contains eigenvalues which have converged, A contains the " - "partially converged Shur form".format(out[-1],n), - out[-1]) + raise_if_slycot_error(out[-1], arg_list, sb03md.__doc__, locals()) X,scale,sep,ferr,wr,wi = out[:-1] w = _np.zeros(n,'complex64') w.real = wr[0:n] diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index af46312b..cdf3d65f 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -4,6 +4,7 @@ set(PYSOURCE test_ab08n.py test_ag08bd.py test_examples.py + test_exceptions.py test_mb.py test_mc.py test_sb.py @@ -12,8 +13,7 @@ set(PYSOURCE test_tb05ad.py test_td04ad.py test_tg01ad.py - test_tg01fd.py - docstring_check.py ) + test_tg01fd.py ) install(FILES ${PYSOURCE} PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE diff --git a/slycot/tests/docstring_check.py b/slycot/tests/test_exceptions.py similarity index 53% rename from slycot/tests/docstring_check.py rename to slycot/tests/test_exceptions.py index 17376a5e..56f62eb7 100644 --- a/slycot/tests/docstring_check.py +++ b/slycot/tests/test_exceptions.py @@ -17,10 +17,14 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. """ -from numpy.testing import assert_raises -from slycot.exceptions import SlycotError, raise_if_slycot_error -def assert_docstring_parse(docstring, erange, checkvars={}): +import pytest + +from slycot.exceptions import raise_if_slycot_error, \ + SlycotError, SlycotWarning, SlycotParameterError + + +def assert_docstring_parse(docstring, exception_class, erange, checkvars={}): """To check that a docstring can be parsed into exceptions See also raise_if_slycot_error @@ -28,6 +32,8 @@ def assert_docstring_parse(docstring, erange, checkvars={}): ---------- docstring: str Documentation string with exception definitions + exception_class: SlycotError or SlycotWarning + Subclass of Slycot specific Errors or Warnings expected to raise erange: int or iterable with int Error numbers for which the documentation should have exception text @@ -38,10 +44,25 @@ def assert_docstring_parse(docstring, erange, checkvars={}): # if erange is a simple integer, assume a continous range of errors try: - erange = range(1,erange+1) + erange = range(1, erange+1) except TypeError: pass for info in erange: - assert_raises(SlycotError, raise_if_slycot_error, info, [], - docstring, checkvars) + if issubclass(exception_class, SlycotError): + with pytest.raises(exception_class) as ex_info: + raise_if_slycot_error(info, [], docstring, checkvars) + assert ex_info.value.info == info + elif issubclass(exception_class, SlycotWarning): + with pytest.warns(exception_class) as wm: + raise_if_slycot_error(info, [], docstring, checkvars) + assert wm[0].message.info == info + else: + raise RuntimeError("Invalid test exception") + + +def test_standard_info_error(): + """Test the standard case of illegal arguments""" + with pytest.raises(SlycotParameterError) as ex_info: + raise_if_slycot_error(-2, ["a", "b"]) + assert ex_info.value.info == -2 diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index 4ea494a6..34ff79a1 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -3,11 +3,14 @@ # test_mb.py - test suite for linear algebra commands # bnavigator , Aug 2019 +import sys import unittest -import numpy as np -from scipy.linalg import schur from slycot import mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd +from slycot.exceptions import SlycotResultWarning + +import numpy as np +from scipy.linalg import schur from numpy.testing import assert_allclose @@ -259,6 +262,23 @@ def test_mb05md(self): assert_allclose(np.dot(Vr, Yr), np.dot(Vr_ref, Yr_ref), atol=0.0001) + # TODO: move this to pytest recwarn together with the whole class + @unittest.skipIf(sys.version < "3", "no assertWarns in old Python") + def test_mb05md_warning(self): + """ Check that the correct warning is raised from docstring""" + A = np.array([[5, 4, 2, 1], + [0, 1, -1, -1], + [-1, -1, 3, 0], + [1, 1, -1, 2]]) + delta = 0. + + with self.assertWarns(SlycotResultWarning, + msg="\n" + "Matrix A is defective, possibly " + "due to rounding errors.") as cm: + (Ar, Vr, Yr, VAL) = mb05md(A, delta) + assert cm.warning.info == 6 + def test_mb05nd(self): """ test_mb05nd: verify Matrix exponential and integral data from http://slicot.org/objects/software/shared/doc/MB05ND.html diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 7e4989ea..0e33c873 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -2,13 +2,14 @@ # sb* synthesis tests from slycot import synthesis -from slycot.exceptions import raise_if_slycot_error, SlycotError, \ - SlycotParameterError, SlycotArithmeticError +from slycot.exceptions import raise_if_slycot_error, \ + SlycotParameterError, SlycotArithmeticError, \ + SlycotResultWarning from numpy import array, eye, zeros from numpy.testing import assert_allclose, assert_raises import pytest -from .docstring_check import assert_docstring_parse +from .test_exceptions import assert_docstring_parse def test_sb02mt(): """Test if sb02mt is callable @@ -104,29 +105,21 @@ def test_sb10jd(): @pytest.mark.parametrize( - 'fun, info, exception, checkvars', - [(synthesis.sb01bd, -1, SlycotParameterError, {}), - (synthesis.sb01bd, 1, SlycotArithmeticError, {}), - (synthesis.sb01bd, 2, SlycotArithmeticError, {}), ]) -def test_sb_exceptionstrings(fun, info, exception, checkvars): - assert_raises(exception, raise_if_slycot_error, info, arg_list=["a", "b"], - docstring=fun.__doc__, checkvars=checkvars) - -@pytest.mark.parametrize( - 'fun, erange, checkvars', - ( ( synthesis.sb01bd, 4, {} ), - ( synthesis.sb02md, 5, {} ), - ( synthesis.sb02od, 6, {} ), - ( synthesis.sb03md, 3, { 'N': 2} ), - ( synthesis.sb03od, 6, {} ), - ( synthesis.sb04md, 2, { 'm': 1} ), - ( synthesis.sb04qd, 3, { 'm': 2} ), - ( synthesis.sb10ad, 12, {} ), - ( synthesis.sb10dd, 9, {} ), - ( synthesis.sb10hd, 4, {} ), - ( synthesis.sb10jd, 0, {} ), - ( synthesis.sg03ad, 4, {} ), - ( synthesis.sg02ad, 7, {} ), - ( synthesis.sg03bd, 7, {} ) ) ) -def test_sb_docparse(fun, erange, checkvars): - assert_docstring_parse(fun.__doc__, erange, checkvars) + 'fun, exception_class, erange, checkvars', + ( ( synthesis.sb01bd, SlycotArithmeticError, 4, {} ), + ( synthesis.sb02md, SlycotArithmeticError, 5, {} ), + ( synthesis.sb02od, SlycotArithmeticError, 6, {} ), + ( synthesis.sb03md, SlycotResultWarning, 3, { 'n': 2, 'dico': 'D'} ), + ( synthesis.sb03md, SlycotResultWarning, 3, { 'n': 2, 'dico': 'C'} ), + ( synthesis.sb03od, SlycotArithmeticError, 6, {} ), + ( synthesis.sb04md, SlycotArithmeticError, 2, { 'm': 1} ), + ( synthesis.sb04qd, SlycotArithmeticError, 3, { 'm': 2} ), + ( synthesis.sb10ad, SlycotArithmeticError, 12, {} ), + ( synthesis.sb10dd, SlycotArithmeticError, 9, {} ), + ( synthesis.sb10hd, SlycotArithmeticError, 4, {} ), + ( synthesis.sb10jd, SlycotArithmeticError, 0, {} ), + ( synthesis.sg03ad, SlycotArithmeticError, 4, {} ), + ( synthesis.sg02ad, SlycotArithmeticError, 7, {} ), + ( synthesis.sg03bd, SlycotArithmeticError, 7, {} ) ) ) +def test_sb_docparse(fun, exception_class, erange, checkvars): + assert_docstring_parse(fun.__doc__, exception_class, erange, checkvars) From 0e8d63c8b1a17c3c419ad897f6b1ecbeacb88234 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 May 2020 18:30:24 +0200 Subject: [PATCH 178/405] update exceptions doc and test [skip ci] --- slycot/exceptions.py | 47 ++++++++++++++++++++------------- slycot/tests/test_exceptions.py | 20 +++++++------- 2 files changed, 39 insertions(+), 28 deletions(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index e9968220..01ad59c8 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -152,26 +152,25 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): multiple definition terms ``SlycotError : e`` or a subclass of it, the matching exception text is used. + To raise warnings, define a "Warns" section using a ``SlycotWarning : e`` + definition or a subclass of it. + The definition body must contain a reST compliant field list with '::' as field name, where specifies the valid values for `e.ìnfo` in a python parseable expression using the variables provided in `checkvars`. A single " = " is treated as " == ". - The body of the field list contains the exception message and can contain - replacement fields in format string syntax using the variables in - `checkvars`. + The body of the field list contains the exception or warning message and + can contain replacement fields in format string syntax using the variables + in `checkvars`. For negative info, the argument as indicated in arg_list was erroneous and - a generic SlycotParameterError is raised if no custom text was defined in - the docstring or no docstring is provided. - - To rase warnings, define a "Warns" section similarly formatted as "Raises" - using the ``SlycotResultWarning : e`` definition name. + a generic SlycotParameterError is raised if matching infospec was defined. Example ------- >>> def fun(info): - ... \"""Example function + ... '''Example function ... ... Raises ... ------ @@ -180,9 +179,14 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): ... :e.info > 1 and e.info < n: ... Info is {e.info}, which is between 1 and {n} ... :n <= e.info < m: - ... {e.info} is between {n} and {m:10.2g}! - ... \""" - ... n, m = 4, 1.2e2 + ... {e.info} is in [{n}, {m:10.2g})! + ... + ... Warns + ... ----- + ... SlycotResultWarning : e + ... :e.info >= 120: {e.info} is too large + ... ''' + ... n, m = 4, 120. ... raise_if_slycot_error(info, ... arg_list=["a", "b", "c"], ... docstring=fun.__doc__, @@ -190,13 +194,20 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): ... >>> fun(0) >>> fun(-1) - SlycotParameterError: The following argument had an illegal value: a + SlycotParameterError: + The following argument had an illegal value: a >>> fun(1) - SlycotArithmeticError: Info is 1 + SlycotArithmeticError: + Info is 1 >>> fun(2) - SlycotArithmeticError: Info is 2, which is between 1 and 4 - >>> fun(5) - SlycotArithmeticError: 4 is between 4 and 1.2e+02! + SlycotArithmeticError: + Info is 2, which is between 1 and 4 + >>> fun(4) + SlycotArithmeticError: + 4 is in [4, 1.2e+02)! + >>> fun(120) + SlycotResultWarning: + 120 is too large """ if docstring: checkvars['e'] = SlycotError("", info) @@ -208,7 +219,7 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): warning, message = _parse_docsection("Warns", docstring, checkvars) if warning and message: - fmessage = message.format(**checkvars).strip() + fmessage = '\n' + message.format(**checkvars).strip() warn(globals()[warning](fmessage, info)) if info < 0 and arg_list: diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 56f62eb7..8cb7ee13 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -30,16 +30,16 @@ def assert_docstring_parse(docstring, exception_class, erange, checkvars={}): Parameters ---------- - docstring: str - Documentation string with exception definitions - exception_class: SlycotError or SlycotWarning - Subclass of Slycot specific Errors or Warnings expected to raise - erange: int or iterable with int - Error numbers for which the documentation should have - exception text - checkvars: dict, optional - dict of variables for evaluation of and formatting the - exception message + docstring: str + Documentation string with exception definitions + exception_class: SlycotError or SlycotWarning + Subclass of Slycot specific Errors or Warnings expected to raise + erange: int or iterable with int + Error numbers for which the documentation should have + exception text + checkvars: dict, optional + dict of variables for evaluation of and formatting the + exception message """ # if erange is a simple integer, assume a continous range of errors From 7ad151734e9f0720fa7d7e5c84b786f832d31122 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 03:39:46 +0200 Subject: [PATCH 179/405] more work on exception and warning handling - reintroduce catch all - syntax change: parse variables info and iwarn directly instead of e.info - SlycotWarning as also an iwarn attribute - update all the docstrings of functions that use the Raises and Warns sections - clean functions - update tests --- slycot/analysis.py | 619 +++++++++++----------- slycot/exceptions.py | 70 ++- slycot/math.py | 175 ++++--- slycot/synthesis.py | 900 +++++++++++++++----------------- slycot/tests/test_exceptions.py | 24 +- slycot/tests/test_mc.py | 15 +- slycot/tests/test_sb.py | 44 +- slycot/tests/test_tb05ad.py | 15 +- slycot/transform.py | 335 ++++++------ 9 files changed, 1077 insertions(+), 1120 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index fd733de1..2378a9d8 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -117,25 +117,23 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): hidden = ' (hidden by the wrapper)' arg_list = ['jobz', 'n', 'm', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, - 'ncont', 'indcon', 'nblk', 'Z', 'LDZ'+hidden, 'tau', 'tol', - 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'info'+hidden] + 'ncont', 'indcon', 'nblk', 'Z', 'LDZ'+hidden, 'tau', 'tol', + 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'info'+hidden] + + wrappermap = {"N": _wrapper.ab01nd_n, + "I": _wrapper.ab01nd_i, + "F": _wrapper.ab01nd_f} + if ldwork is None: - ldwork = max(n,3*m) - if jobz == 'N': - out = _wrapper.ab01nd_n(n,m,A,B,tol=tol,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - # sets Z to None + ldwork = max(n, 3*m) + + out = wrappermap[jobz](n, m, A, B, tol=tol, ldwork=ldwork) + raise_if_slycot_error(out[-1], arg_list) + # sets Z to None + if jobz == "N": out[5] = None - return out[:-1] - if jobz == 'I': - out = _wrapper.ab01nd_i(n,m,A,B,tol=tol,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - return out[:-1] - if jobz == 'F': - out = _wrapper.ab01nd_f(n,m,A,B,tol=tol,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - return out[:-1] - raise SlycotParameterError('jobz must be either N, I or F', -1) + return out[:-1] + def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): """ n,a,b,c,d = ab05md(n1,m1,p1,n2,p2,a1,b1,c1,d1,a2,b2,c2,d2,[uplo]) @@ -289,6 +287,16 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): D : rank-2 array('d') with bounds (p1,m1) The leading p1-by-m1 part of this array contains the input/output matrix D for the connected system. + + Raises + ------ + SlycotArithmeticError + :1 <= info <= p1: + the system is not completely controllable. That is, the matrix + ``(I + ALPHA*D1*D2)`` is exactly singular (the element + ``U(i,i)```` of the upper triangular factor of ``LU``` + factorization is exactly zero), possibly due to + rounding errors. """ hidden = ' (hidden by the wrapper)' arg_list = ['over'+hidden, 'n1', 'm1', 'p1', 'n2', 'alpha', 'A1', 'LDA1'+hidden, @@ -300,11 +308,7 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): if ldwork is None: ldwork = max(p1*p1,m1*m1,n1*p1) out = _wrapper.ab05nd(n1,m1,p1,n2,alpha,A1,B1,C1,D1,A2,B2,C2,D2,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0: - raise SlycotArithmeticError( - 'The resulting system is not completely controllable.', - out[-1]) + raise_if_slycot_error(out[-1], arg_list, ab05nd, locals()) return out[:-1] def ab07nd(n,m,A,B,C,D,ldwork=None): @@ -349,26 +353,31 @@ def ab07nd(n,m,A,B,C,D,ldwork=None): rcond : float The estimated reciprocal condition number of the feedthrough matrix D of the original system. + + Warns + ----- + SlycotResultWarning + :1 <= info <= m: + the matrix `D` is exactly singular; the ({info},{info}) + diagonal element is zero, `RCOND` was set to zero; + :info == m+1: + the matrix `D` is numerically singular, i.e., `RCOND` + is less than the relative machine precision, `EPS` + (see LAPACK Library routine DLAMCH). The + calculations have been completed, but the results + could be very inaccurate. """ hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'm', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', - 'LDC'+hidden, 'D', 'LDD'+hidden, 'rcond', 'IWORK'+hidden, 'DWORK'+hidden, - 'ldwork', 'INFO'+hidden] + arg_list = ['n', 'm', 'A', 'LDA' + hidden, 'B', 'LDB' + hidden, + 'C', 'LDC' + hidden, 'D', 'LDD' + hidden, 'rcond', + 'IWORK' + hidden, 'DWORK' + hidden, 'ldwork', 'INFO' + hidden] if ldwork is None: - ldwork = max(1,4*m) - out = _wrapper.ab07nd(n,m,A,B,C,D,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] == m+1: - raise SlycotArithmeticError( - 'Entry matrix D is numerically singular.', - out[-1]) - if out[-1] > 0: - raise SlycotArithmeticError( - 'Entry matrix D is exactly singular, the ({0:},{0:}) diagonal ' - 'element is zero.'.format(out[-1]), - out[-1]) + ldwork = max(1, 4*m) + out = _wrapper.ab07nd(n, m, A, B, C, D, ldwork=ldwork) + raise_if_slycot_error(out[-1], arg_list, ab07nd.__doc__, locals()) return out[:-1] + def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): """ nu,rank,dinfz,nkror,nkrol,infz,kronr,kronl,Af,Bf = ab08nd(n,m,p,A,B,C,D,[equil,tol,ldwork]) @@ -642,44 +651,44 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The reduction of A to the real Schur form failed - :e.info = 2: - The state matrix A is not stable or not convergent - :e.info = 3: - The computation of Hankel singular values failed + SlycotArithmeticError + :info == 1: + The reduction of A to the real Schur form failed + :info == 2 and dico == 'C': + The state matrix A is not stable + :info == 2 and dico == 'D': + The state matrix A is not convergent + :info == 3: + The computation of Hankel singular values failed + + Warns + ----- + SlycotResultWarning + :iwarn == 1: + The selected order {nr} is greater + than the order of a minimal realization of the + given system. `nr` was set automatically to {Nr} + corresponding to the order of a minimal realization + of the system """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'A', - 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'hsv', 'tol', - 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] + arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', + 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, + 'hsv', 'tol', 'iwork' + hidden, 'dwork ' + hidden, 'ldwork', + 'iwarn', 'info'] if ldwork is None: - ldwork = max(1,n*(2*n+max(n,max(m,p))+5)+n*(n+1)/2) + ldwork = max(1, n*(2*n+max(n, max(m, p))+5)+n*(n+1)/2) if nr is None: ordsel = 'A' - nr = 0 #order will be computed by the routine + nr = 0 # order will be computed by the routine else: ordsel = 'F' - if dico != 'C' and dico != 'D': - raise SlycotParameterError('Parameter dico had an illegal value', -1) - if job != 'B' and job != 'N': - raise SlycotParameterError('Parameter job had an illegal value', -2) - if equil != 'S' and equil != 'N': - raise SlycotParameterError('Parameter equil had an illegal value', -3) - out = _wrapper.ab09ad(dico,job,equil,ordsel,n,m,p,nr,A,B,C,tol,ldwork) - if out[-2] == 1: - warnings.warn("The selected order nr is greater\ - than the order of a minimal realization of the\ - given system. It was set automatically to a value\ - corresponding to the order of a minimal realization\ - of the system") - raise_if_slycot_error(out[-1], arg_list, ab09ad.__doc__) - Nr,A,B,C,hsv = out[:-2] - return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], hsv + out = _wrapper.ab09ad(dico, job, equil, ordsel, + n, m, p, nr, A, B, C, tol, ldwork) + Nr, A, B, C, hsv = out[:-2] + raise_if_slycot_error(out[-2:], arg_list, ab09ad.__doc__, locals()) + return Nr, A[:Nr, :Nr], B[:Nr, :], C[:, :Nr], hsv + def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): """``nr,Ar,Br,Cr,hsv,T,Ti = ab09ad(dico,job,equil,n,m,p,nr,A,B,C,[nr,tol,ldwork])`` @@ -772,42 +781,40 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The state matrix A is not stable or not convergent - :e.info = 2: - The computation of Hankel singular values failed + SlycotArithmeticError + :info == 1 and dico == 'C': + The state matrix A is not stable + :info == 1 and dico == 'D': + The state matrix A is not convergent + :info == 2: + The computation of Hankel singular values failed + + Warns + ----- + SlycotResultWarning + :iwarn == 1: + The selected order {nr} is greater + than the order of a minimal realization of the + given system. `nr` was set automatically to {Nr} + corresponding to the order of a minimal realization + of the system """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'job', 'ordsel', 'n', 'm', 'p', 'nr', 'A', - 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'hsv', 'T', - 'ldt'+hidden, 'Ti', 'ldti'+hidden, 'tol', 'iwork'+hidden, - 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] + arg_list = ['dico', 'job', 'ordsel', 'n', 'm', 'p', 'nr', + 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, + 'hsv', 'T', 'ldt' + hidden, 'Ti', 'ldti' + hidden, 'tol', + 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] if ldwork is None: - ldwork = max(1,n*(2*n+max(n,max(m,p))+5)+n*(n+1)/2) + ldwork = max(1, n*(2*n + max(n, max(m, p))+5)+n*(n+1)/2) if nr is None: ordsel = 'A' - nr = 0 #order will be computed by the routine + nr = 0 # order will be computed by the routine else: ordsel = 'F' - if dico != 'C' and dico != 'D': - raise SlycotParameterError('Parameter dico had an illegal value', -1) - if job != 'B' and job != 'N': - raise SlycotParameterError('Parameter job had an illegal value', -2) - out = _wrapper.ab09ax(dico,job,ordsel,n,m,p,nr,A,B,C,tol,ldwork) - if out[-2] == 1: - warnings.warn("The selected order nr is greater\ - than the order of a minimal realization of the\ - given system. It was set automatically to a value\ - corresponding to the order of a minimal realization\ - of the system") - raise_if_slycot_error(out[-1], arg_list, ab09ax.__doc__) - - nr,A,B,C,hsv,T,Ti = out[:-2] - return nr, A[:nr,:nr], B[:nr,:], C[:,:nr], hsv, T[:,:nr], Ti[:nr,:] + out = _wrapper.ab09ax(dico, job, ordsel, n, m, p, nr, A, B, C, tol, ldwork) + Nr, A, B, C, hsv, T, Ti = out[:-2] + raise_if_slycot_error(out[-2:], arg_list, ab09ax.__doc__, locals()) + return Nr, A[:Nr, :Nr], B[:Nr, :], C[:, :Nr], hsv, T[:, :Nr], Ti[:Nr, :] def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): """ nr,Ar,Br,Cr,Dr,hsv = ab09bd(dico,job,equil,n,m,p,A,B,C,D,[nr,tol1,tol2,ldwork]) @@ -915,46 +922,44 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The reduction of A to the real Schur form failed - :e.info = 2: - The state matrix A is not stable (if dico = C) ' - 'or not convergent (if dico = D) - :e.info = 3: - The computation of Hankel singular values failed + SlycotArithmeticError : e + :info == 1: + The reduction of A to the real Schur form failed + :info == 2 and dico == 'C': + The state matrix A is not stable + :info == 2 and dico == 'D': + The state matrix A is not convergent + :info == 3: + The computation of Hankel singular values failed + + Warns + ----- + SlycotResultWarning : e + :iwarn == 1: + The selected order {nr} is greater + than the order of a minimal realization of the + given system. `nr` was set automatically to {Nr} + corresponding to the order of a minimal realization + of the system """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'A', - 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'hsv', 'tol1', 'tol2', - 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] + arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', + 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, + 'D', 'ldd' + hidden, 'hsv', 'tol1', 'tol2', + 'iwork' + hidden, 'dwork' + hidden, 'ldwork', 'iwarn', 'info'] if ldwork is None: - ldwork = max(1,n*(2*n+max(n,max(m,p))+5)+n*(n+1)/2) + ldwork = max(1, n*(2*n+max(n, max(m, p))+5)+n*(n+1)/2) if nr is None: ordsel = 'A' - nr = 0 #order will be computed by the routine + nr = 0 # order will be computed by the routine else: ordsel = 'F' - if dico != 'C' and dico != 'D': - raise SlycotParameterError('Parameter dico had an illegal value', -1) - if job != 'B' and job != 'N': - raise SlycotParameterError('Parameter job had an illegal value', -2) - if equil != 'S' and equil != 'N': - raise SlycotParameterError('Parameter equil had an illegal value', -3) - out = _wrapper.ab09bd(dico,job,equil,ordsel,n,m,p,nr,A,B,C,D,tol1,tol2,ldwork) - if out[-2] == 1: - warnings.warn("The selected order nr is greater\ - than the order of a minimal realization of the\ - given system. It was set automatically to a value\ - corresponding to the order of a minimal realization\ - of the system") - raise_if_slycot_error(out[-1], arg_list, ab09bd.__doc__) - Nr,A,B,C,D,hsv = out[:-2] - return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr],D[:,:], hsv + out = _wrapper.ab09bd(dico, job, equil, ordsel, + n, m, p, nr, A, B, C, D, tol1, tol2, ldwork) + Nr, A, B, C, D, hsv = out[:-2] + raise_if_slycot_error(out[-2:], arg_list, ab09bd.__doc__, locals()) + return Nr, A[:Nr, :Nr], B[:Nr, :], C[ :,:Nr], D[:, :], hsv def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): """ nr,Ar,Br,Cr,ns,hsv = ab09md(dico,job,equil,n,m,p,A,B,C,[alpha,nr,tol,ldwork]) @@ -1080,57 +1085,49 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The reduction of A to the real Schur form failed - :e.info = 2: - The separation of the alpha-stable/unstable diagonal - blocks failed because of very close eigenvalues - :e.info = 3: - The computation of Hankel singular values failed + SlycotArithmeticError : e + :info == 1: + The computation of the ordered real Schur form of A failed + :info == 2: + The separation of the {alpha}-stable/unstable diagonal + blocks failed because of very close eigenvalues + :info == 3: + The computation of Hankel singular values failed + + Warns + ----- + SlycotResultWarning : e + :iwarn == 1: + The selected order {nr} is greater + than `nsmin`, the sum of the order of the + {alpha}-unstable part and the order of a minimal + realization of the {alpha}-stable part of the given + system. The resulting `nr` is set to `nsmin` = {Nr} + :iwarn == 2: + The selected order {nr} is less + than the order of the {alpha}-unstable part of the + given system. In this case `nr` is set equal to the + order of the {alpha}-unstable part {Nr}. """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'alpha', 'A', - 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'ns', 'hsv', 'tol1', 'tol2', - 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] + arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'alpha', + 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, + 'ns', 'hsv', 'tol', + 'iwork' + hidden, 'dwork' + hidden, 'ldwork', 'iwarn', 'info'] if ldwork is None: - ldwork = max(1,n*(2*n+max(n,max(m,p))+5)+n*(n+1)/2) + ldwork = max(1, n*(2*n+max(n, max(m, p))+5)+n*(n+1)/2) if nr is None: ordsel = 'A' - nr = 0 #order will be computed by the routine + nr = 0 # order will be computed by the routine else: ordsel = 'F' - if dico != 'C' and dico != 'D': - raise SlycotParameterError('Parameter dico had an illegal value', -1) if alpha is None: - if dico == 'C': - alpha = 0. - elif dico == 'D': - alpha = 1. - if job != 'B' and job != 'N': - raise SlycotParameterError('Parameter job had an illegal value', -2) - if equil != 'S' and equil != 'N': - raise SlycotParameterError('Parameter equil had an illegal value', -3) - out = _wrapper.ab09md(dico,job,equil,ordsel,n,m,p,nr,alpha,A,B,C,tol,ldwork) - if out[-2] == 1: - warnings.warn("with ordsel = 'F', the selected order nr is greater\ - than nsmin, the sum of the order of the\ - alpha-unstable part and the order of a minimal\ - realization of the alpha-stable part of the given\ - system. In this case, the resulting nr is set equal\ - to nsmin.") - if out[-2] == 2: - warnings.warn("with ordsel = 'F', the selected order nr is less\ - than the order of the alpha-unstable part of the\ - given system. In this case nr is set equal to the\ - order of the alpha-unstable part.") - - raise_if_slycot_error(out[-1], arg_list, ab09md.__doc__) - Nr,A,B,C,Ns,hsv = out[:-2] - return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], Ns, hsv + alpha = {'C': 0, 'D': 1.}[dico] + out = _wrapper.ab09md(dico, job, equil, ordsel, + n, m, p, nr, alpha, A, B, C, tol, ldwork) + Nr, A, B, C, Ns, hsv = out[:-2] + raise_if_slycot_error(out[-2:], arg_list, ab09md.__doc__, locals()) + return Nr, A[:Nr, :Nr], B[:Nr, :], C[:, :Nr], Ns, hsv def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork=None): """ nr,Ar,Br,Cr,Dr,ns,hsv = ab09nd(dico,job,equil,n,m,p,A,B,C,D,[alpha,nr,tol1,tol2,ldwork]) @@ -1250,60 +1247,53 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= the original system ordered decreasingly. hsv(1) is the Hankel norm of the system. + Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The reduction of A to the real Schur form failed - :e.info = 2: - The state matrix A is not stable (if dico = C) ' - 'or not convergent (if dico = D) - :e.info = 3: - The computation of Hankel singular values failed + SlycotArithmeticError + :info == 1: + The computation of the ordered real Schur form of A failed + :info == 2: + The separation of the {alpha}-stable/unstable diagonal + blocks failed because of very close eigenvalues + :info == 3: + The computation of Hankel singular values failed + + Warns + ----- + SlycotResultWarning + :iwarn == 1: + The selected order {nr} is greater + than `nsmin`, the sum of the order of the + {alpha}-unstable part and the order of a minimal + realization of the {alpha}-stable part of the given + system. The resulting `nr` is set to `nsmin` = {Nr} + :iwarn == 2: + The selected order {nr} is less + than the order of the {alpha}-unstable part of the + given system. In this case `nr` is set equal to the + order of the {alpha}-unstable part {Nr}. """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'alpha', 'A', - 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'ns', 'hsv', 'tol1', 'tol2', - 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] + arg_list = ['dico', 'job', 'equil', 'ordsel', 'n', 'm', 'p', 'nr', 'alpha', + 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, + 'D', 'ldc' + hidden, 'ns', 'hsv', 'tol1', 'tol2', + 'iwork' + hidden, 'dwork' + hidden, 'ldwork', 'iwarn', 'info'] if ldwork is None: - ldwork = max(1,n*(2*n+max(n,max(m,p))+5)+n*(n+1)/2) + ldwork = max(1, n*(2*n+max(n, max(m, p))+5)+n*(n+1)/2) if nr is None: ordsel = 'A' - nr = 0 #order will be computed by the routine + nr = 0 # order will be computed by the routine else: ordsel = 'F' - if dico != 'C' and dico != 'D': - raise SlycotParameterError('Parameter dico had an illegal value', -1) if alpha is None: - if dico == 'C': - alpha = 0. - elif dico == 'D': - alpha = 1. - if job != 'B' and job != 'N': - raise SlycotParameterError('Parameter job had an illegal value', -2) - if equil != 'S' and equil != 'N': - raise SlycotParameterError('Parameter equil had an illegal value', -3) - out = _wrapper.ab09nd(dico,job,equil,ordsel,n,m,p,nr,alpha,A,B,C,D,tol1,tol2,ldwork) - if out[-2] == 1: - warnings.warn("with ordsel = 'F', the selected order nr is greater\ - than nsmin, the sum of the order of the\ - alpha-unstable part and the order of a minimal\ - realization of the alpha-stable part of the given\ - system. In this case, the resulting nr is set equal\ - to nsmin.") - if out[-2] == 2: - warnings.warn("with ordsel = 'F', the selected order nr is less\ - than the order of the alpha-unstable part of the\ - given system. In this case nr is set equal to the\ - order of the alpha-unstable part.") - - raise_if_slycot_error(out[-1], arg_list, ab09nd.__doc__) - - Nr,A,B,C,D,Ns,hsv = out[:-2] - return Nr, A[:Nr,:Nr], B[:Nr,:], C[:,:Nr], D, Ns, hsv + alpha = {'C': 0, 'D': 1.}[dico] + out = _wrapper.ab09nd(dico, job, equil, ordsel, + n, m, p, nr, alpha, A, B, C, D, tol1, tol2, ldwork) + Nr, A, B, C, D, Ns, hsv = out[:-2] + raise_if_slycot_error(out[-2:], arg_list, ab09nd.__doc__, locals()) + return Nr, A[:Nr, :Nr], B[:Nr, :], C[:, :Nr], D, Ns, hsv + def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): """norm = ab13bd(dico, jobn, n, m, p, A, B, C, D, [tol]) @@ -1358,43 +1348,44 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The reduction of A to a real Schur form failed - :e.info = 2: - A failure was detected during the reordering of the - real Schur form of A, or in the iterative process for - reordering the eigenvalues of Z'*(A + B*F)*Z along the - diagonal - :e.info = 3: - The matrix A has a controllable eigenvalue on the - imaginary axis if dico == 'C' or the unit circle - if dico = 'D' - :e.info = 4: - The solution of Lyapunov equation failed because the - equation is singular - :e.info = 5: - dico = 'C' and D is a nonzero matrix - :e.info = 6: - jobn = 'H' and the system is unstable + SlycotArithmeticError + :info == 1: + The reduction of A to a real Schur form failed + :info == 2: + A failure was detected during the reordering of the + real Schur form of A, or in the iterative process for + reordering the eigenvalues of `` Z'*(A + B*F)*Z`` along the + diagonal (see SLICOT routine SB08DD) + :info == 3 and dico == 'C': + The matrix A has a controllable eigenvalue on the imaginary axis + :info == 3 and dico == 'D': + The matrix A has a controllable eigenvalue on the unit circle + :info == 4: + The solution of Lyapunov equation failed because the + equation is singular + :info == 5: + D is a nonzero matrix + :info == 6: + The system is unstable + + Warns + ----- + SlycotResultWarning + :iwarn > 0: + {iwarn} violations of the numerical stability condition + occured during the assignment of eigenvalues in + computing the right coprime factorization with inner + denominator of `G` (see the SLICOT subroutine SB08DD). """ - if dico != 'C' and dico != 'D': - raise SlycotParameterError('dico must be "C" or "D"', -1) - if jobn != 'H' and jobn != 'L': - raise SlycotParameterError('jobn must be "H" or "L"', -2) out = _wrapper.ab13bd(dico, jobn, n, m, p, A, B, C, D, tol) hidden = ' (hidden by the wrapper)' arg_list = ('dico', 'jobn', 'n', 'm', 'p', - 'A', 'lda'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, - 'D', 'ldd'+hidden, 'nq'+hidden,'tol', 'dwork'+hidden, - 'ldwork'+hidden, 'iwarn'+hidden, 'info'+hidden) - raise_if_slycot_error(out[-1], arg_list, ab13bd.__doc__) - + 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, + 'D', 'ldd' + hidden, 'nq' + hidden,'tol', 'dwork' + hidden, + 'ldwork' + hidden, 'iwarn', 'info') + raise_if_slycot_error(out[-2:], arg_list, ab13bd.__doc__, locals()) return out[0] def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): @@ -1473,22 +1464,26 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The matrix E is (numerically) singular - :e.info = 2: - The (periodic) QR (or QZ) algorithm for computing - eigenvalues did not converge - :e.info = 3: - The SVD algorithm for computing singular values did - not converge - :e.info = 4: - The tolerance is too small and the algorithm did not converge + SlycotArithmeticError + :info = 1: + The matrix E is (numerically) singular + :info = 2: + The (periodic) QR (or QZ) algorithm for computing + eigenvalues did not converge + :info = 3: + The SVD algorithm for computing singular values did + not converge + :info = 4: + The tolerance is too small and the algorithm did not converge """ - + hidden = ' (hidden by the wrapper)' + arg_list = ('dico', 'jobe', 'equil', 'jobd', 'n', 'm', 'p', + 'fpeak' + hidden, + 'A', 'lda' + hidden, 'E', 'lde' + hidden, 'B', 'ldb' + hidden, + 'C', 'ldc' + hidden, 'D', 'ldd' + hidden, + 'gpeak' + hidden, 'tol', 'iwork' + hidden, 'dwork' + hidden, + 'ldwork' + hidden, 'cwork' + hidden, 'lcwork' + hidden, + 'info' + hidden) if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be "C" or "D"', -1) if jobe != 'G' and jobe != 'I': @@ -1497,21 +1492,15 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): raise SlycotParameterError('equil must be "S" or "N"', -3) if jobd != 'D' and jobd != 'Z': raise SlycotParameterError('jobd must be "D" or "Z"', -4) - out = _wrapper.ab13dd(dico, jobe, equil, jobd, n, m, p, [0.0, 1.0], A, E, B, C, D, tol) - if out[-1] == 0: - # success - fpeak = out[0][0] if out[0][1] > 0 else float('inf') - gpeak = out[1][0] if out[1][1] > 0 else float('inf') - return gpeak, fpeak - - hidden = ' (hidden by the wrapper)' - arg_list = ('dico', 'jobe', 'equil', 'jobd', 'n', 'm', 'p', - 'fpeak'+hidden, - 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, - 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, - 'gpeak'+hidden, 'tol', 'iwork'+hidden, 'dwork'+hidden, - 'ldwork'+hidden, 'cwork'+hidden, 'lcwork'+hidden, 'info'+hidden) + out = _wrapper.ab13dd(dico, jobe, equil, jobd, + n, m, p, [0.0, 1.0], A, E, B, C, D, tol) raise_if_slycot_error(out[-1], arg_list, ab13dd.__doc__) + + fpeak = out[0][0] if out[0][1] > 0 else float('inf') + gpeak = out[1][0] if out[1][1] > 0 else float('inf') + return gpeak, fpeak + + def ab13ed(n, A, tol = 9.0): """low, high = ab13ed(n, A, [tol]) @@ -1561,21 +1550,18 @@ def ab13ed(n, A, tol = 9.0): Raises ------ - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The QR algorithm fails to converge + SlycotParameterError + :info = -i: the i-th argument had an illegal value; + SlycotArithmeticError + :info = 1: + The QR algorithm fails to converge """ - out = _wrapper.ab13ed(n, A, tol) - if out[-1] == 0: - # success - return out[0], out[1] - hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'A', 'lda'+hidden, 'low'+hidden, 'high'+hidden, 'tol', - 'dwork'+hidden, 'ldwork'+hidden, 'info'+hidden] + arg_list = ['n', 'A', 'lda' + hidden, 'low' + hidden, 'high' + hidden, 'tol', + 'dwork' + hidden, 'ldwork' + hidden, 'info' + hidden] + out = _wrapper.ab13ed(n, A, tol) raise_if_slycot_error(out[-1], arg_list, ab13ed.__doc__) + return out[:-1] def ab13fd(n, A, tol = 0.0): """beta, omega = ab13fd(n, A, [tol]) @@ -1627,28 +1613,23 @@ def ab13fd(n, A, tol = 0.0): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 2: - Either the QR or SVD algorithm fails to converge + SlycotArithmeticError + :info = 2: + Either the QR or SVD algorithm fails to converge + Warns + ----- + SlycotResultWarning + :info = 1: + Failed to compute beta(A) within the specified tolerance. + Nevertheless, the returned value is an upper bound on beta(A); """ - out = _wrapper.ab13fd(n, A, tol) - if out[-1] == 0: - # success - return out[0], out[1] - - if out[-1] == 1: - warnings.warn("the routine fails to compute beta(A) within the" - " specified tolerance") - return out[0], out[1] # the returned value is an upper bound on beta(A) - hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'A', 'lda'+hidden, 'beta'+hidden, 'omega'+hidden, 'tol', - 'dwork'+hidden, 'ldwork'+hidden, 'cwork'+hidden, - 'lcwork'+hidden, 'info'+hidden] + arg_list = ['n', 'A', 'lda' + hidden, 'beta' + hidden, 'omega' + hidden, 'tol', + 'dwork' + hidden, 'ldwork' + hidden, 'cwork' + hidden, + 'lcwork' + hidden, 'info' + hidden] + out = _wrapper.ab13fd(n, A, tol) raise_if_slycot_error(out[-1], arg_list, ab13fd.__dict__) + return out[0], out[1] def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) @@ -1737,20 +1718,24 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): multiplicities of infinite eigenvalues. """ hidden = ' (hidden by the wrapper)' - arg_list = ['equil', 'l', 'n', 'm', 'p', 'A', 'lda'+hidden, 'E', 'lde'+hidden, 'B', 'ldb'+hidden, 'C', 'ldc'+hidden, 'D', 'ldd'+hidden, 'nfz', 'nrank', 'niz', 'dinfz', 'nkror', 'ninfe', 'nkrol', 'infz', 'kronr', 'infe', 'kronl', 'tol', 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'info'] - - if equil != 'S' and equil != 'N': - raise SlycotParameterError('Parameter equil had an illegal value', -1) + arg_list = ['equil', 'l', 'n', 'm', 'p', + 'A', 'lda' + hidden, 'E', 'lde' + hidden, 'B', 'ldb' + hidden, + 'C', 'ldc' + hidden, 'D', 'ldd' + hidden, + 'nfz', 'nrank', 'niz', 'dinfz', 'nkror', 'ninfe', 'nkrol', + 'infz', 'kronr', 'infe', 'kronl', 'tol', + 'iwork' + hidden, 'dwork' + hidden, 'ldwork', 'info'] if ldwork is None: - ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)) + ldw = max(l+p, m+n)*(m+n) + max(1, 5*max(l+p, m+n)) if equil == 'S': ldwork = max(4*(l+n), ldw) - else: #equil == 'N' + else: # equil == 'N' ldwork = ldw - [Af,Ef,nfz,nrank,niz,dinfz,nkror,ninfe,nkrol,infz,kronr,infe,kronl,info]= _wrapper.ag08bd(equil,l,n,m,p,A,E,B,C,D,tol,ldwork) - - raise_if_slycot_error(info, arg_list, '') + out = _wrapper.ag08bd(equil, l, n, m, p, A, E, B, C, D, tol, ldwork) + [Af, Ef, nfz, nrank, niz, + dinfz, nkror, ninfe, nkrol, infz, kronr, infe, kronl, info] = out + raise_if_slycot_error(info, arg_list) - return Af[:nfz,:nfz],Ef[:nfz,:nfz],nrank,niz,infz[:dinfz],kronr[:nkror],infe[:ninfe],kronl[:nkrol] + return (Af[:nfz, :nfz], Ef[:nfz, :nfz], nrank, niz, + infz[:dinfz], kronr[:nkror], infe[:ninfe], kronl[:nkrol]) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 01ad59c8..1f85679f 100755 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -50,9 +50,10 @@ class SlycotArithmeticError(SlycotError, ArithmeticError): class SlycotWarning(UserWarning): """Slycot Warning""" - def __init__(self, message, info): + def __init__(self, message, iwarn, info): super(SlycotWarning, self).__init__(message) self.info = info + self.iwarn = iwarn class SlycotResultWarning(SlycotWarning): @@ -87,7 +88,7 @@ def _parse_docsection(section_name, docstring, checkvars): # Exception Type ematch = re.match( - r'(\s*)(Slycot.*(Error|Warning)) : e', l) + r'(\s*)(Slycot.*(Error|Warning))', l) if ematch: error_indent = len(ematch.group(1)) slycot_error = ematch.group(2) @@ -100,7 +101,7 @@ def _parse_docsection(section_name, docstring, checkvars): infospec_indent = len(imatch.group(1)) infospec = imatch.group(2) # Don't handle the standard case unless we have i - if infospec == "e.info = -i": + if infospec == "info = -i": if 'i' not in checkvars.keys(): continue infospec_ = infospec.replace(" = ", " == ") @@ -135,8 +136,8 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): Parameters ---------- - info: int - The parameter INFO returned by the SLICOT subroutine + info: int or list of int + The parameter INFO or [IWARN, INFO] returned by the SLICOT subroutine arg_list: list of str, optional A list of arguments (possibly hidden by the wrapper) of the SLICOT subroutine @@ -149,16 +150,17 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): Notes ----- If the numpydoc compliant docstring has a "Raises" section with one or - multiple definition terms ``SlycotError : e`` or a subclass of it, + multiple definition terms ``SlycotError`` or a subclass of it, the matching exception text is used. - To raise warnings, define a "Warns" section using a ``SlycotWarning : e`` + To raise warnings, define a "Warns" section using a ``SlycotWarning`` definition or a subclass of it. The definition body must contain a reST compliant field list with - '::' as field name, where specifies the valid values - for `e.ìnfo` in a python parseable expression using the variables provided - in `checkvars`. A single " = " is treated as " == ". + '::' as field name, where is a python parseable + expression using the arguments `iwarn`, `info` and any additional variables + provided in `checkvars` (usually obtained by calling `locals()`. + A single " = " is treated as " == ". The body of the field list contains the exception or warning message and can contain replacement fields in format string syntax using the variables @@ -174,22 +176,25 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): ... ... Raises ... ------ - ... SlycotArithmeticError : e - ... :e.info = 1: Info is 1 - ... :e.info > 1 and e.info < n: - ... Info is {e.info}, which is between 1 and {n} - ... :n <= e.info < m: - ... {e.info} is in [{n}, {m:10.2g})! + ... SlycotArithmeticError + ... :info = 1: INFO is 1 + ... :info > 1 and info < n: + ... INFO is {info}, which is between 1 and {n} + ... :n <= info < m: + ... {info} is in [{n}, {m:10.2g})! ... ... Warns ... ----- - ... SlycotResultWarning : e - ... :e.info >= 120: {e.info} is too large + ... SlycotResultWarning + ... :info >= 120: {info} is too large + ... SlycotResultWarning + ... :iwarn == 1: IWARN is 1 ... ''' ... n, m = 4, 120. ... raise_if_slycot_error(info, ... arg_list=["a", "b", "c"], - ... docstring=fun.__doc__, + ... docstring=(fun.__doc__ if type(info) is list + ... else fun.__doc__[:-60]), ... checkvars=locals()) ... >>> fun(0) @@ -198,19 +203,31 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): The following argument had an illegal value: a >>> fun(1) SlycotArithmeticError: - Info is 1 + INFO is 1 >>> fun(2) SlycotArithmeticError: - Info is 2, which is between 1 and 4 + INFO is 2, which is between 1 and 4 >>> fun(4) SlycotArithmeticError: 4 is in [4, 1.2e+02)! >>> fun(120) SlycotResultWarning: 120 is too large + >>> fun([1,0]) + SlycotResultWarning: + IWARN is 1 """ + try: + iwarn, info = info + except TypeError: + iwarn = None if docstring: - checkvars['e'] = SlycotError("", info) + # possibly override with mandatory argument + checkvars['info'] = info + if iwarn is not None: # do not possibly override if not provided + checkvars['iwarn'] = iwarn + else: + iwarn = 0 exception, message = _parse_docsection("Raises", docstring, checkvars) if exception and message: @@ -220,9 +237,16 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): warning, message = _parse_docsection("Warns", docstring, checkvars) if warning and message: fmessage = '\n' + message.format(**checkvars).strip() - warn(globals()[warning](fmessage, info)) + warn(globals()[warning](fmessage, iwarn, info)) + return if info < 0 and arg_list: message = ("The following argument had an illegal value: {}" "".format(arg_list[-info-1])) raise SlycotParameterError(message, info) + + # catch all + if info > 0: + raise SlycotError("Caught unhandled nonzero INFO value {}" + .format(info), + info) diff --git a/slycot/math.py b/slycot/math.py index 217be5e8..57d4f22d 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -438,6 +438,8 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): without evaluating the product. Specifically, the matrices Z_i are computed, such that + :: + Z_1' * H_1 * Z_2 = T_1, Z_2' * H_2 * Z_3 = T_2, ... @@ -454,14 +456,12 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): Parameters ---------- - job : {'E', 'S'} Indicates whether the user wishes to compute the full Schur form or the eigenvalues only, as follows: = 'E': Compute the eigenvalues only; = 'S': Compute the factors T_1, ..., T_p of the full Schur form, T = T_1*T_2*...*T_p. - compz : {'N', 'I', 'V'} Indicates whether or not the user wishes to accumulate the matrices Z_1, ..., Z_p, as follows: @@ -472,10 +472,8 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): = 'V': Z_i must contain an orthogonal matrix Q_i on entry, and the product Q_i*Z_i is returned, i = 1, ..., p. - n : int The order of the matrix H. n >= 0 - ilo, ihi : int It is assumed that all matrices H_j, j = 2, ..., p, are already upper triangular in rows and columns [:ilo-1] and @@ -487,32 +485,25 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): transformations to all the rows and columns of the matrices H_i, i = 1,...,p, if JOB = 'S'. 1 <= ilo <= max(1,n); min(ilo,n) <= ihi <= n. - iloz, ihiz : int Specify the rows of Z to which the transformations must be applied if compz = 'I' or compz = 'V'. 1 <= iloz <= ilo; ihi <= ihiz <= n. - - H : ndarray + H : array_like H[:n,:n,0] must contain the upper Hessenberg matrix H_1 and H[:n,:n,j-1] for j > 1 must contain the upper triangular matrix H_j, j = 2, ..., p. - - Q : ndarray + Q : array_like If compz = 'V', Q[:n,:n,:p] must contain the current matrix Q of transformations accumulated by SLICOT Library routine MB03VY. If compz = 'I', Q is ignored - ldwork : int, optinal The length of the cache array. The default value is ihi-ilo+p-1 - - Returns ------- - T : ndarray 3D array with the same shape as H. If JOB = 'S', T[:n,:n,0] is upper quasi-triangular in rows @@ -521,7 +512,6 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): T[:n,:n,j-1] for j > 1 contains the resulting upper triangular matrix T_j. If job = 'E', T is None - Z : ndarray 3D array with the same shape as Q. If compz = 'V', or compz = 'I', the leading @@ -530,9 +520,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): transformations are applied only to the submatrices Z[iloz-1:ihiz,ilo-1:ihi,j-1], j = 1, ..., p. If compz = 'N', Z is None - - W : ndarray (dtype=complex) - 1D array with shape (n). + W : (n,) complex ndarray The computed eigenvalues ilo to ihi. If two eigenvalues are computed as a complex conjugate pair, they are stored in consecutive elements of W say the i-th and @@ -540,6 +528,14 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): If JOB = 'S', the eigenvalues are stored in the same order as on the diagonal of the Schur form returned in H. + Warns + ----- + SlycotResultWarning + :info > 0: + failed to compute all the eigenvalues {ilo} to {ihi} + in a total of 30*({ihi}-{ilo}+1) iterations + the elements Wr{{info}:{ihi}] contains those + eigenvalues which have been successfully computed. """ hidden = ' (hidden by the wrapper)' arg_list = ['job', 'compz', 'n', 'p' + hidden, @@ -555,15 +551,8 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): T, Z, Wr, Wi, info = _wrapper.mb03wd( job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork) + raise_if_slycot_error(info, arg_list, mb03rd.__doc__, locals()) - raise_if_slycot_error(info, arg_list) - - if info > 0: - warnings.warn(("failed to compute all the eigenvalues {ilo} to {ihi} " - "in a total of 30*({ihi}-{ilo}+1) iterations " - "the elements {i}:{ihi} of Wr contain those " - "eigenvalues which have been successfully computed." - ).format(i=info, ilo=ilo, ihi=ihi)) if job == 'E': T = None if compz == 'N': @@ -574,7 +563,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): def mb05md(a, delta, balanc='N'): - """Ar, Vr, Yr, VAL = mb05md(a, delta, balanc='N') + """Ar, Vr, Yr, w = mb05md(a, delta, balanc='N') Matrix exponential for a real non-defective matrix @@ -631,7 +620,7 @@ def mb05md(a, delta, balanc='N'): the (right) eigenvector matrix of `A`, where `Lambda` is the diagonal matrix of eigenvalues. - VAL : (n,) real or complex ndarray + w : (n,) real or complex ndarray Contains the eigenvalues of the matrix `A`. The eigenvalues are unordered except that complex conjugate pairs of values appear consecutively with the eigenvalue having positive @@ -639,16 +628,16 @@ def mb05md(a, delta, balanc='N'): Warns ------ - SlycotResultWarning : e - :0 < e.info <=n: + SlycotResultWarning + :0 < info <=n: the QR algorithm failed to compute all the eigenvalues; no eigenvectors have been computed; - w[{e.info:n}] contains eigenvalues which have converged; - :e.info == n+1: + w[{info}:{n}] contains eigenvalues which have converged; + :info == n+1: The inverse of the eigenvector matrix could not be formed due to an attempt to divide by zero, i.e., the eigenvector matrix is singular; - :e.info == n+2: + :info == n+2: Matrix A is defective, possibly due to rounding errors. """ hidden = ' (hidden by the wrapper)' @@ -661,15 +650,13 @@ def mb05md(a, delta, balanc='N'): n=n, delta=delta, a=a) - - raise_if_slycot_error(INFO, arg_list, - docstring=mb05md.__doc__, checkvars=locals()) + raise_if_slycot_error(INFO, arg_list, mb05md.__doc__, locals()) if not all(VALi == 0): - VAL = VALr + 1J*VALi + w = VALr + 1J*VALi else: - VAL = VALr - return (Ar, Vr, Yr, VAL) + w = VALr + return (Ar, Vr, Yr, w) @@ -678,23 +665,42 @@ def mb05nd(a, delta, tol=1e-7): To compute - (a) F(delta) = exp(A*delta) and + :: + (a) F(delta) = exp(A*delta) and (b) H(delta) = Int[F(s) ds] from s = 0 to s = delta, - where A is a real N-by-N matrix and delta is a scalar value. + where `A` is a real`n`-by-`n` matrix and `delta` is a scalar value. + + Parameters + ---------- + A : (n,n) array_like + Square matrix + delta : float + The scalar value delta of the problem. + tol : float + Tolerance. A good value is sqrt(eps) - Required arguments: - A : input rank-2 array('d') with bounds (n,n) - Square matrix - delta : input 'd' - The scalar value delta of the problem. - tol : input 'd' - Tolerance. A good value is sqrt(eps) + Returns + ------- + F : ndarray + exp(A*delta) + H : ndarray + Int[F(s) ds] from s = 0 to s = delta, - Return objects: - F : exp(A*delta) - H : Int[F(s) ds] from s = 0 to s = delta, + Raises + ------ + SlycotArithmeticError + :1 < info <=n: + the ({info},{info}) element of the denominator of + the Pade approximation is zero, so the denominator + is exactly singular; + :info == n+1: + ``DELTA = (delta * frobenius norm of matrix A)`` is + probably too large to permit meaningful computation. + That is, {delta} > SQRT(BIG), where BIG is a + representable number near the overflow threshold of + the machine (see LAPACK Library Routine DLAMCH). """ hidden = ' (hidden by the wrapper)' arg_list = ['n', 'delta', 'a', 'lda'+hidden, 'ex', 'ldex'+hidden, @@ -702,10 +708,7 @@ def mb05nd(a, delta, tol=1e-7): 'dwork'+hidden, 'ldwork'+hidden] n = min(a.shape) out = _wrapper.mb05nd(n=n, delta=delta, a=a, tol=tol) - - raise_if_slycot_error(out[-1], arg_list) - if out[-1] == n+1: - raise SlycotArithmeticError("Delta too large", out[-1]) + raise_if_slycot_error(out[-1], arg_list, mb05nd.__doc__, locals()) return out[:-1] @@ -724,41 +727,55 @@ def mc01td(dico, dp, p): Parameters ---------- - dico : {'C', 'D'} - Indicates whether the stability test to be applied to `P(x)` is in - the continuous-time or discrete-time case as follows:: + dico : {'C', 'D'} + Indicates whether the stability test to be applied to `P(x)` is in + the continuous-time or discrete-time case as follows:: - = 'C': continuous-time case; - = 'D': discrete-time case. + = 'C': continuous-time case; + = 'D': discrete-time case. - dp : int - The degree of the polynomial `P(x)`. ``dp >= 0``. - p : (dp+1,) array_like - This array must contain the coefficients of `P(x)` in increasing - powers of `x`. + dp : int + The degree of the polynomial `P(x)`. ``dp >= 0``. + p : (dp+1,) array_like + This array must contain the coefficients of `P(x)` in increasing + powers of `x`. Returns ------- - dp : int - If ``P(dp+1) = 0.0`` on entry, then `dp` contains the index of the - highest power of `x` for which ``P(dp+1) <> 0.0``. - stable : int - Equal to 1 if `P(x)` is stable, 0 otherwise. - nz : int - The number of unstable zeros. + dp : int + If ``P(dp+1) = 0.0`` on entry, then `dp` contains the index of the + highest power of `x` for which ``P(dp+1) <> 0.0``. + stable : int + Equal to 1 if `P(x)` is stable, 0 otherwise. + nz : int + The number of unstable zeros. + + Warns + ----- + SlycotResultWarning + :info == 1: + Entry ``P(x)`` is the zero polynomial. + :info == 2 and dico == 'C': + The polynomial ``P(x)`` is most probably unstable, + although it may be stable with one or more zeros + very close to the imaginary axis. + The number of unstable zeros (NZ) is not determined. + :info == 2 and dico == 'D': + The polynomial ``P(x)`` is most probably unstable, + although it may be stable with one or more zeros + very close to the the unit circle. + The number of unstable zeros (NZ) is not determined. + :iwarn > 0: + The degree of the polynomial ``P(x)`` has been + reduced to ``(DB - {iwarn})`` because + ``P(DB+1-j) = 0.0`` on entry + for ``j = 0, 1,..., k-1`` and ``P(DB+1-k) <> 0.0``. """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'dp', 'P', 'stable', 'nz', 'DWORK' + hidden, 'IWARN', 'INFO'] (dp_out, stable_log, nz, iwarn, info) = _wrapper.mc01td(dico, dp, p) - raise_if_slycot_error(info, arg_list) - if info == 1: - warnings.warn('entry P(x) is the zero polynomial.') - if info == 2: - warnings.warn('P(x) may have zeros very close to stability boundary.') - if iwarn > 0: - fmt = 'The degree of P(x) has been reduced to {:d}' - warnings.warn(fmt.format(dp - iwarn)) + raise_if_slycot_error([iwarn, info], arg_list, mc01td.__doc__, locals()) ftrue, ffalse = _wrapper.ftruefalse() stable = 1 if stable_log == ftrue else 0 return (dp_out, stable, nz) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index a913ace6..462650a2 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -103,30 +103,34 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - the reduction of A to a real Schur form failed; - :e.info = 2: - a failure was detected during the ordering of the - real Schur form of A, or in the iterative process - for reordering the eigenvalues of Z'*(A + B*F)*Z - along the diagonal. - :e.info = 3: - the number of eigenvalues to be assigned is less - than the number of possibly assignable eigenvalues; - nap eigenvalues have been properly assigned, - but some assignable eigenvalues remain unmodified. - :e.info = 4: - an attempt is made to place a complex conjugate - pair on the location of a real eigenvalue. This - situation can only appear when n-nfp is odd, - np > n-nfp-nup is even, and for the last real - eigenvalue to be modified there exists no available - real eigenvalue to be assigned. However, nap - eigenvalues have been already properly assigned. + SlycotArithmeticError + :info = 1: + the reduction of A to a real Schur form failed; + :info = 2: + a failure was detected during the ordering of the + real Schur form of A, or in the iterative process + for reordering the eigenvalues of Z'*(A + B*F)*Z + along the diagonal. + Warns + ----- + SlycotResultWarning + :info = 3: + the number of eigenvalues to be assigned is less + than the number of possibly assignable eigenvalues; + `nap`={nap} eigenvalues have been properly assigned, + but some assignable eigenvalues remain unmodified. + :info = 4: + an attempt is made to place a complex conjugate + pair on the location of a real eigenvalue. This + situation can only appear when ``n-nfp`` is odd, + ``np > n-nfp-nup`` is even, and for the last real + eigenvalue to be modified there exists no available + real eigenvalue to be assigned. However, `nap`={nap} + eigenvalues have been already properly assigned. + :iwarn > 0: + {iwarn} violations of the numerical stability condition + ``NORM(F) <= 100*NORM(A)/NORM(B)`` occured during the + assignment of eigenvalues Example ------- @@ -144,23 +148,23 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): array([ 0.2 , 0.40000001, 0.5 ]) """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'n', 'm', 'np', 'alpha', 'A', 'LDA'+hidden, 'B', - 'LDB'+hidden, 'wr'+hidden, 'wi'+hidden, 'nfp', 'nap', 'nup', 'F', - 'LDF'+hidden, 'Z', 'LDZ'+hidden, 'tol', 'DWORK'+hidden, 'ldwork', - 'IWARN'+hidden, 'INFO'+hidden] + arg_list = ['dico', 'n', 'm', 'np', 'alpha', + 'A', 'LDA' + hidden, 'B', 'LDB' + hidden, + 'wr' + hidden, 'wi' + hidden, 'nfp', 'nap', 'nup', + 'F', 'LDF' + hidden, 'Z', 'LDZ' + hidden, + 'tol', 'DWORK' + hidden, 'ldwork', + 'IWARN' + hidden, 'INFO' + hidden] if ldwork is None: - ldwork = max(1,5*m,5*n,2*n+4*m) - A_z,wr,wi,nfp,nap,nup,F,Z,warn,info = _wrapper.sb01bd(dico,n,m,np,alpha,A,B,w.real,w.imag,tol=tol,ldwork=ldwork) + ldwork = max(1, 5*m, 5*n, 2*n+4*m) + A_z, wr, wi, nfp, nap, nup, F, Z, iwarn, info = _wrapper.sb01bd( + dico, n, m, np, alpha, A, B, w.real, w.imag, tol=tol, ldwork=ldwork) - raise_if_slycot_error(info, arg_list, sb01bd.__doc__) + raise_if_slycot_error([iwarn, info], arg_list, sb01bd.__doc__, locals()) - if warn != 0: - warnings.warn('%i violations of the numerical stability condition occured during the assignment of eigenvalues' % warn) - # put togheter wr and wi into a complex array of eigenvalues - w = _np.zeros(np,'complex64') + w = _np.zeros(np, 'complex64') w.real = wr[0:np] w.imag = wi[0:np] - return A_z,w,nfp,nap,nup,F,Z + return A_z, w, nfp, nap, nup, F, Z def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): """ X,rcond,w,S,U,A_inv = sb02md(dico,n,A,G,Q,[hinv,uplo,scal,sort,ldwork]) @@ -275,25 +279,25 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): Raises ------ - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - if matrix A is (numerically) singular in discrete- - time case; - :e.info = 2: - if the Hamiltonian or symplectic matrix H cannot be - reduced to real Schur form; - :e.info = 3: - if the real Schur form of the Hamiltonian or - symplectic matrix H cannot be appropriately ordered; - :e.info = 4: - if the Hamiltonian or symplectic matrix H has less - than n stable eigenvalues; - :e.info = 5: - if the n-th order system of linear algebraic - equations, from which the solution matrix X would - be obtained, is singular to working precision. + SlycotParameterError + :info = -i: the i-th argument had an illegal value; + SlycotArithmeticError + :info = 1: + Matrix A is (numerically) singular in discrete- + time case; + :info = 2: + The Hamiltonian or symplectic matrix H cannot be + reduced to real Schur form; + :info = 3: + The real Schur form of the Hamiltonian or + symplectic matrix H cannot be appropriately ordered; + :info = 4: + The Hamiltonian or symplectic matrix H has less + than n stable eigenvalues; + :info = 5: + The n-th order system of linear algebraic + equations, from which the solution matrix X would + be obtained, is singular to working precision. Example @@ -313,20 +317,23 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): """ hidden = ' (hidden by the wrapper)' - arg_list = ['dico', 'hinv', 'uplo', 'scal', 'sort', 'n', 'A', 'LDA'+hidden, - 'G', 'LDG'+hidden, 'Q', 'LDQ'+hidden, 'rcond', 'wr'+hidden, 'wi'+hidden, 'S', - 'LDS'+hidden, 'U', 'LDU'+hidden, 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', - 'BWORK'+hidden, 'INFO'+hidden] + arg_list = ['dico', 'hinv', 'uplo', 'scal', 'sort', 'n', + 'A', 'LDA' + hidden, 'G', 'LDG' + hidden, 'Q', 'LDQ' + hidden, + 'rcond', 'wr' + hidden, 'wi' + hidden, 'S', 'LDS' + hidden, + 'U', 'LDU' + hidden, 'IWORK' + hidden, + 'DWORK' + hidden, 'ldwork', 'BWORK' + hidden, 'INFO' + hidden] if ldwork is None: - ldwork = max(3,6*n) - A_inv,X,rcond,wr,wi,S,U,info = _wrapper.sb02md(dico,n,A,G,Q,hinv=hinv,uplo=uplo,scal=scal,sort=sort,ldwork=ldwork) + ldwork = max(3, 6*n) + A_inv, X, rcond, wr, wi, S, U, info = _wrapper.sb02md( + dico, n, A, G, Q, + hinv=hinv, uplo=uplo, scal=scal, sort=sort, ldwork=ldwork) raise_if_slycot_error(info, arg_list, sb02md.__doc__) - w = _np.zeros(2*n,'complex64') + w = _np.zeros(2*n, 'complex64') w.real = wr[0:2*n] w.imag = wi[0:2*n] - return X,rcond,w,S,U,A_inv + return X, rcond, w, S, U, A_inv def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): """ A_b,B_b,Q_b,R_b,L_b,ipiv,oufact,G = sb02mt(n,m,B,R,[A,Q,L,fact,jobl,uplo,ldwork]) @@ -437,15 +444,13 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): Raises ------ - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :1 <= e.info <= m: - The {e.info}-th element of the `d` factor is + SlycotArithmeticError + :1 <= info <= m: + The {info}-th element of the `d` factor is exactly zero; the ``UdU' (or LdL')`` factorization has been completed, but the block diagonal matrix d is exactly singular; - :e.info = m+1: + :info = m+1: The matrix R is numerically singular. """ hidden = ' (hidden by the wrapper)' @@ -598,29 +603,26 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - if the computed extended matrix pencil is singular, - possibly due to rounding errors; - :e.info = 2: - if the QZ (or QR) algorithm failed; - :e.info = 3: - if reordering of the (generalized) eigenvalues failed; - :e.info = 4: - if after reordering, roundoff changed values of - some complex eigenvalues so that leading eigenvalues - in the (generalized) Schur form no longer satisfy - the stability condition; this could also be caused - due to scaling; - :e.info = 5: - if the computed dimension of the solution does not - equal n; - :e.info = 6: - if a singular matrix was encountered during the - computation of the solution matrix X. + SlycotArithmeticError + :info = 1: + The computed extended matrix pencil is singular, + possibly due to rounding errors; + :info = 2: + The QZ (or QR) algorithm failed; + :info = 3: + Reordering of the (generalized) eigenvalues failed; + :info = 4: + After reordering, roundoff changed values of + some complex eigenvalues so that leading eigenvalues + in the (generalized) Schur form no longer satisfy + the stability condition; this could also be caused + due to scaling; + :info = 5: + The computed dimension of the solution does not + equal n; + :info = 6: + A singular matrix was encountered during the + computation of the solution matrix X. Example ------- @@ -768,20 +770,20 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): Raises ------ - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; + SlycotParameterError + :info = -i: the i-th argument had an illegal value; Warns ----- - SlycotResultWarning : e - :0 < e.info <=n: + SlycotResultWarning + :0 < info <=n: The QR algorithm failed to compute all the eigenvalues (see LAPACK Library routine DGEES); - w[{e.info}:{n}] contains eigenvalues which have converged, + w[{info}:{n}] contains eigenvalues which have converged, and A contains the partially converged Shur form - :e.info == n+1 and dico == 'C': + :info == n+1 and dico == 'C': The matrices `A` and `-A'` have common or very close eigenvalues - :e.info == n+1 and dico == 'D': + :info == n+1 and dico == 'D': Matrix A has almost reciprocal eigenvalues (that is, `'lambda(i) = 1/lambda(j)`` for some `i` and `j`, where ``lambda(i)`` and ``lambda(j)`` are @@ -912,56 +914,64 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): Raises ------ + SlycotArithmeticError + :info = 3 and fact == 'F' and dico == 'C': + The Schur factor S supplied in the array A is not + stable (that is, one or more of the eigenvalues of + S has a non-negative real part) + :info = 3 and dico == 'D': + The Schur factor S + supplied in the array A is not convergent (that is, + one or more of the eigenvalues of S lies outside the + unit circle) + :info = 4: + FACT = 'F' and the Schur factor S supplied in + the array A has two or more consecutive non-zero + elements on the first sub-diagonal, so that there is + a block larger than 2-by-2 on the diagonal + :info = 5: + FACT = 'F' and the Schur factor S supplied in + the array A has a 2-by-2 diagonal block with real + eigenvalues instead of a complex conjugate pair; + :info = 6: + FACT = 'N' and the LAPACK Library routine DGEES + has failed to converge. This failure is not likely + to occur. - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - if the Lyapunov equation is (nearly) singular - (warning indicator); - if DICO = 'C' this means that while the matrix A - (or the factor S) has computed eigenvalues with - negative real parts, it is only just stable in the - sense that small perturbations in A can make one or - more of the eigenvalues have a non-negative real - part; - if DICO = 'D' this means that while the matrix A - (or the factor S) has computed eigenvalues inside - the unit circle, it is nevertheless only just - convergent, in the sense that small perturbations - in A can make one or more of the eigenvalues lie - outside the unit circle; - perturbed values were used to solve the equation; - :e.info = 2: - if FACT = 'N' and DICO = 'C', but the matrix A is - not stable (that is, one or more of the eigenvalues - of A has a non-negative real part), or DICO = 'D', - but the matrix A is not convergent (that is, one or - more of the eigenvalues of A lies outside the unit - circle); however, A will still have been factored - and the eigenvalues of A returned in WR and WI. - :e.info = 3: - if FACT = 'F' and DICO = 'C', but the Schur factor S - supplied in the array A is not stable (that is, one - or more of the eigenvalues of S has a non-negative - real part), or DICO = 'D', but the Schur factor S - supplied in the array A is not convergent (that is, - one or more of the eigenvalues of S lies outside the - unit circle); - :e.info = 4: - if FACT = 'F' and the Schur factor S supplied in - the array A has two or more consecutive non-zero - elements on the first sub-diagonal, so that there is - a block larger than 2-by-2 on the diagonal; - :e.info = 5: - if FACT = 'F' and the Schur factor S supplied in - the array A has a 2-by-2 diagonal block with real - eigenvalues instead of a complex conjugate pair; - :e.info = 6: - if FACT = 'N' and the LAPACK Library routine DGEES - has failed to converge. This failure is not likely - to occur. The matrix B will be unaltered but A will - be destroyed. + Warns + ----- + SlycotResultWarning + :info = 1 and dico == 'C': + The Lyapunov equation is (nearly) singular. + This means that while the matrix A + (or the factor S) has computed eigenvalues with + negative real parts, it is only just stable in the + sense that small perturbations in A can make one or + more of the eigenvalues have a non-negative real + part; + perturbed values were used to solve the equation; + :info = 1 and dico == 'D': + The Lyapunov equation is (nearly) singular. + This means that while the matrix A + (or the factor S) has computed eigenvalues inside + the unit circle, it is nevertheless only just + convergent, in the sense that small perturbations + in A can make one or more of the eigenvalues lie + outside the unit circle; + perturbed values were used to solve the equation; + :info = 2 and fact == 'N' and dico == 'C': + The matrix A is + not stable (that is, one or more of the eigenvalues + of A has a non-negative real part), or DICO = 'D', + but the matrix A is not convergent (that is, one or + more of the eigenvalues of A lies outside the unit + circle); however, A still has been factored + and the eigenvalues of A are returned in WR and WI. + :info = 2 and dico == 'D': + The matrix A is not convergent (that is, one or + more of the eigenvalues of A lies outside the unit + circle); however, A still has been factored + and the eigenvalues of A are returned in WR and WI. """ hidden = ' (hidden by the wrapper)' arg_list = ['dico','fact', 'trans', 'n', 'm', 'a', 'lda'+hidden, 'q', @@ -975,68 +985,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03od(dico,n,m,A,Q,B,fact=fact,trans=trans,ldwork=ldwork) - - raise_if_slycot_error(out[-1], arg_list) - if out[-1] == 1: - if dico == 'D': - error_text = """this means that while the matrix A - (or the factor S) has computed eigenvalues inside - the unit circle, it is nevertheless only just - convergent, in the sense that small perturbations - in A can make one or more of the eigenvalues lie - outside the unit circle; - perturbed values were used to solve the equation;""" - else: - error_text = """this means that while the matrix A - (or the factor S) has computed eigenvalues with - negative real parts, it is only just stable in the - sense that small perturbations in A can make one or - more of the eigenvalues have a non-negative real - part;""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 2: - if dico == 'D': - error_text = """the matrix A is not convergent (that is, one or - more of the eigenvalues of A lies outside the unit - circle); however, A will still have been factored - and the eigenvalues of A returned in WR and WI.""" - else: - error_text = """the matrix A is - not stable (that is, one or more of the eigenvalues - of A has a non-negative real part).""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 3: - if dico == 'D': - error_text = """the Schur factor S - supplied in the array A is not convergent (that is, - one or more of the eigenvalues of S lies outside the - unit circle).""" - else: - error_text = """the Schur factor S - supplied in the array A is not stable (that is, one - or more of the eigenvalues of S has a non-negative - real part).""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 4: - if fact == 'F': - error_text = """the Schur factor S supplied in - the array A has two or more consecutive non-zero - elements on the first sub-diagonal, so that there is - a block larger than 2-by-2 on the diagonal.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 5: - if fact == 'F': - error_text = """the Schur factor S supplied in - the array A has a 2-by-2 diagonal block with real - eigenvalues instead of a complex conjugate pair.""" - raise SlycotArithmeticError(error_text, out[-1]) - if out[-1] == 6: - if fact == 'N': - error_text = """the LAPACK Library routine DGEES - has failed to converge. This failure is not likely - to occur. The matrix B will be unaltered but A will - be destroyed.""" - raise SlycotArithmeticError(error_text, out[-1]) + raise_if_slycot_error(out[-1], arg_list, sb03od.__doc__, locals()) U,scale,wr,wi = out[:-1] w = _np.zeros(n,'complex64') w.real = wr[0:n] @@ -1048,117 +997,97 @@ def sb04md(n,m,A,B,C,ldwork=None): To solve for X the continuous-time Sylvester equation - AX + XB = C + ``AX + XB = C`` where A, B, C and X are general n-by-n, m-by-m, n-by-m and n-by-m matrices respectively. - Required arguments - ------------------ - - n : input int - m : input int - A : input rank-2 array('d'), shape (n,n) - B : input rank-2 array('d'), shape (m,m) - C : input rank-2 array('d'), shape (n,m) - - Return objects - -------------- + Parameters + ---------- + n : int + row shape + m : int + column shape + A : (n,n) array_like + Matrix A + B : (m,m) array_like + Matrix B + C : (n,m) array_like + Matrix C - X : rank-2 array('d'), shape (n,m) + Returns + ------- + X : (n,m) ndarray + Matrix X Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info > 0: - if info = i, 1 <= i <= m, the QR algorithm failed to - compute all the eigenvalues of B (see LAPACK Library - routine DGEES) - :e.info > m: - if a singular matrix was encountered whilst solving - for the (info-m)-th column of matrix X. + SlycotArithmeticError + :0 < info <= m: + The QR algorithm failed to compute all the eigenvalues + of B (see LAPACK Library routine DGEES) + :info > m: + A singular matrix was encountered whilst solving + for the ({info}-{m})-th column of matrix X. """ hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'm', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', - 'LDC'+hidden, 'Z', 'LDZ'+hidden, 'IWORK'+hidden, 'DWORK'+hidden, - 'ldwork', 'INFO'+hidden] - if ldwork is None: - out = _wrapper.sb04md(n,m,A,B,C) - else: - out = _wrapper.sb04md(n,m,A,B,C,ldwork=ldwork) - - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0 and out[-1] <= m: - error_text = """The QR algorithm failed to compute all the eigenvalues -(see LAPACK Library routine DGEES)""" - raise SlycotArithmeticError(error_text, out[-1]) - elif out[-1] > m: - error_text = """a singular matrix was encountered whilst solving -for the %i-th column of matrix X.""" % (out[-1]-m) - raise SlycotArithmeticError(error_text, out[-1]) - return out[2] + arg_list = ['n', 'm', 'A', 'LDA' + hidden, 'B', 'LDB' + hidden, + 'C', 'LDC' + hidden, 'Z', 'LDZ' + hidden, + 'IWORK' + hidden, 'DWORK' + hidden, 'ldwork', 'INFO' + hidden] + out = _wrapper.sb04md(n, m, A, B, C, ldwork) + U, S, X, Z, info = out + raise_if_slycot_error(info, arg_list, sb04md.__doc__, locals()) + return X def sb04qd(n,m,A,B,C,ldwork=None): """X = sb04qd(n,m,A,B,C[,ldwork]) To solve for X the discrete-time Sylvester equation - AXB + X + C = 0, + ``AXB + X + C = 0,`` where A, B, C and X are general n-by-n, m-by-m, n-by-m and n-by-m matrices respectively. A Hessenberg-Schur method, which reduces A to upper Hessenberg form, H = U'AU, and B' to real Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. - Required arguments - ------------------ - - n : input int - m : input int - A : input rank-2 array('d'), shape (n,n) - B : input rank-2 array('d'), shape (m,m) - C : input rank-2 array('d'), shape (n,m) - Return objects - -------------- + Parameters + ---------- + n : int + row shape + m : int + column shape + A : (n,n) array_like + Matrix A + B : (m,m) array_like + Matrix B + C : (n,m) array_like + Matrix C - X : rank-2 array('d'), shape (n,m) + Returns + ------- + X : (n,m) ndarray + Matrix X Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :1 <= e.info <= m: - if info = i, 1 <= i <= m, the QR algorithm failed to - compute all the eigenvalues of B (see LAPACK Library - routine DGEES) - :e.info > m: - if a singular matrix was encountered whilst solving - for the (info-m)-th column of matrix X. + SlycotArithmeticError + :0 < info <= m: + The QR algorithm failed to compute all the eigenvalues + of B (see LAPACK Library routine DGEES) + :info > m: + A singular matrix was encountered whilst solving + for the ({info}-{m})-th column of matrix X. """ hidden = ' (hidden by the wrapper)' - arg_list = ['n', 'm', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', - 'LDC'+hidden, 'Z', 'LDZ'+hidden, 'IWORK'+hidden, 'DWORK'+hidden, - 'ldwork', 'INFO'+hidden] - if ldwork is None: - out = _wrapper.sb04qd(n,m,A,B,C) - else: - out = _wrapper.sb04qd(n,m,A,B,C,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0 and out[-1] <= m: - error_text = """The QR algorithm failed to compute all the eigenvalues -(see LAPACK Library routine DGEES)""" - raise SlycotArithmeticError(error_text, out[-1]) - elif out[-1] > m: - error_text = """a singular matrix was encountered whilst solving -for the %i-th column of matrix X.""" % (out[-1]-m) - raise SlycotArithmeticError(error_text, out[-1]) - return out[2] + arg_list = arg_list = ['n', 'm', 'A', 'LDA' + hidden, 'B', 'LDB' + hidden, + 'C', 'LDC' + hidden, 'Z', 'LDZ' + hidden, + 'IWORK' + hidden, 'DWORK' + hidden, 'ldwork', 'INFO' + hidden] + out = _wrapper.sb04qd(n,m,A,B,C,ldwork) + U, S, X, Z, info = out + raise_if_slycot_error(info, arg_list, sb04qd.__doc__, locals()) + return X def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None,ldwork=None): """ gamma_est, Ak, Bk, Ck, Dk, Ac, Bc, Cc, Dc, rcond = sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,[job,gtol,actol,liwork,ldwork]) @@ -1282,50 +1211,46 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The matrix | A-j*omega*I B2 | had not full - | C1 D12 | - column rank in respect to the tolerance eps; - :e.info = 2: - The matrix | A-j*omega*I B1 | had not full row - | C2 D21 | - rank in respect to the tolerance eps; - :e.info = 3: - The matrix D12 had not full column rank in - respect to the tolerance SQRT(eps); - :e.info = 4: - The matrix D21 had not full row rank in respect - to the tolerance SQRT(eps); - :e.info = 5: - The singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21); - |C1 D12| |C2 D21| - :e.info = 6: - The controller is not admissible (too small value of gamma); - :e.info = 7: - The X-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - :e.info = 8: - The Y-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - :e.info = 9: - if the determinant of Im2 + Tu*D11HAT*Ty*D22 is - zero [3]; - :e.info = 10: - There are numerical problems when estimating - singular values of D1111, D1112, D1111', D1121'; - :e.info = 11: - The matrices Inp2 - D22*DK or Im2 - DK*D22 - are singular to working precision; - :e.info = 12: - A stabilizing controller cannot be found. + SlycotArithmeticError + :info = 1: + The matrix | A-j*omega*I B2 | had not full + | C1 D12 | + column rank in respect to the tolerance eps; + :info = 2: + The matrix | A-j*omega*I B1 | had not full row + | C2 D21 | + rank in respect to the tolerance eps; + :info = 3: + The matrix D12 had not full column rank in + respect to the tolerance SQRT(eps); + :info = 4: + The matrix D21 had not full row rank in respect + to the tolerance SQRT(eps); + :info = 5: + The singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices |A B2 |, |A B1 |, D12 or D21); + |C1 D12| |C2 D21| + :info = 6: + The controller is not admissible (too small value of gamma); + :info = 7: + The X-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :info = 8: + The Y-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :info = 9: + The determinant of Im2 + Tu*D11HAT*Ty*D22 is zero; + :info = 10: + There are numerical problems when estimating + singular values of D1111, D1112, D1111', D1121'; + :info = 11: + The matrices Inp2 - D22*DK or Im2 - DK*D22 + are singular to working precision; + :info = 12: + A stabilizing controller cannot be found. """ hidden = ' (hidden by the wrapper)' arg_list = ['job', 'n', 'm', 'np', 'ncon', 'nmeas', 'gamma', @@ -1481,41 +1406,38 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - j*Theta - if the matrix | A-e *I B2 | had not full - | C1 D12 | - column rank; - :e.info = 2: - j*Theta - if the matrix | A-e *I B1 | had not full - | C2 D21 | - row rank; - :e.info = 3: - if the matrix D12 had not full column rank; - :e.info = 4: - if the matrix D21 had not full row rank; - :e.info = 5: - if the controller is not admissible (too small value of gamma); - :e.info = 6: - if the X-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - :e.info = 7: - if the Z-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties); - :e.info = 8: - if the matrix Im2 + DKHAT*D22 is singular. - :e.info = 9: - if the singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21). - |C1 D12| |C2 D21| + SlycotArithmeticError + :info = 1: + . j*Theta + The matrix | A-e *I B2 | had not full + | C1 D12 | + column rank; + :info = 2: + . j*Theta + The matrix | A-e *I B1 | had not full + | C2 D21 | + row rank; + :info = 3: + The matrix D12 had not full column rank; + :info = 4: + The matrix D21 had not full row rank; + :info = 5: + The controller is not admissible (too small value of gamma); + :info = 6: + The X-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :info = 7: + The Z-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties); + :info = 8: + The matrix Im2 + DKHAT*D22 is singular. + :info = 9: + The singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices |A B2 |, |A B1 |, D12 or D21). + |C1 D12| |C2 D21| """ hidden = ' (hidden by the wrapper)' @@ -1625,24 +1547,21 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - if the matrix D12 had not full column rank in - respect to the tolerance tol; - :e.info = 2: - if the matrix D21 had not full row rank in respect - to the tolerance tol; - :e.info = 3: - if the singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices D12 or D21). - :e.info = 4: - if the X-Riccati equation was not solved successfully; - :e.info = 5: - if the Y-Riccati equation was not solved successfully. + SlycotArithmeticError + :info = 1: + if the matrix D12 had not full column rank in + respect to the tolerance tol; + :info = 2: + if the matrix D21 had not full row rank in respect + to the tolerance tol; + :info = 3: + if the singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices D12 or D21). + :info = 4: + if the X-Riccati equation was not solved successfully; + :info = 5: + if the Y-Riccati equation was not solved successfully. """ hidden = ' (hidden by the wrapper)' @@ -1713,6 +1632,13 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): D : rank-2 array('d') with bounds (np,m) The leading NP-by-M part of this array contains the matrix Dd of the converted system. + + Raises + ------ + SlycotArithmeticError + :info == 1: + The iteration for computing singular value + decomposition did not converge. """ hidden = ' (hidden by the wrapper)' @@ -1734,11 +1660,15 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): To solve for X either the generalized continuous-time Lyapunov equation + :: + T T op(A) X op(E) + op(E) X op(A) = SCALE * Y, (1) or the generalized discrete-time Lyapunov equation + :: + T T op(A) X op(A) - op(E) X op(E) = SCALE * Y, (2) @@ -1917,34 +1847,35 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): Raises ------ + SlycotArithmeticError + :info = 1: + FACT = 'F' and the matrix contained in the upper + Hessenberg part of the array A is not in upper + quasitriangular form; + :info = 2: + FACT = 'N' and the pencil A - lambda * E cannot be + reduced to generalized Schur form: LAPACK routine + DGEGS has failed to converge; - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - FACT = 'F' and the matrix contained in the upper - Hessenberg part of the array A is not in upper - quasitriangular form; - :e.info = 2: - FACT = 'N' and the pencil A - lambda * E cannot be - reduced to generalized Schur form: LAPACK routine - DGEGS has failed to converge; - :e.info = 3: - DICO = 'D' and the pencil A - lambda * E has a - pair of reciprocal eigenvalues. That is, lambda_i = - 1/lambda_j for some i and j, where lambda_i and - lambda_j are eigenvalues of A - lambda * E. Hence, - equation (2) is singular; perturbed values were - used to solve the equation (but the matrices A and - E are unchanged); - :e.info = 4: - DICO = 'C' and the pencil A - lambda * E has a - degenerate pair of eigenvalues. That is, lambda_i = - -lambda_j for some i and j, where lambda_i and - lambda_j are eigenvalues of A - lambda * E. Hence, - equation (1) is singular; perturbed values were - used to solve the equation (but the matrices A and - E are unchanged). + Warns + ----- + SlycotResultWarning + :info = 3: + DICO = 'D' and the pencil A - lambda * E has a + pair of reciprocal eigenvalues. That is, lambda_i = + 1/lambda_j for some i and j, where lambda_i and + lambda_j are eigenvalues of A - lambda * E. Hence, + equation (2) is singular; perturbed values were + used to solve the equation (but the matrices A and + E are unchanged); + :info = 4: + DICO = 'C' and the pencil A - lambda * E has a + degenerate pair of eigenvalues. That is, lambda_i = + -lambda_j for some i and j, where lambda_i and + lambda_j are eigenvalues of A - lambda * E. Hence, + equation (1) is singular; perturbed values were + used to solve the equation (but the matrices A and + E are unchanged). """ hidden = ' (hidden by the wrapper)' @@ -2261,42 +2192,43 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, 21 contained in DWORK(4). - iwarn : int - = 0: no warning; - = 1: the computed solution may be inaccurate due to poor - scaling or eigenvalues too close to the boundary of - the stability domain (the imaginary axis, if - DICO = 'C', or the unit circle, if DICO = 'D'). - - Raises ------ + SlycotArithmeticError + :info = 1: + The computed extended matrix pencil is singular, + possibly due to rounding errors + :info = 2: + The QZ algorithm failed + :info = 3: + Reordering of the generalized eigenvalues failed + :info = 4: + After reordering, roundoff changed values of + some complex eigenvalues so that leading eigenvalues + in the generalized Schur form no longer satisfy the + stability condition; this could also be caused due + to scaling + :info = 5: + The computed dimension of the solution does not + equal N + :info = 6: + The spectrum is too close to the boundary of + the stability domain + :info = 7: + A singular matrix was encountered during the + computation of the solution matrix X - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The computed extended matrix pencil is singular, - possibly due to rounding errors - :e.info = 2: - The QZ algorithm failed - :e.info = 3: - Reordering of the generalized eigenvalues failed - :e.info = 4: - After reordering, roundoff changed values of - some complex eigenvalues so that leading eigenvalues - in the generalized Schur form no longer satisfy the - stability condition; this could also be caused due - to scaling - :e.info = 5: - The computed dimension of the solution does not - equal N - :e.info = 6: - The spectrum is too close to the boundary of - the stability domain - :e.info = 7: - A singular matrix was encountered during the - computation of the solution matrix X + Warns + ----- + SlycotResultWarning + :iwarn = 1 and dico == 'C': + The computed solution may be inaccurate due to poor + scaling or eigenvalues too close to the boundary of + the imaginary axis. + :iwarn = 1 and dico == 'D': + The computed solution may be inaccurate due to poor + scaling or eigenvalues too close to the boundary of + the unit circle. """ hidden = ' (hidden by the wrapper)' @@ -2327,7 +2259,7 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, elif (fact == 'B'): out = _wrapper.sg02ad_bb(dico,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,tol,ldwork) - raise_if_slycot_error(out[-1], arg_list, sg02ad.__doc__) + raise_if_slycot_error(out[-2:], arg_list, sg02ad.__doc__, locals()) return out[:-1] @@ -2470,40 +2402,40 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): (alpha(j), j=1,...,n, are the eigenvalues of the matrix pencil A - lambda * E. - Raises - ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - the pencil A - lambda * E is (nearly) singular; - perturbed values were used to solve the equation - (but the reduced (quasi)triangular matrices A and E - are unchanged); - :e.info = 2: - fact = 'F' and the matrix contained in the upper - Hessenberg part of the array A is not in upper - quasitriangular form; - :e.info = 3: - fact = 'F' and there is a 2-by-2 block on the main - diagonal of the pencil A_s - lambda * E_s whose - eigenvalues are not conjugate complex; - :e.info = 4: - fact = 'N' and the pencil A - lambda * E cannot be - reduced to generalized Schur form: LAPACK routine - DGEGS (or DGGES) has failed to converge; - :e.info = 5: - dico = 'C' and the pencil A - lambda * E is not - c-stable; - :e.info = 6: - dico = 'D' and the pencil A - lambda * E is not - d-stable; - :e.info = 7: - the LAPACK routine DSYEVX utilized to factorize M3 - failed to converge in the discrete-time case (see - section METHOD for SLICOT Library routine SG03BU). - This error is unlikely to occur. + Raises + ------ + SlycotArithmeticError + :info = 2: + fact = 'F' and the matrix contained in the upper + Hessenberg part of the array A is not in upper + quasitriangular form; + :info = 3: + fact = 'F' and there is a 2-by-2 block on the main + diagonal of the pencil A_s - lambda * E_s whose + eigenvalues are not conjugate complex; + :info = 4: + fact = 'N' and the pencil A - lambda * E cannot be + reduced to generalized Schur form: LAPACK routine + DGEGS (or DGGES) has failed to converge; + :info = 5: + dico = 'C' and the pencil A - lambda * E is not + c-stable; + :info = 6: + dico = 'D' and the pencil A - lambda * E is not + d-stable; + :info = 7: + the LAPACK routine DSYEVX utilized to factorize M3 + failed to converge in the discrete-time case (see + section METHOD for SLICOT Library routine SG03BU). + This error is unlikely to occur. + Warns + ----- + SlycotResultWarning + :info = 1: + the pencil A - lambda * E is (nearly) singular; + perturbed values were used to solve the equation + (but the reduced (quasi)triangular matrices A and E + are unchanged); """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'fact', 'trans', 'n', 'm', 'A', 'LDA'+hidden, 'E', diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 8cb7ee13..01eb17e0 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -34,9 +34,9 @@ def assert_docstring_parse(docstring, exception_class, erange, checkvars={}): Documentation string with exception definitions exception_class: SlycotError or SlycotWarning Subclass of Slycot specific Errors or Warnings expected to raise - erange: int or iterable with int - Error numbers for which the documentation should have - exception text + erange: int or iterable with int or iterable of two-element iterables + of [IWARN, INFO] for which the documentation should have exception + text checkvars: dict, optional dict of variables for evaluation of and formatting the exception message @@ -48,14 +48,20 @@ def assert_docstring_parse(docstring, exception_class, erange, checkvars={}): except TypeError: pass - for info in erange: + for e in erange: + try: + iwarn, info = e + except TypeError: + iwarn = 0 + info = e if issubclass(exception_class, SlycotError): with pytest.raises(exception_class) as ex_info: - raise_if_slycot_error(info, [], docstring, checkvars) + raise_if_slycot_error(e, [], docstring, checkvars) assert ex_info.value.info == info elif issubclass(exception_class, SlycotWarning): with pytest.warns(exception_class) as wm: - raise_if_slycot_error(info, [], docstring, checkvars) + raise_if_slycot_error(e, [], docstring, checkvars) + assert wm[0].message.iwarn == iwarn assert wm[0].message.info == info else: raise RuntimeError("Invalid test exception") @@ -66,3 +72,9 @@ def test_standard_info_error(): with pytest.raises(SlycotParameterError) as ex_info: raise_if_slycot_error(-2, ["a", "b"]) assert ex_info.value.info == -2 + + +def test_unhandled_info(): + with pytest.raises(SlycotError) as ex_info: + raise_if_slycot_error(2, [], docstring="no valid docstring") + assert ex_info.value.info == 2 diff --git a/slycot/tests/test_mc.py b/slycot/tests/test_mc.py index 5e703f87..db02cedf 100644 --- a/slycot/tests/test_mc.py +++ b/slycot/tests/test_mc.py @@ -33,9 +33,18 @@ def test_mc01td_D(self): def test_mc01td_warnings(self): """ test_mc01td_warnings: Test warnings """ - T = [([0, 0], "entry P(x) is the zero polynomial."), - ([0, 1], "P(x) may have zeros very close to stability boundary."), - ([1, 0], "The degree of P(x) has been reduced to 0")] + T = [([0, 0], "\n" + "Entry ``P(x)`` is the zero polynomial."), + ([0, 1], "\n" + "The polynomial ``P(x)`` is most probably unstable,\n" + "although it may be stable with one or more zeros\n" + "very close to the imaginary axis.\n" + "The number of unstable zeros (NZ) is not determined."), + ([1, 0], "\n" + "The degree of the polynomial ``P(x)`` has been\n" + "reduced to ``(DB - 1)`` because\n" + "``P(DB+1-j) = 0.0`` on entry\n" + "for ``j = 0, 1,..., k-1`` and ``P(DB+1-k) <> 0.0``.")] for P, m in T: with warnings.catch_warnings(record=True) as w: (dp, stable, nz) = mc01td('C', len(P)-1, P) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 0e33c873..92bf68f7 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -105,21 +105,33 @@ def test_sb10jd(): @pytest.mark.parametrize( - 'fun, exception_class, erange, checkvars', - ( ( synthesis.sb01bd, SlycotArithmeticError, 4, {} ), - ( synthesis.sb02md, SlycotArithmeticError, 5, {} ), - ( synthesis.sb02od, SlycotArithmeticError, 6, {} ), - ( synthesis.sb03md, SlycotResultWarning, 3, { 'n': 2, 'dico': 'D'} ), - ( synthesis.sb03md, SlycotResultWarning, 3, { 'n': 2, 'dico': 'C'} ), - ( synthesis.sb03od, SlycotArithmeticError, 6, {} ), - ( synthesis.sb04md, SlycotArithmeticError, 2, { 'm': 1} ), - ( synthesis.sb04qd, SlycotArithmeticError, 3, { 'm': 2} ), - ( synthesis.sb10ad, SlycotArithmeticError, 12, {} ), - ( synthesis.sb10dd, SlycotArithmeticError, 9, {} ), - ( synthesis.sb10hd, SlycotArithmeticError, 4, {} ), - ( synthesis.sb10jd, SlycotArithmeticError, 0, {} ), - ( synthesis.sg03ad, SlycotArithmeticError, 4, {} ), - ( synthesis.sg02ad, SlycotArithmeticError, 7, {} ), - ( synthesis.sg03bd, SlycotArithmeticError, 7, {} ) ) ) + 'fun, exception_class, erange, checkvars', + ((synthesis.sb01bd, SlycotArithmeticError, 2, {}), + (synthesis.sb01bd, SlycotResultWarning, [3, 4, [1, 0]], {'nap': '1'}), + (synthesis.sb02md, SlycotArithmeticError, 5, {}), + (synthesis.sb02od, SlycotArithmeticError, 6, {}), + (synthesis.sb03md, SlycotResultWarning, 3, {'n': 2, + 'dico': 'D'}), + (synthesis.sb03md, SlycotResultWarning, 3, {'n': 2, + 'dico': 'C'}), + (synthesis.sb03od, SlycotResultWarning, [1, 2], {'dico': 'C', + 'fact': 'N'}), + (synthesis.sb03od, SlycotResultWarning, [1, 2], {'dico': 'D', + 'fact': 'N'}), + (synthesis.sb03od, SlycotArithmeticError, [3, 4, 5, 6], {'dico': 'D', + 'fact': 'F'}), + (synthesis.sb04md, SlycotArithmeticError, 2, {'m': 1}), + (synthesis.sb04qd, SlycotArithmeticError, 3, {'m': 2}), + (synthesis.sb10ad, SlycotArithmeticError, 12, {}), + (synthesis.sb10dd, SlycotArithmeticError, 9, {}), + (synthesis.sb10hd, SlycotArithmeticError, 4, {}), + (synthesis.sb10jd, SlycotArithmeticError, 0, {}), + (synthesis.sg02ad, SlycotArithmeticError, 7, {}), + (synthesis.sg02ad, SlycotResultWarning, [[1, 0]], {'dico': 'C'}), + (synthesis.sg02ad, SlycotResultWarning, [[1, 0]], {'dico': 'D'}), + (synthesis.sg03ad, SlycotArithmeticError, 2, {}), + (synthesis.sg03ad, SlycotResultWarning, [3, 4], {}), + (synthesis.sg03bd, SlycotResultWarning, 1, {}), + (synthesis.sg03bd, SlycotArithmeticError, range(2, 8), {}))) def test_sb_docparse(fun, exception_class, erange, checkvars): assert_docstring_parse(fun.__doc__, exception_class, erange, checkvars) diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index bc5b0b6f..275521df 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -172,15 +172,16 @@ def test_tb05ad_resonance(self): are parsed from the docstring, tests both the info index and the message """ - A = np.array([ [0, -1], [1, 0] ]) - B = np.array([ [1],[0] ]) - C = np.array([ [0, 1 ]]) + A = np.array([[0, -1], + [1, 0]]) + B = np.array([[1], + [0]]) + C = np.array([[0, 1]]) jomega = 1j - with self.assertRaises( + with self.assertRaisesRegex( SlycotArithmeticError, - msg="\n" - "Either FREQ is too near to an eigenvalue of A, or RCOND\n" - "is less than the machine precision EPS.") as cm: + r"Either `freq`.* is too near to an eigenvalue of A,\n" + r"or `rcond` is less than the machine precision EPS.") as cm: transform.tb05ad(2, 1, 1, jomega, A, B, C, job='NH') assert cm.exception.info == 2 diff --git a/slycot/transform.py b/slycot/transform.py index 14e78d40..8a80d763 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -98,8 +98,7 @@ def tb01id(n,m,p,maxred,a,b,c,job='A'): arg_list = ['job', 'N', 'M', 'P', 'maxred', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', 'LDC'+hidden, 'scale', 'INFO'+hidden] out = _wrapper.tb01id(n,m,p,maxred,a,b,c,job=job) - if out[-1] < 0: - raise raise_if_slycot_error(out[-1], arg_list) + raise_if_slycot_error(out[-1], arg_list) return out[:-1] def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): @@ -202,6 +201,16 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): The leading porm-by-nr-by-kpcoef part of this array contains the coefficients of the intermediate matrix V(s). vcoeff(i,j,k) is defined as for pcoeff(i,j,k). + Raises + ------ + SlycotArithmeticError + :info == 1: + A singular matrix was encountered during the + computation of V(s); + :info == 2: + A singular matrix was encountered during the + computation of P(s). + """ hidden = ' (hidden by the wrapper)' arg_list = ['leri', 'equil', 'n', 'm', 'P', 'A', 'LDA'+hidden, 'B', @@ -209,27 +218,18 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): 'pcoeff', 'LDPCO1'+hidden, 'LDPCO2'+hidden, 'qcoeff', 'LDQCO1'+hidden, 'LDQCO2'+hidden, 'vcoeff', 'LDVCO1'+hidden, 'LDVCO2'+hidden, 'tol', 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'INFO'+hidden] - if leri == 'L': - if ldwork is None: - ldwork = max( 2*n + 3*max(m,p), p*(p+2)) - out = _wrapper.tb03ad_l(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0: - raise SlycotArithmeticError( - 'a singular matrix was encountered during the computation', - out[-1]) - return out[:-1] - if leri == 'R': - if ldwork is None: - ldwork = max( 2*n + 3*max(m,p), m*(m+2)) - out = _wrapper.tb03ad_r(n,m,p,A,B,C,D,equil=equil,tol=tol,ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0: - raise SlycotArithmeticError( - 'a singular matrix was encountered during the computation', - out[-1]) - return out[:-1] - raise SlycotParameterError('leri must be either L or R', -1) + wfun = {"L": _wrapper.tb03ad_l, + "R": _wrapper.tb03ad_r} + mp_ = {"L": p, "R": m} + mp = mp_[leri] + if leri not in wfun.keys(): + raise SlycotParameterError('leri must be either L or R', -1) + if ldwork is None: + ldwork = max(2*n + 3*max(m, p), mp*(mp+2)) + out = wfun[leri](n, m, p, A, B, C, D, equil=equil, tol=tol, ldwork=ldwork) + raise_if_slycot_error(out[-1], arg_list) + return out[:-1] + def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): """ Ar,Br,Cr,nr,denom_degs,denom_coeffs,num_coeffs = tb04ad(n,m,p,A,B,C,D,[tol1,tol2,ldwork]) @@ -324,65 +324,57 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): To find the complex frequency response matrix (transfer matrix) G(freq) of the state-space representation (A,B,C) given by - -1 + + :: + + -1 G(freq) = C * ((freq*I - A) ) * B where A, B and C are real N-by-N, N-by-M and P-by-N matrices respectively and freq is a complex scalar. - Required Arguments - ------------------ - - n : integer - The number of states, i.e. the order of the state - transition matrix A. - - m : integer - The number of inputs, i.e. the number of columns in the - matrix B. - - p : integer - The number of outputs, i.e. the number of rows in the - matrix C. - - freq complex - The frequency freq at which the frequency response matrix - (transfer matrix) is to be evaluated. For continuous time - systems, this is j*omega, where omega is the frequency to - be evaluated. For discrete time systems, - freq = exp(j*omega*Ts) - - A : double precision array, dimension (n,n). - On entry, this array must contain the state transition - matrix A. - - - B : double precision array, dimension (n,m). - On entry, this array must contain the input/state matrix B. - - - C : double precision array, dimension (p,n) - On entry, of this array must contain the state/output matrix C. - - - job : string, 'AG', 'NG', or 'NH' - If job = 'AG' (i.e., 'all', 'general matrix'), the A matrix is - first balanced. The balancing transformation - is then appropriately applied to matrices B and C. The A matrix - is (again) transformed to an upper Hessenberg representation and - the B and C matrices are also transformed. In addition, - the condition number of the problem is calculated as well as the - eigenvalues of A. - - If job='NG' (i.e., 'none', 'general matrix'), no balancing is done. - Neither the condition number nor the eigenvalues are calculated. - The routine still transforms A into upper Hessenberg form. The - matrices B and C are also appropriately transformed. - - If job = 'NH' (i.e., 'none', 'hessenberg matrix'), the function - assumes the matrices have already been transformed into Hessenberg - form, i.e., by a previous function call tb05ad. If this not the - case, the routine will return a wrong result without warning. + Parameters + ---------- + n : int + The number of states, i.e. the order of the state + transition matrix A. + m : int + The number of inputs, i.e. the number of columns in the + matrix B. + p : int + The number of outputs, i.e. the number of rows in the + matrix C. + jomega : complex float + The frequency at which the frequency response matrix + (transfer matrix) is to be evaluated. For continuous time + systems, this is j*omega, where omega is the frequency to + be evaluated. For discrete time systems, + freq = exp(j*omega*Ts) + A : (n,n) ndarray + On entry, this array must contain the state transition + matrix A. + B : (n,m) ndarray + On entry, this array must contain the input/state matrix B. + C : (p,n) ndarray + On entry, of this array must contain the state/output matrix C. + job : {'AG', 'NG', 'NH'} + If job = 'AG' (i.e., 'all', 'general matrix'), the A matrix is + first balanced. The balancing transformation + is then appropriately applied to matrices B and C. The A matrix + is (again) transformed to an upper Hessenberg representation and + the B and C matrices are also transformed. In addition, + the condition number of the problem is calculated as well as the + eigenvalues of A. + + If job='NG' (i.e., 'none', 'general matrix'), no balancing is done. + Neither the condition number nor the eigenvalues are calculated. + The routine still transforms A into upper Hessenberg form. The + matrices B and C are also appropriately transformed. + + If job = 'NH' (i.e., 'none', 'hessenberg matrix'), the function + assumes the matrices have already been transformed into Hessenberg + form, i.e., by a previous function call tb05ad. If this not the + case, the routine will return a wrong result without warning. Returns ------- @@ -455,17 +447,13 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): Raises ------ - - SlycotParameterError : e - :e.info = -i: - the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - More than 30 iterations were required to isolate the - eigenvalues of A. The computations are continued. - :e.info = 2: - Either FREQ is too near to an eigenvalue of A, or RCOND - is less than the machine precision EPS. + SlycotArithmeticError + :info = 1: + More than {n30} (30*`n`) iterations were required to isolate the + eigenvalues of A. The computations are continued. + :info = 2: + Either `freq`={jomega} is too near to an eigenvalue of A, + or `rcond` is less than the machine precision EPS. Example ------- @@ -511,34 +499,32 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): # ---------------------------------------------------- # Checks done, do computation. + n30 = 30*n # for INFO = 1 error docstring if job == 'AG': out = _wrapper.tb05ad_ag(n, m, p, jomega, A, B, C) - raise_if_slycot_error(out[-1], arg_list, tb05ad.__doc__) - At, Bt, Ct, rcond, g_jw, evre, evim, hinvb = out[:-1] + At, Bt, Ct, rcond, g_jw, evre, evim, hinvb, info = out + raise_if_slycot_error(info, arg_list, tb05ad.__doc__, locals()) ev = _np.zeros(n, 'complex64') ev.real = evre ev.imag = evim - info = out[-1] return At, Bt, Ct, g_jw, rcond, ev, hinvb, info elif job == 'NG': # use tb05ad_ng, for 'NONE' , and 'General', because balancing # (option 'A' for 'ALL') seems to have a bug. out = _wrapper.tb05ad_ng(n, m, p, jomega, A, B, C) - raise_if_slycot_error(out[-1], arg_list, tb05ad.__doc__) - At, Bt, Ct, g_jw, hinvb = out[:-1] - info = out[-1] + At, Bt, Ct, g_jw, hinvb, info = out + raise_if_slycot_error(info, arg_list, tb05ad.__doc__, locals()) return At, Bt, Ct, g_jw, hinvb, info elif job == 'NH': out = _wrapper.tb05ad_nh(n, m, p, jomega, A, B, C) - raise_if_slycot_error(out[-1], arg_list, tb05ad.__doc__) - g_i, hinvb = out[:-1] - info = out[-1] + g_i, hinvb, info = out + raise_if_slycot_error(info, arg_list, tb05ad.__doc__, locals()) return g_i, hinvb, info else: raise SlycotParameterError("Unrecognized job. Expected job = 'AG' or " "job='NG' or job = 'NH' but received job={}" "".format(job), - -1) # job is baleig and inita together + -1) # job is baleig and inita together def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): @@ -547,64 +533,54 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): Convert a transfer function or matrix of transfer functions to a minimum state space realization. - Required arguments - ------------------ - - rowcol : character - indicates whether the transfer matrix T(s) is given - as rows ('R') or colums ('C') over common denominators. - m : integer - input dimension - p : integer - output dimension - index : rank-1 array, shape (p) or (m) - array of orders of the denominator polynomials. Different - shapes corresponding to rowcol=='R' and rowcol=='C' - respectively. - dcoeff : rank-2 array, shape (p,max(index)+1) or (m,max(index)+1) - array of denominator coefficients. Different shapes - corresponding to rowcol=='R' and rowcol=='C' respectively. - ucoeff : rank-3 array, shape (p,m,max(index)+1) or (max(p,m),max(p,m),max(index)+1) - array of numerator coefficients. Different shapes - corresponding to rowcol=='R' and rowcol=='C' respectively. - - Optional arguments - ------------------ - - tol : float - tolerance in determining the state space system, - when set to 0, a default value is used. - ldwork : int - The length of the cache array. The default values is - max(1,sum(index)+max(sum(index),max(3*m,3*p))) + Parameters + ---------- + rowcol : {R', 'C'} + indicates whether the transfer matrix T(s) is given + as rows ('R') or colums ('C') over common denominators. + m : int + input dimension + p : int + output dimension + index : (p,) or (m,) array_like + array of orders of the denominator polynomials. Different + shapes corresponding to rowcol=='R' and rowcol=='C' + respectively. + dcoeff : (p,max(index)+1) or (m,max(index)+1) ndarray + array of denominator coefficients. Different shapes + corresponding to rowcol=='R' and rowcol=='C' respectively. + ucoeff : (p,m,max(index)+1) or (max(p,m),max(p,m),max(index)+1) ndarray + array of numerator coefficients. Different shapes + corresponding to rowcol=='R' and rowcol=='C' respectively. + tol : float, optional + tolerance in determining the state space system, + when set to 0, a default value is used. + ldwork : int, optional + The length of the cache array. The default values is + max(1,sum(index)+max(sum(index),max(3*m,3*p))) Returns ------- - - nr : int - minimal state dimension - A : rank-2 array, shape(nr,nr) - state dynamics matrix. - B : rank-2 array, shape (nr,m) - input matrix - C : rank-2 array, shape (p,nr) - output matri - D : rank-2 array, shape (p,m) - direct transmission matrix + nr : int + minimal state dimension + A : (nr,nr) ndarray + state dynamics matrix. + B : (nr,m) ndarray + input matrix + C : (p,nr) ndarray + output matrix + D : (p,m) ndarray + direct transmission matrix Raises ------ - - SlycotParameterError : e - :e.info = -i: - the i-th argument had an illegal value; - SlycotArithmeticError : e - if e.info = i, then i is the first integer for which - abs( dcoeff(i,1) ) is so small that the calculations + SlycotArithmeticError + :info > 0: + i={info} is the first index of `dcoeff` for which + ``abs( dcoeff(i,1) )`` is so small that the calculations would overflow (see SLICOT Library routine TD03AY); that is, the leading coefficient of a polynomial is - nearly zero; no state-space representation is - calculated. + nearly zero; """ hidden = ' (hidden by the wrapper)' arg_list = ['rowcol','m','p','index','dcoeff','lddcoe'+hidden, 'ucoeff', 'lduco1'+hidden,'lduco2'+hidden, @@ -650,14 +626,7 @@ def td04ad(rowcol,m,p,index,dcoeff,ucoeff,tol=0.0,ldwork=None): else: raise SlycotParameterError("Parameter rowcol had an illegal value", -1) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] > 0: - raise SlycotArithmeticError( - "The leading coefficient of a denominator polynomial is nearly " - "zero; calculations would overflow; no state-space representation " - "was calculated. ABS(DCOEFF({},1))={} is too small." - "".format(out[-1],(abs(dcoeff[out[-1],1]))), - out[-1]) + raise_if_slycot_error(out[-1], arg_list, td04ad.__doc__) Nr, A, B, C, D = out[:-1] return Nr, A[:Nr,:Nr], B[:Nr,:m], C[:p,:Nr], D[:p,:m] @@ -735,28 +704,33 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): The leading p-by-m part of this array contains the direct transmission matrix D; the remainder of the leading max(m,p)-by-max(m,p) part is used as internal workspace. + Raises + ------ + SlycotArithmeticError + :info == 1 and leri = 'L': + P(s) is not row proper + :info == 1 and leri = 'R': + P(s) is not column proper """ hidden = ' (hidden by the wrapper)' - arg_list = ['leri', 'm', 'P', 'index', 'pcoeff', 'LDPCO1'+hidden, - 'LDPCO2'+hidden, 'qcoeff', 'LDQCO1'+hidden, 'LDQCO2'+hidden, 'N', 'rcond', - 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, - 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'INFO'+hidden] + arg_list = ['leri', 'm', 'P', 'index', + 'pcoeff', 'LDPCO1' + hidden, 'LDPCO2' + hidden, + 'qcoeff', 'LDQCO1' + hidden, 'LDQCO2' + hidden, + 'N', 'rcond', + 'A', 'LDA' + hidden, 'B', 'LDB' + hidden, + 'C', 'LDC' + hidden, 'D', 'LDD' + hidden, + 'IWORK' + hidden, 'DWORK' + hidden, 'ldwork', + 'INFO' + hidden] if ldwork is None: - ldwork = max(m,p)*(max(m,p)+4) + ldwork = max(m, p)*(max(m, p)+4) n = sum(index) - if leri == 'L': - out = _wrapper.tc04ad_l(m,p,index,pcoeff,qcoeff,n) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError('P(s) is not row proper', out[-1]) - return out[:-1] - if leri == 'R': - out = _wrapper.tc04ad_r(m,p,index,pcoeff,qcoeff,n) - raise_if_slycot_error(out[-1], arg_list) - if out[-1] == 1: - raise SlycotArithmeticError('P(s) is not column proper', out[-1]) - return out[:-1] - raise SlycotParameterError('leri must be either L or R', -1) + wfun = {"L": _wrapper.tc04ad_l, "R": _wrapper.tc04ad_r} + if leri not in wfun.keys(): + raise SlycotParameterError('leri must be either L or R', -1) + out = wfun[leri](m, p, index, pcoeff, qcoeff, n) + raise_if_slycot_error(out[-1], arg_list, tc04ad.__doc__, locals()) + return out[:-1] + def tc01od(m,p,indlin,pcoeff,qcoeff,leri): """ pcoeff,qcoeff = tc01od_l(m,p,indlim,pcoeff,qcoeff,leri) @@ -1071,15 +1045,8 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): hidden = ' (hidden by the wrapper)' arg_list = ['job', 'l', 'n', 'm', 'p', 'thresh', 'A', 'lda'+hidden, 'E','lde'+hidden,'B','ldb'+hidden,'C','ldc'+hidden, 'lscale', 'rscale', 'dwork'+hidden, 'info'] - if job != 'A' and job != 'B' and job != 'C' and job != 'N': - raise SlycotParameterError('Parameter job had an illegal value', -1) - A,E,B,C,lscale,rscale,info = _wrapper.tg01ad(job,l,n,m,p,thresh,A,E,B,C) - raise_if_slycot_error(info, arg_list) - if info != 0: - raise SlycotArithmeticError('tg01ad failed', info) - return A,E,B,C,lscale,rscale def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): @@ -1260,12 +1227,10 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld elif compq == 'U' and compz == 'U': A,E,B,C,Q,Z,ranke,rnka22,info = _wrapper.tg01fd_uu(joba,l,n,m,p,A,E,B,C,Q,Z,tol,ldwork) else: - raise SlycotParameterError( - "The combination of compq and compz is not implemented", -1) + raise NotImplementedError( + "The combination of compq and compz is not implemented") raise_if_slycot_error(info, arg_list) - if info != 0: - raise SlycotArithmeticError('tg01fd failed', info) if joba == 'N': rnka22 = None From 18f054e20bc2984616af0caff45eb55ec1efc549 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 04:17:37 +0200 Subject: [PATCH 180/405] more cleanup, including file attributes for source files --- slycot/analysis.py | 132 +++++++++++++++++++-------------------- slycot/exceptions.py | 0 slycot/math.py | 6 +- slycot/src/AB08MZ.f | 0 slycot/src/AB08NZ.f | 0 slycot/src/AB8NXZ.f | 0 slycot/src/AG08BZ.f | 0 slycot/src/AG8BYZ.f | 0 slycot/src/MA02BZ.f | 0 slycot/src/MA02CZ.f | 0 slycot/src/MA02ID.f | 0 slycot/src/MA02JD.f | 0 slycot/src/MB01MD.f | 0 slycot/src/MB01ND.f | 0 slycot/src/MB01UX.f | 0 slycot/src/MB03TD.f | 0 slycot/src/MB03TS.f | 0 slycot/src/MB03WA.f | 0 slycot/src/MB03XD.f | 0 slycot/src/MB03XP.f | 0 slycot/src/MB03XU.f | 0 slycot/src/MB03YA.f | 0 slycot/src/MB03YD.f | 0 slycot/src/MB03YT.f | 0 slycot/src/MB03ZA.f | 0 slycot/src/MB03ZD.f | 0 slycot/src/MB04DD.f | 0 slycot/src/MB04DI.f | 0 slycot/src/MB04DS.f | 0 slycot/src/MB04IZ.f | 0 slycot/src/MB04PA.f | 0 slycot/src/MB04PB.f | 0 slycot/src/MB04PU.f | 0 slycot/src/MB04QB.f | 0 slycot/src/MB04QC.f | 0 slycot/src/MB04QF.f | 0 slycot/src/MB04QU.f | 0 slycot/src/MB04TB.f | 0 slycot/src/MB04TS.f | 0 slycot/src/MB04WD.f | 0 slycot/src/MB04WP.f | 0 slycot/src/MB04WR.f | 0 slycot/src/MB04WU.f | 0 slycot/src/MB3OYZ.f | 0 slycot/src/MB3PYZ.f | 0 slycot/src/SB04OW.f | 0 slycot/src/TB01IZ.f | 0 slycot/src/TB01XZ.f | 0 slycot/src/TG01AZ.f | 0 slycot/src/TG01FZ.f | 0 slycot/src/UD01MZ.f | 0 slycot/src/UE01MD.f | 0 slycot/synthesis.py | 15 ++--- slycot/tests/__init__.py | 0 54 files changed, 71 insertions(+), 82 deletions(-) mode change 100755 => 100644 slycot/exceptions.py mode change 100755 => 100644 slycot/src/AB08MZ.f mode change 100755 => 100644 slycot/src/AB08NZ.f mode change 100755 => 100644 slycot/src/AB8NXZ.f mode change 100755 => 100644 slycot/src/AG08BZ.f mode change 100755 => 100644 slycot/src/AG8BYZ.f mode change 100755 => 100644 slycot/src/MA02BZ.f mode change 100755 => 100644 slycot/src/MA02CZ.f mode change 100755 => 100644 slycot/src/MA02ID.f mode change 100755 => 100644 slycot/src/MA02JD.f mode change 100755 => 100644 slycot/src/MB01MD.f mode change 100755 => 100644 slycot/src/MB01ND.f mode change 100755 => 100644 slycot/src/MB01UX.f mode change 100755 => 100644 slycot/src/MB03TD.f mode change 100755 => 100644 slycot/src/MB03TS.f mode change 100755 => 100644 slycot/src/MB03WA.f mode change 100755 => 100644 slycot/src/MB03XD.f mode change 100755 => 100644 slycot/src/MB03XP.f mode change 100755 => 100644 slycot/src/MB03XU.f mode change 100755 => 100644 slycot/src/MB03YA.f mode change 100755 => 100644 slycot/src/MB03YD.f mode change 100755 => 100644 slycot/src/MB03YT.f mode change 100755 => 100644 slycot/src/MB03ZA.f mode change 100755 => 100644 slycot/src/MB03ZD.f mode change 100755 => 100644 slycot/src/MB04DD.f mode change 100755 => 100644 slycot/src/MB04DI.f mode change 100755 => 100644 slycot/src/MB04DS.f mode change 100755 => 100644 slycot/src/MB04IZ.f mode change 100755 => 100644 slycot/src/MB04PA.f mode change 100755 => 100644 slycot/src/MB04PB.f mode change 100755 => 100644 slycot/src/MB04PU.f mode change 100755 => 100644 slycot/src/MB04QB.f mode change 100755 => 100644 slycot/src/MB04QC.f mode change 100755 => 100644 slycot/src/MB04QF.f mode change 100755 => 100644 slycot/src/MB04QU.f mode change 100755 => 100644 slycot/src/MB04TB.f mode change 100755 => 100644 slycot/src/MB04TS.f mode change 100755 => 100644 slycot/src/MB04WD.f mode change 100755 => 100644 slycot/src/MB04WP.f mode change 100755 => 100644 slycot/src/MB04WR.f mode change 100755 => 100644 slycot/src/MB04WU.f mode change 100755 => 100644 slycot/src/MB3OYZ.f mode change 100755 => 100644 slycot/src/MB3PYZ.f mode change 100755 => 100644 slycot/src/SB04OW.f mode change 100755 => 100644 slycot/src/TB01IZ.f mode change 100755 => 100644 slycot/src/TB01XZ.f mode change 100755 => 100644 slycot/src/TG01AZ.f mode change 100755 => 100644 slycot/src/TG01FZ.f mode change 100755 => 100644 slycot/src/UD01MZ.f mode change 100755 => 100644 slycot/src/UE01MD.f mode change 100755 => 100644 slycot/tests/__init__.py diff --git a/slycot/analysis.py b/slycot/analysis.py index 2378a9d8..cb633e51 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -803,7 +803,7 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): arg_list = ['dico', 'job', 'ordsel', 'n', 'm', 'p', 'nr', 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, 'hsv', 'T', 'ldt' + hidden, 'Ti', 'ldti' + hidden, 'tol', - 'iwork'+hidden, 'dwork'+hidden, 'ldwork', 'iwarn', 'info'] + 'iwork' + hidden, 'dwork' + hidden, 'ldwork', 'iwarn', 'info'] if ldwork is None: ldwork = max(1, n*(2*n + max(n, max(m, p))+5)+n*(n+1)/2) if nr is None: @@ -922,7 +922,7 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): Raises ------ - SlycotArithmeticError : e + SlycotArithmeticError :info == 1: The reduction of A to the real Schur form failed :info == 2 and dico == 'C': @@ -934,7 +934,7 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): Warns ----- - SlycotResultWarning : e + SlycotResultWarning :iwarn == 1: The selected order {nr} is greater than the order of a minimal realization of the @@ -1304,47 +1304,42 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): a discrete-time system. If the H2-norm is computed, the system must be stable. - Required arguments - ------------------ - - dico : {'D', 'C'} input string(len=1) - Indicate whether the system is discrete 'D' or continuous 'C'. - jobn : {'H', 'L'} input string(len=1) - H2-norm 'H' or L2-norm 'L' to be computed. - n : input int - The number of state variables. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state - dynamics matrix A of the system. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input/state - matrix B of the system. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the state/output - matrix C of the system. - D : input rank-2 array('d') with bounds (p,m) - The leading p-by-m part of this array must contain the direct - transmission matrix D of the system. - - Optional arguments - ------------------ - - tol : The absolute tolerance level below which the elements of - B are considered zero (used for controllability tests). - If the user sets tol <= 0, then an implicitly computed, - default tolerance, defined by toldef = n*eps*norm(B), - is used instead, where eps is the machine precision - (see LAPACK Library routine DLAMCH) and norm(B) denotes - the 1-norm of B. + Parameters + ---------- + dico : {'D', 'C'} + Indicate whether the system is discrete 'D' or continuous 'C'. + jobn : {'H', 'L'} + H2-norm 'H' or L2-norm 'L' to be computed. + n : int + The number of state variables. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n,n) ndarray + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system. + B : (n,m) ndarray + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : (p,n) ndarray + The leading p-by-n part of this array must contain the state/output + matrix C of the system. + D : (p,m) ndarray + The leading p-by-m part of this array must contain the direct + transmission matrix D of the system. + tol : float, optional + The absolute tolerance level below which the elements of + B are considered zero (used for controllability tests). + If the user sets tol <= 0, then an implicitly computed, + default tolerance, defined by toldef = n*eps*norm(B), + is used instead, where eps is the machine precision + (see LAPACK Library routine DLAMCH) and norm(B) denotes + the 1-norm of B. Returns ------- - - norm: H2 or L2 norm of thes ystem (A,B,C,D) + norm: H2 or L2 norm of the system (A,B,C,D) Raises ------ @@ -1493,9 +1488,9 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): if jobd != 'D' and jobd != 'Z': raise SlycotParameterError('jobd must be "D" or "Z"', -4) out = _wrapper.ab13dd(dico, jobe, equil, jobd, - n, m, p, [0.0, 1.0], A, E, B, C, D, tol) + n, m, p, [0.0, 1.0], A, E, B, C, D, tol) raise_if_slycot_error(out[-1], arg_list, ab13dd.__doc__) - + fpeak = out[0][0] if out[0][1] > 0 else float('inf') gpeak = out[1][0] if out[1][1] > 0 else float('inf') return gpeak, fpeak @@ -1509,15 +1504,15 @@ def ab13ed(n, A, tol = 9.0): the nearest complex matrix with an eigenvalue on the imaginary axis. The estimate is given as - low <= beta(A) <= high, + ``low <= beta(A) <= high,`` where either - (1 + tol) * low >= high, + ``(1 + tol) * low >= high,`` or - low = 0 and high = delta, + ``low = 0 and high = delta,`` and delta is a small number approximately equal to the square root of machine precision times the Frobenius norm (Euclidean norm) @@ -1526,32 +1521,30 @@ def ab13ed(n, A, tol = 9.0): to the nearest unstable complex matrix, i.e., the complex stability radius. - Required arguments: - n : input int - The order of the matrix A. n >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the matrix A. - - Optional arguments: - tol : Specifies the accuracy with which low and high approximate - beta(A). If the user sets tol to be less than sqrt(eps), - where eps is the machine precision (see LAPACK Library - Routine DLAMCH), then the tolerance is taken to be - sqrt(eps). - The recommended value is tol = 9, which gives an estimate - of beta(A) correct to within an order of magnitude. + Parameters + ---------- + n : int + The order of the matrix A. ``n >= 0.`` + A : (n,n) array_like + The leading n-by-n part of this array must contain the matrix A. + tol : float optional + Specifies the accuracy with which low and high approximate + beta(A). If the user sets tol to be less than sqrt(eps), + where eps is the machine precision (see LAPACK Library + Routine DLAMCH), then the tolerance is taken to be + sqrt(eps). + The recommended value is tol = 9, which gives an estimate + of beta(A) correct to within an order of magnitude. - Return objects: - low : float - A lower bound for beta(A). - high : float - An upper bound for beta(A). + Returns + ------- + low : float + A lower bound for beta(A). + high : float + An upper bound for beta(A). Raises ------ - - SlycotParameterError - :info = -i: the i-th argument had an illegal value; SlycotArithmeticError :info = 1: The QR algorithm fails to converge @@ -1559,7 +1552,7 @@ def ab13ed(n, A, tol = 9.0): hidden = ' (hidden by the wrapper)' arg_list = ['n', 'A', 'lda' + hidden, 'low' + hidden, 'high' + hidden, 'tol', 'dwork' + hidden, 'ldwork' + hidden, 'info' + hidden] - out = _wrapper.ab13ed(n, A, tol) + out = _wrapper.ab13ed(n, A, tol) raise_if_slycot_error(out[-1], arg_list, ab13ed.__doc__) return out[:-1] @@ -1616,6 +1609,7 @@ def ab13fd(n, A, tol = 0.0): SlycotArithmeticError :info = 2: Either the QR or SVD algorithm fails to converge + Warns ----- SlycotResultWarning diff --git a/slycot/exceptions.py b/slycot/exceptions.py old mode 100755 new mode 100644 diff --git a/slycot/math.py b/slycot/math.py index 57d4f22d..f2c32062 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -183,8 +183,8 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): **Numerical Aspects** - The algorithm usually requires :math:`\mathcal{O}(N^3)` operations, - but :math:`\mathcal{O}(N^4)` are + The algorithm usually requires :math:`\\mathcal{O}(N^3)` operations, + but :math:`\\mathcal{O}(N^4)` are possible in the worst case, when all diagonal blocks in the real Schur form of `A` are 1-by-1, and the matrix cannot be diagonalized by well-conditioned transformations. @@ -206,7 +206,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): **Revisions** - \V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. + \\V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. References ---------- diff --git a/slycot/src/AB08MZ.f b/slycot/src/AB08MZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/AB08NZ.f b/slycot/src/AB08NZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/AB8NXZ.f b/slycot/src/AB8NXZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/AG08BZ.f b/slycot/src/AG08BZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/AG8BYZ.f b/slycot/src/AG8BYZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/MA02BZ.f b/slycot/src/MA02BZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/MA02CZ.f b/slycot/src/MA02CZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/MA02ID.f b/slycot/src/MA02ID.f old mode 100755 new mode 100644 diff --git a/slycot/src/MA02JD.f b/slycot/src/MA02JD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB01MD.f b/slycot/src/MB01MD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB01ND.f b/slycot/src/MB01ND.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB01UX.f b/slycot/src/MB01UX.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03TD.f b/slycot/src/MB03TD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03TS.f b/slycot/src/MB03TS.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03WA.f b/slycot/src/MB03WA.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03XD.f b/slycot/src/MB03XD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03XP.f b/slycot/src/MB03XP.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03XU.f b/slycot/src/MB03XU.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03YA.f b/slycot/src/MB03YA.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03YD.f b/slycot/src/MB03YD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03YT.f b/slycot/src/MB03YT.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03ZA.f b/slycot/src/MB03ZA.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB03ZD.f b/slycot/src/MB03ZD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04DD.f b/slycot/src/MB04DD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04DI.f b/slycot/src/MB04DI.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04DS.f b/slycot/src/MB04DS.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04IZ.f b/slycot/src/MB04IZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04PA.f b/slycot/src/MB04PA.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04PB.f b/slycot/src/MB04PB.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04PU.f b/slycot/src/MB04PU.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04QB.f b/slycot/src/MB04QB.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04QC.f b/slycot/src/MB04QC.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04QF.f b/slycot/src/MB04QF.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04QU.f b/slycot/src/MB04QU.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04TB.f b/slycot/src/MB04TB.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04TS.f b/slycot/src/MB04TS.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04WD.f b/slycot/src/MB04WD.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04WP.f b/slycot/src/MB04WP.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04WR.f b/slycot/src/MB04WR.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB04WU.f b/slycot/src/MB04WU.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB3OYZ.f b/slycot/src/MB3OYZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/MB3PYZ.f b/slycot/src/MB3PYZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/SB04OW.f b/slycot/src/SB04OW.f old mode 100755 new mode 100644 diff --git a/slycot/src/TB01IZ.f b/slycot/src/TB01IZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/TB01XZ.f b/slycot/src/TB01XZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/TG01AZ.f b/slycot/src/TG01AZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/TG01FZ.f b/slycot/src/TG01FZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/UD01MZ.f b/slycot/src/UD01MZ.f old mode 100755 new mode 100644 diff --git a/slycot/src/UE01MD.f b/slycot/src/UE01MD.f old mode 100755 new mode 100644 diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 462650a2..455bcb2e 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -768,11 +768,6 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): w : rank-1 array('c'), shape (n) If fact = 'N', this array contain the eigenvalues of A. - Raises - ------ - SlycotParameterError - :info = -i: the i-th argument had an illegal value; - Warns ----- SlycotResultWarning @@ -1549,19 +1544,19 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): ------ SlycotArithmeticError :info = 1: - if the matrix D12 had not full column rank in + The matrix D12 had not full column rank in respect to the tolerance tol; :info = 2: - if the matrix D21 had not full row rank in respect + The matrix D21 had not full row rank in respect to the tolerance tol; :info = 3: - if the singular value decomposition (SVD) algorithm + The singular value decomposition (SVD) algorithm did not converge (when computing the SVD of one of the matrices D12 or D21). :info = 4: - if the X-Riccati equation was not solved successfully; + The X-Riccati equation was not solved successfully; :info = 5: - if the Y-Riccati equation was not solved successfully. + The Y-Riccati equation was not solved successfully. """ hidden = ' (hidden by the wrapper)' diff --git a/slycot/tests/__init__.py b/slycot/tests/__init__.py old mode 100755 new mode 100644 From a44c9526260ad21637841bf8bad247c934cceb3c Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 04:23:28 +0200 Subject: [PATCH 181/405] dont assertRaisesRegex in Py2 --- slycot/tests/test_tb05ad.py | 2 ++ 1 file changed, 2 insertions(+) diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index 275521df..e64f7360 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -4,6 +4,7 @@ from slycot import transform from slycot.exceptions import SlycotArithmeticError, SlycotParameterError +import sys import numpy as np import unittest @@ -165,6 +166,7 @@ def check_tb05ad_errors(self, sys): n, m, p, jomega, sys['A'], sys['B'], sys['C'], job='a') assert cm.exception.info == -1 + @unittest.skipIf(sys.version < "3", "no assertRaisesRegex in old Python") def test_tb05ad_resonance(self): """ Test tb05ad resonance failure. From d81c7d1c01d03c935853e638104c075a8d01ddab Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 7 May 2020 15:05:38 +0200 Subject: [PATCH 182/405] optional type --- slycot/math.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/math.py b/slycot/math.py index f2c32062..b95245bf 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -498,7 +498,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): transformations accumulated by SLICOT Library routine MB03VY. If compz = 'I', Q is ignored - ldwork : int, optinal + ldwork : int, optional The length of the cache array. The default value is ihi-ilo+p-1 From ad241931e72845a093339ba5bf0dd7a559ef369b Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 7 May 2020 15:06:06 +0200 Subject: [PATCH 183/405] typo in range [skip ci] --- slycot/math.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/math.py b/slycot/math.py index b95245bf..bf2c8801 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -534,7 +534,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): :info > 0: failed to compute all the eigenvalues {ilo} to {ihi} in a total of 30*({ihi}-{ilo}+1) iterations - the elements Wr{{info}:{ihi}] contains those + the elements Wr[{info}:{ihi}] contains those eigenvalues which have been successfully computed. """ hidden = ' (hidden by the wrapper)' From ec8c96847539271e5dbe51222e748eb062e884bf Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 16:55:58 +0200 Subject: [PATCH 184/405] only parse docstring when iwarn or info catch all unhandled warnings clean imports --- slycot/analysis.py | 4 +--- slycot/exceptions.py | 15 ++++++++++----- slycot/math.py | 4 +--- slycot/synthesis.py | 5 ++--- slycot/tests/test_exceptions.py | 11 ++++++++++- slycot/transform.py | 3 +-- 6 files changed, 25 insertions(+), 17 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index cb633e51..aacc0c8f 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -18,10 +18,8 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import raise_if_slycot_error, \ - SlycotParameterError, SlycotArithmeticError +from .exceptions import raise_if_slycot_error, SlycotParameterError -import warnings def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): """ Ac,Bc,ncont,indcon,nblk,Z,tau = ab01nd_i(n,m,A,B,[jobz,tol,ldwork]) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 1f85679f..3e789a04 100644 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -221,13 +221,12 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): iwarn, info = info except TypeError: iwarn = None - if docstring: - # possibly override with mandatory argument + if docstring and (iwarn or info): + # possibly override info with mandatory argument checkvars['info'] = info - if iwarn is not None: # do not possibly override if not provided + # do not possibly override iwarn if not provided + if iwarn is not None: checkvars['iwarn'] = iwarn - else: - iwarn = 0 exception, message = _parse_docsection("Raises", docstring, checkvars) if exception and message: @@ -250,3 +249,9 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): raise SlycotError("Caught unhandled nonzero INFO value {}" .format(info), info) + if not iwarn and 'iwarn' in checkvars: + iwarn = checkvars['iwarn'] + if iwarn: + warn(SlycotWarning("Caught unhandled nonzero IWARN value {}" + .format(iwarn), + iwarn, info)) diff --git a/slycot/math.py b/slycot/math.py index bf2c8801..06e24548 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -18,9 +18,7 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import raise_if_slycot_error, SlycotArithmeticError - -import warnings +from .exceptions import raise_if_slycot_error import numpy as np diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 455bcb2e..9b5c2769 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -20,11 +20,10 @@ from . import _wrapper -from .exceptions import raise_if_slycot_error, \ - SlycotParameterError, SlycotArithmeticError +from .exceptions import raise_if_slycot_error, SlycotParameterError import numpy as _np -import warnings + def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): """ A_z,w,nfp,nap,nup,F,Z = sb01bd(n,m,np,alpha,A,B,w,dico,[tol,ldwork]) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 01eb17e0..178c0422 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -52,7 +52,7 @@ def assert_docstring_parse(docstring, exception_class, erange, checkvars={}): try: iwarn, info = e except TypeError: - iwarn = 0 + iwarn = None info = e if issubclass(exception_class, SlycotError): with pytest.raises(exception_class) as ex_info: @@ -78,3 +78,12 @@ def test_unhandled_info(): with pytest.raises(SlycotError) as ex_info: raise_if_slycot_error(2, [], docstring="no valid docstring") assert ex_info.value.info == 2 + with pytest.warns(SlycotWarning) as wm: + raise_if_slycot_error([1, 0], [], docstring="no valid docstring") + assert wm[0].message.iwarn == 1 + assert wm[0].message.info == 0 + with pytest.warns(SlycotWarning) as wm: + raise_if_slycot_error(0, [], docstring="no valid docstring", + checkvars={'iwarn': 1}) + assert wm[0].message.iwarn == 1 + assert wm[0].message.info == 0 diff --git a/slycot/transform.py b/slycot/transform.py index 8a80d763..a3d298f9 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -18,8 +18,7 @@ # MA 02110-1301, USA. from . import _wrapper -from .exceptions import raise_if_slycot_error, \ - SlycotParameterError, SlycotArithmeticError +from .exceptions import raise_if_slycot_error, SlycotParameterError import numpy as _np From c0b1069a988e661a4b250578df98554fa9c7b446 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 18:49:33 +0200 Subject: [PATCH 185/405] bring synthesis.py closer to numpydoc --- slycot/synthesis.py | 2568 +++++++++++++++++++++---------------------- 1 file changed, 1284 insertions(+), 1284 deletions(-) mode change 100644 => 100755 slycot/synthesis.py diff --git a/slycot/synthesis.py b/slycot/synthesis.py old mode 100644 new mode 100755 index 9b5c2769..9ebed7d5 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -31,74 +31,68 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): To determine the state feedback matrix F for a given system (A,B) such that the closed-loop state matrix A+B*F has specified eigenvalues. - Required arguments - ------------------ - - n : int - The dimension of the state vector, n >= 0. - m : int - The dimension of input vector, m >= 0. - np : int - The number of given eigenvalues. At most n eigenvalues can be - assigned. 0 <= np <= n. - alpha : float - Specifies the maximum admissible value, either for real parts, - if dico = 'C', or for moduli, if dico = 'D', of the eigenvalues of - A which will not be modified by the eigenvalue assignment algorithm. - alpha >= 0 if dico = 'D'. - A : rank-2 array('d'), shape (n,n) - State dynamics matrix. - B : rank-2 array('d'), shape (n,m) - Input/state matrix. - w : rank-1 array('c'), shape (np,) - Array of the desired eigenvalues of the closed-loop system state-matrix - A+B*F. The eigenvalues can be unordered, except that complex conjugate - pairs must appear consecutively. - dico : {'C', 'D'} - Specifies the type of the original system as follows: - = 'C': continuous-time system; - = 'D': discrete-time system. - - Optional arguments - ------------------ - - tol : float + Parameters + ---------- + n : int + The dimension of the state vector, n >= 0. + m : int + The dimension of input vector, m >= 0. + np : int + The number of given eigenvalues. At most n eigenvalues can be + assigned. 0 <= np <= n. + alpha : float + Specifies the maximum admissible value, either for real parts, + if dico = 'C', or for moduli, if dico = 'D', of the eigenvalues of + A which will not be modified by the eigenvalue assignment algorithm. + alpha >= 0 if dico = 'D'. + A : (n, n) array_like + State dynamics matrix. + B : (n, m) array_like + Input/state matrix. + w : (np, ) complex array_like + Array of the desired eigenvalues of the closed-loop system state-matrix + A+B*F. The eigenvalues can be unordered, except that complex conjugate + pairs must appear consecutively. + dico : {'C', 'D'} + Specifies the type of the original system as follows: + := 'C': continuous-time system; + := 'D': discrete-time system. + tol : float, optional The absolute tolerance level below which the elements of A or B are considered zero (used for controllability tests). If tol <= 0 the default value is used. - ldwork : int - The length of the cache array. The default value is - max(1,5*m,5*n,2*n+4*m), for optimum performance it should be larger. + ldwork : int, optional + The length of the cache array. The default value is + max(1,5*m,5*n,2*n+4*m), for optimum performance it should be larger. Returns ------- - - A_z : rank-2 array('d'), shape (n,n) - This array contains the matrix Z'*(A+B*F)*Z in a real Schur form. - The diagonal block A[:nfp,:nfp] corresponds to the fixed (unmodified) - eigenvalues having real parts less than alpha, if dico = 'C', or moduli - less than alpha if dico = 'D'. - The diagonal block A[n-nup:,n-nup:] corresponds to the uncontrollable - eigenvalues detected by the eigenvalue assignment algorithm. - The elements under the first subdiagonal are set to zero. - w : rank-1 array('c'), shape (np,) - The first part w[:nap] contain the assigned eigenvalues. - The rest w[np-nap:] contain the unassigned eigenvalues. - nfp : int - The number of eigenvalues of A having real parts less than alpha, - if dico = 'C', or moduli less than alpha, if dico = 'D'. These - eigenvalues are not modified by the eigenvalue assignment algorithm. - nap : int - The number of assigned eigenvalues. - nup : int - The number of uncontrollable eigenvalues detected by the eigenvalue - assignment algorithm. - F : rank-2 array('d'), shape (m,n) - The state feedback F, which assigns nap closed-loop eigenvalues and - keeps unaltered n-nap open-loop eigenvalues. - Z : rank-2 array('d'), shape (n,n) - The orthogonal matrix Z which reduces the closed-loop system state - matrix A + B*F to upper real Schur form. + A_z : (n, n) ndarray + This array contains the matrix Z'*(A+B*F)*Z in a real Schur form. + The diagonal block A[:nfp, :nfp] corresponds to the fixed (unmodified) + eigenvalues having real parts less than alpha, if dico = 'C', or moduli + less than alpha if dico = 'D'. + The diagonal block A[n-nup:, n-nup:] corresponds to the uncontrollable + eigenvalues detected by the eigenvalue assignment algorithm. + The elements under the first subdiagonal are set to zero. + w : (np, ) complex ndarray + The first part w[:nap] contain the assigned eigenvalues. + The rest w[np-nap:] contain the unassigned eigenvalues. + nfp : int + The number of eigenvalues of A having real parts less than alpha, + if dico = 'C', or moduli less than alpha, if dico = 'D'. These + eigenvalues are not modified by the eigenvalue assignment algorithm. + nap : int + The number of assigned eigenvalues. + nup : int + The number of uncontrollable eigenvalues detected by the eigenvalue + assignment algorithm. + F : (m, n) ndarray + The state feedback F, which assigns nap closed-loop eigenvalues and + keeps unaltered n-nap open-loop eigenvalues. + Z : (n, n) ndarray + The orthogonal matrix Z which reduces the closed-loop system state + matrix A + B*F to upper real Schur form. Raises ------ @@ -110,6 +104,7 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): real Schur form of A, or in the iterative process for reordering the eigenvalues of Z'*(A + B*F)*Z along the diagonal. + Warns ----- SlycotResultWarning @@ -136,13 +131,13 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): >>> import numpy as np >>> import slycot - >>> A = np.array([[0, 1, 0],[0, 0, 1],[-2, 1, 3]]) + >>> A = np.array([[0, 1, 0], [0, 0, 1], [-2, 1, 3]]) >>> B = np.array([[0], [0], [1]]) >>> np.linalg.eig(A)[0] # open loop eigenvalues array([ 3.11490754, 0.74589831, -0.86080585]) - >>> w = np.array([0.5,0.4,0.2]) - >>> out = slycot.sb01bd(3,1,3,1,A,B,w,'D') - >>> A_fb = A + np.dot(B,out[5]) + >>> w = np.array([0.5, 0.4, 0.2]) + >>> out = slycot.sb01bd(3, 1, 3, 1, A, B, w, 'D') + >>> A_fb = A + np.dot(B, out[5]) >>> np.linalg.eig(A_fb)[0] # closed loop eigenvalues array([ 0.2 , 0.40000001, 0.5 ]) """ @@ -170,20 +165,28 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): To solve for X either the continuous-time algebraic Riccati equation + + :: + -1 Q + A'*X + X*A - X*B*R B'*X = 0 (1) or the discrete-time algebraic Riccati equation + + :: + -1 X = A'*X*A - A'*X*B*(R + B'*X*B) B'*X*A + Q (2) where A, B, Q and R are n-by-n, n-by-m, n-by-n and m-by-m matrices respectively, with Q symmetric and R symmetric nonsingular; X is an n-by-n symmetric matrix. - -1 - The matrix G = B*R B' must be provided on input, instead of B and + + The matrix ``G = B*R^{-1}*B'`` must be provided on input, instead of B and R, that is, for instance, the continuous-time equation + :: + Q + A'*X + X*A - X*G*X = 0 (3) is solved, where G is an n-by-n symmetric matrix. Slycot Library @@ -196,88 +199,88 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): lambda(1),...,lambda(n) of the corresponding Hamiltonian or symplectic matrix associated to the optimal problem. - Required arguments - ------------------ - - n : int - The order of the matrices A, Q, G and X. n > 0. - A : rank-2 array('d'), shape (n,n) - G : rank-2 array('d'), shape (n,n) - The upper triangular part (if uplo = 'U') or lower triangular - part (if uplo = 'L') of this array must contain the upper - triangular part or lower triangular part, respectively, of the - symmetric matrix G. - Q : rank-2 array('d'), shape (n,n) - The upper triangular part (if uplo = 'U') or lower triangular - part (if uplo = 'L') of this array must contain the upper - triangular part or lower triangular part, respectively, - of the symmetric matrix Q. - dico : {'C', 'D'} - Specifies the type of Riccati equation to be solved as follows: - = 'C': Equation (3), continuous-time case; - = 'D': Equation (2), discrete-time case. - - Optional arguments - ------------------ - - hinv : {'D', 'I'} - If dico = 'D', specifies which symplectic matrix is to be - constructed, as follows: - = 'D': The Hamiltonian or sympletic matrix H is constructed; - = 'I': The inverse of the matrix H is constructed. - The default value is 'D'. hinv is not used if DICO = 'C'. - uplo : {'U', 'L'} - Specifies which triangle of the matrices G and Q is stored, - as follows: - = 'U': Upper triangle is stored; - = 'L': Lower triangle is stored. - The default value is 'U'. - scal : {'N', 'G'} - Specifies whether or not a scaling strategy should be used, - as follows: - = 'G': General scaling should be used; - = 'N': No scaling should be used. - The default value is 'N'. - sort : {'S', 'U'} - Specifies which eigenvalues should be obtained in the top of - the Schur form, as follows: - = 'S': Stable eigenvalues come first; - = 'U': Unstable eigenvalues come first. - The default value is 'S'. - ldwork : int - The length of the cache array. The default value is max(3, 6*n), - for optimum performance it should be larger. + Parameters + ---------- + n : int + The order of the matrices A, Q, G and X. n > 0. + A : (n, n) array_like + G : (n, n) array_like + The upper triangular part (if uplo = 'U') or lower triangular + part (if uplo = 'L') of this array must contain the upper + triangular part or lower triangular part, respectively, of the + symmetric matrix G. + Q : (n, n) array_like + The upper triangular part (if uplo = 'U') or lower triangular + part (if uplo = 'L') of this array must contain the upper + triangular part or lower triangular part, respectively, + of the symmetric matrix Q. + dico : {'C', 'D'} + Specifies the type of Riccati equation to be solved as follows: + := 'C': Equation (3), continuous-time case; + := 'D': Equation (2), discrete-time case. + hinv : {'D', 'I'}, optional + If dico = 'D', specifies which symplectic matrix is to be + constructed, as follows: + := 'D': The Hamiltonian or sympletic matrix H is constructed; + := 'I': The inverse of the matrix H is constructed. + The default value is 'D'. hinv is not used if DICO = 'C'. + uplo : {'U', 'L'}, optional + Specifies which triangle of the matrices G and Q is stored, + as follows: + := 'U': Upper triangle is stored; + := 'L': Lower triangle is stored. + The default value is 'U'. + scal : {'N', 'G'}, optional + Specifies whether or not a scaling strategy should be used, + as follows: + := 'G': General scaling should be used; + := 'N': No scaling should be used. + The default value is 'N'. + sort : {'S', 'U'}, optional + Specifies which eigenvalues should be obtained in the top of + the Schur form, as follows: + := 'S': Stable eigenvalues come first; + := 'U': Unstable eigenvalues come first. + The default value is 'S'. + ldwork : int, optional + The length of the cache array. The default value is max(3, 6*n), + for optimum performance it should be larger. Returns ------- + X : (n, n) ndarray + The solution matrix of the problem. + rcond : float + An estimate of the reciprocal of the condition number (in + the 1-norm) of the n-th order system of algebraic + equations from which the solution matrix X is obtained. + w : (2*n) complex ndarray + This array contain the eigenvalues of the 2n-by-2n matrix S, ordered + as specified by sort (except for the case hinv = 'D', when the order + is opposite to that specified by sort). The leading n elements of + this array contain the closed-loop spectrum of the system matrix + + :: - X : rank-2 array('d'), shape (n,n) - The solution matrix of the problem. - rcond : float - An estimate of the reciprocal of the condition number (in - the 1-norm) of the n-th order system of algebraic - equations from which the solution matrix X is obtained. - w : rank-1 array('c'), shape (2 * n) - This array contain the eigenvalues of the 2n-by-2n matrix S, ordered - as specified by sort (except for the case hinv = 'D', when the order - is opposite to that specified by sort). The leading n elements of - this array contain the closed-loop spectrum of the system -1 - matrix A - B*R *B'*X, if dico = 'C', or of the matrix + A - B*R *B'*X, if dico = 'C', + + or of the matrix + -1 A - B*(R + B'*X*B) B'*X*A, if dico = 'D'. - S : rank-2 array('d'), shape (2 * n,2 * n) - This array contains the ordered real Schur form S of the Hamiltonian - or symplectic matrix H. - U : rank-2 array('d'), shape (2 * n,2 * n) - This array contains the transformation matrix U which reduces the - Hamiltonian or symplectic matrix H to the ordered real Schur form S. - A_inv : rank-2 array('d'), shape (n,n) - The inverse of A if dico = 'D' or a copy of A itself otherwise. + + S : (2*n, 2*n) ndarray + This array contains the ordered real Schur form S of the Hamiltonian + or symplectic matrix H. + U : (2*n, 2*n) ndarray + This array contains the transformation matrix U which reduces the + Hamiltonian or symplectic matrix H to the ordered real Schur form S. + A_inv : (n, n) ndarray + The inverse of A if dico = 'D' or a copy of A itself otherwise. Raises ------ - SlycotParameterError :info = -i: the i-th argument had an illegal value; SlycotArithmeticError @@ -299,21 +302,21 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): be obtained, is singular to working precision. - Example - ------- + Example + ------- - >>> import numpy as np - >>> import slycot - >>> A = np.array([[0, 1],[0, 0]]) - >>> Q = np.array([[1, 0],[0, 2]]) - >>> G = np.array([[0, 0],[0, 1]]) - >>> out = slycot.sb02md(2,A,G,Q,'C') - >>> out[0] # X - array([[ 2., 1.], - [ 1., 2.]]) - >>> out[1] # rcond - 0.3090169943749475 - """ + >>> import numpy as np + >>> import slycot + >>> A = np.array([[0, 1], [0, 0]]) + >>> Q = np.array([[1, 0], [0, 2]]) + >>> G = np.array([[0, 0], [0, 1]]) + >>> out = slycot.sb02md(2, A, G, Q, 'C') + >>> out[0] # X + array([[ 2., 1.], + [ 1., 2.]]) + >>> out[1] # rcond + 0.3090169943749475 + """ hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'hinv', 'uplo', 'scal', 'sort', 'n', @@ -339,13 +342,15 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): To compute the following matrices + :: + -1 G = B*R *B', - -1 + -1 A_b = A - B*R *L', - -1 + -1 Q_b = Q - L*R *L', where A, B, Q, R, L, and G are n-by-n, n-by-m, n-by-n, m-by-m, n-by-m, @@ -355,91 +360,83 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): for solving linear-quadratic optimization problems will then also solve optimization problems with coupling weighting matrix L. - Required arguments - ------------------ - - n : int - The order of the matrices A, Q, and G, and the number of rows of - the matrices B and L. n >= 0. - m : int - The order of the matrix R, and the number of columns of the matrices - B and L. m >= 0. - B : rank-2 array('d'), shape (n,m) - R : rank-2 array('d'), shape (m,m) - If fact = 'N', the upper/lower triangular part of this array must - contain the upper/lower triangular part, of the symmetric input - weighting matrix R. - If fact = 'C', the upper/lower triangular part of this array must - contain the Cholesky factor of the positive definite input weighting - matrix R. - - Optional arguments - ------------------ - - A : rank-2 array('d'), shape (n,n) - If jobl = 'Z', this matrix is not needed. - Q : rank-2 array('d'), shape (n,n) - If jobl = 'Z', this matrix is not needed. Otherwise the upper/lower - triangular part of this array (depending on uplo) must contain the - corresponding part of matrix Q. - L : rank-2 array('d'), shape (n,m) - If jobl = 'Z', this matrix is not needed. - fact : {'N', 'C'} - Specifies how the matrix R is given (factored or not), as follows: - = 'N': Array R contains the matrix R, - = 'C': Array R contains the Cholesky factor of R. - The default value is 'N'. - jobl : {'Z', 'N'} - When equal to 'Z', L is considered as a zero matrix and A,Q and L are - not needed. A,Q and L are required otherwise.The default value is 'Z'. - uplo : {'U', 'L'} - Specifies which triangle of the matrices R and Q (if jobl = 'N') - is stored, as follows: - = 'U': Upper triangle is stored; - = 'L': Lower triangle is stored. - The default value is 'U'. - ldwork : int - The length of the cache array. Whenever fact = 'N' the default value - is max(2,3*m,n*m), for optimum performance it should be larger. - No cache is needed if fact = 'C', defaults at 1. + Parameters + ---------- + n : int + The order of the matrices A, Q, and G, and the number of rows of + the matrices B and L. n >= 0. + m : int + The order of the matrix R, and the number of columns of the matrices + B and L. m >= 0. + B : (n, m) array_like + R : (m, m) array_like + If fact = 'N', the upper/lower triangular part of this array must + contain the upper/lower triangular part, of the symmetric input + weighting matrix R. + If fact = 'C', the upper/lower triangular part of this array must + contain the Cholesky factor of the positive definite input weighting + matrix R. + A : (n, n) array_like, optional + If jobl = 'Z', this matrix is not needed. + Q : (n, n) array_like, optional + If jobl = 'Z', this matrix is not needed. Otherwise the upper/lower + triangular part of this array (depending on uplo) must contain the + corresponding part of matrix Q. + L : (n, m) array_like, optional + If jobl = 'Z', this matrix is not needed. + fact : {'N', 'C'}, optional + Specifies how the matrix R is given (factored or not), as follows: + := 'N': Array R contains the matrix R, + := 'C': Array R contains the Cholesky factor of R. + The default value is 'N'. + jobl : {'Z', 'N'}, optional + When equal to 'Z', L is considered as a zero matrix and A, Q and L are + not needed. A, Q and L are required otherwise.The default value is 'Z'. + uplo : {'U', 'L'}, optional + Specifies which triangle of the matrices R and Q (if jobl = 'N') + is stored, as follows: + := 'U': Upper triangle is stored; + := 'L': Lower triangle is stored. + The default value is 'U'. + ldwork : int, optional + The length of the cache array. Whenever fact = 'N' the default value + is max(2, 3*m, n*m), for optimum performance it should be larger. + No cache is needed if fact = 'C', defaults at 1. Returns ------- - - A_b : rank-2 array('d'), shape (n,n) - If jobl = 'Z', this is None. - B_b : rank-2 array('d'), shape (n,m) - -1 - If oufact = 1 this array contains the matrix B*chol(R) . It is a copy - of input B if oufact = 2. - Q_b : rank-2 array('d'), shape (n,n) - If jobl = 'Z', this is None. Otherwise the upper/lower triangular part - of this array contain the corresponding triangular part of matrix Q_b - (depending on uplo). - R_b : rank-2 array('d'), shape (m,m) - If oufact = 1, the upper/lower triangular part of this array contains - the Cholesky factor of the given input weighting matrix. - If oufact = 2, the upper/lower triangular part of this array contains - the factors of the UdU' or LdL' factorization, respectively, of the given - input weighting matrix. - If fact = 'C' it is a copy of input R. - L_b : rank-2 array('d'), shape (n,m) - If jobl = 'Z', this is None. If oufact = 1, this array contains the matrix - -1 - L*chol(R) .If oufact = 2 this contains a copy of input L. - ipiv : rank-1 array('i'), shape (m,) - If oufact = 2, this array contains details of the interchanges - performed and the block structure of the d factor in the UdU' or - LdL' factorization of matrix R, as produced by LAPACK routine DSYTRF. - Otherwise it is None. - oufact : int - Information about the factorization finally used. - oufact = 1: Cholesky factorization of R has been used; - oufact = 2: UdU' (if uplo = 'U') or LdL' (if uplo = 'L') - factorization of R has been used. - G : rank-2 array('d'), shape (n,n) - The upper/lower triangular part of this array contains the corresponding - triangular part of the matrix G. + A_b : (n, n) ndarray + If jobl = 'Z', this is None. + B_b : (n, m) ndarray + If oufact = 1 this array contains the matrix ``B*chol(R)^{-1}``. + It is a copy of input B if oufact = 2. + Q_b : (n, n) ndarray + If jobl = 'Z', this is None. Otherwise the upper/lower triangular part + of this array contain the corresponding triangular part of matrix Q_b + (depending on uplo). + R_b : (m, m) ndarray + If oufact = 1, the upper/lower triangular part of this array contains + the Cholesky factor of the given input weighting matrix. + If oufact = 2, the upper/lower triangular part of this array contains + the factors of the UdU' or LdL' factorization, respectively, of the given + input weighting matrix. + If fact = 'C' it is a copy of input R. + L_b : (n, m) ndarray + If jobl = 'Z', this is None. If oufact = 1, this array contains the matrix + ``L*chol(R)^{-1}``. If oufact = 2 this contains a copy of input L. + ipiv : (m, ) int ndarray + If oufact = 2, this array contains details of the interchanges + performed and the block structure of the d factor in the UdU' or + LdL' factorization of matrix R, as produced by LAPACK routine DSYTRF. + Otherwise it is None. + oufact : int + Information about the factorization finally used. + :oufact = 1: Cholesky factorization of R has been used; + :oufact = 2: UdU' (if uplo = 'U') or LdL' (if uplo = 'L') + factorization of R has been used. + G : (n, n) ndarray + The upper/lower triangular part of this array contains the corresponding + triangular part of the matrix G. Raises ------ @@ -459,7 +456,7 @@ def sb02mt(n,m,B,R,A=None,Q=None,L=None,fact='N',jobl='Z',uplo='U',ldwork=None): 'DWORK'+hidden, 'ldwork', 'INFO'+hidden] out = None if fact == 'N' and ldwork is None: - ldwork = max(2,3*m,n*m) + ldwork = max(2, 3*m, n*m) if jobl == 'Z': if fact == 'C': out = _wrapper.sb02mt_c(n,m,B,R,uplo=uplo) @@ -485,10 +482,16 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw To solve for X either the continuous-time algebraic Riccati equation + + :: + -1 Q + A'X + XA - (L+XB)R (L+XB)' = 0 (1) or the discrete-time algebraic Riccati equation + + :: + -1 X = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q (2) @@ -507,98 +510,92 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw The routine uses the method of deflating subspaces, based on reordering the eigenvalues in a generalized Schur matrix pair. - Required arguments - ------------------ - - n : int - The actual state dimension, i.e. the order of the matrices A, Q, - and X, and the number of rows of the matrices B and L. n > 0. - m : int - The number of system inputs, the order of the matrix R, and the - number of columns of the matrix B. m > 0. - A : rank-2 array('d'), shape (n,n) - The state matrix of the system. - B : rank-2 array('d'), shape (n,m) - The input matrix of the system. - Q : rank-2 array('d'), shape (n,n) or (p,n) - If fact = 'N' or 'D', the shape must be (n,n) and the upper/lower - triangular part (depending on uplo) of this array must contain - the corresponding triangular part of the symmetric state weighting - matrix Q. - If fact = 'C' or 'B', the shape must be (p,n) and of this array must - contain the output matrix C of the system. - R : rank-2 array('d'), shape (m,m) or (p,m) - If fact = 'N' or 'C', the shape must be (m,m) and the upper/lower - triangular part (depending on uplo) of this array must contain the - corresponding triangular part of the symmetric input weighting matrix R. - If FACT = 'D' or 'B', the shape must be (p,m) and this array must - contain the direct transmission matrix D of the system. - dico : {'C', 'D'} - Specifies the type of Riccati equation to be solved as follows: - = 'C': Equation (1), continuous-time case; - = 'D': Equation (2), discrete-time case. - - Optional arguments - ------------------ - - p : int - The number of system outputs. If fact = 'C' or 'D' or 'B', - p is the number of rows of the matrices C and/or D. p > 0. - If fact = 'N' it is not needed. - L : rank-2 array('d'), shape (n,m) - If L is not specified it will considered as a zero matrix of the - appropriate dimensions. - fact : {'N', 'C', 'D', 'B'} - Specifies whether or not the matrices Q and/or R are factored, - as follows: - = 'N': Not factored, Q and R are given; - = 'C': C is given, and Q = C'C; - = 'D': D is given, and R = D'D; - = 'B': Both factors C and D are given, Q = C'C, R = D'D. - The default value is 'N'. - uplo : {'U', 'L'} - If fact = 'N', specifies which triangle of Q and R is stored, - as follows: - = 'U': Upper triangle is stored; - = 'L': Lower triangle is stored. - The default value is 'U'. - sort : {'S', 'U'} - Specifies which eigenvalues should be obtained in the top of - the generalized Schur form, as follows: - = 'S': Stable eigenvalues come first; - = 'U': Unstable eigenvalues come first. - The default value is 'S'. - tol : float - The tolerance to be used in rank determination of the original - matrix pencil, specifically of the triangular factor obtained during - the reduction process. If tol <= 0 a default value is used. - ldwork : int - The length of the cache array. The default value is - max(7*(2*n+1)+16,16*n,2*n+m,3*m), for optimum performance it should - be larger. + Parameters + ---------- + n : int + The actual state dimension, i.e. the order of the matrices A, Q, + and X, and the number of rows of the matrices B and L. n > 0. + m : int + The number of system inputs, the order of the matrix R, and the + number of columns of the matrix B. m > 0. + A : (n, n) array_like + The state matrix of the system. + B : (n, m) array_like + The input matrix of the system. + Q : (n, n) or (p, n) array_like + If fact = 'N' or 'D', the shape must be (n, n) and the upper/lower + triangular part (depending on uplo) of this array must contain + the corresponding triangular part of the symmetric state weighting + matrix Q. + If fact = 'C' or 'B', the shape must be (p, n) and of this array must + contain the output matrix C of the system. + R : (m, m) or (p, m) array_like + If fact = 'N' or 'C', the shape must be (m, m) and the upper/lower + triangular part (depending on uplo) of this array must contain the + corresponding triangular part of the symmetric input weighting matrix R. + If FACT = 'D' or 'B', the shape must be (p, m) and this array must + contain the direct transmission matrix D of the system. + dico : {'C', 'D'} + Specifies the type of Riccati equation to be solved as follows: + := 'C': Equation (1), continuous-time case; + := 'D': Equation (2), discrete-time case. + p : int, optional + The number of system outputs. If fact = 'C' or 'D' or 'B', + p is the number of rows of the matrices C and/or D. p > 0. + If fact = 'N' it is not needed. + L : (n, m) array_like, optional + If L is not specified it will considered as a zero matrix of the + appropriate dimensions. + fact : {'N', 'C', 'D', 'B'}, optional + Specifies whether or not the matrices Q and/or R are factored, + as follows: + := 'N': Not factored, Q and R are given; + := 'C': C is given, and Q = C'C; + := 'D': D is given, and R = D'D; + := 'B': Both factors C and D are given, Q = C'C, R = D'D. + The default value is 'N'. + uplo : {'U', 'L'}, optional + If fact = 'N', specifies which triangle of Q and R is stored, + as follows: + := 'U': Upper triangle is stored; + := 'L': Lower triangle is stored. + The default value is 'U'. + sort : {'S', 'U'}, optional + Specifies which eigenvalues should be obtained in the top of + the generalized Schur form, as follows: + := 'S': Stable eigenvalues come first; + := 'U': Unstable eigenvalues come first. + The default value is 'S'. + tol : float, optional + The tolerance to be used in rank determination of the original + matrix pencil, specifically of the triangular factor obtained during + the reduction process. If tol <= 0 a default value is used. + ldwork : int, optional + The length of the cache array. The default value is + max(7*(2*n+1)+16, 16*n, 2*n+m, 3*m), for optimum performance it should + be larger. Returns ------- - - X : rank-2 array('d'), shape (n,n) - The solution matrix of the problem. - rcond : float - An estimate of the reciprocal of the condition number (in - the 1-norm) of the n-th order system of algebraic equations - from which the solution matrix X is obtained. - w : rank-1 array('c'), shape (2 * n) - The generalized eigenvalues of the 2n-by-2n matrix pair, ordered as - specified by sort. For instance, if sort = 'S', the leading n - elements of these arrays contain the closed-loop spectrum of the - system matrix A - BF, where F is the optimal feedback matrix computed - based on the solution matrix X. - S : rank-2 array('d'), shape (2*n+m,2 * n) - This array contains the ordered real Schur form S of the first matrix - in the reduced matrix pencil associated to the optimal problem, or of - the corresponding Hamiltonian matrix - T : rank-2 array('d'), shape (2*n+m+1,2 * n) - This array contains the ordered upper triangular form T of the second - matrix in the reduced matrix pencil associated to the optimal problem. + X : (n, n) array_like + The solution matrix of the problem. + rcond : float + An estimate of the reciprocal of the condition number (in + the 1-norm) of the n-th order system of algebraic equations + from which the solution matrix X is obtained. + w : (2 * n) complex array_like + The generalized eigenvalues of the 2n-by-2n matrix pair, ordered as + specified by sort. For instance, if sort = 'S', the leading n + elements of these arrays contain the closed-loop spectrum of the + system matrix A - BF, where F is the optimal feedback matrix computed + based on the solution matrix X. + S : (2*n+m, 2 * n) array_like + This array contains the ordered real Schur form S of the first matrix + in the reduced matrix pencil associated to the optimal problem, or of + the corresponding Hamiltonian matrix + T : (2*n+m+1, 2 * n) array_like + This array contains the ordered upper triangular form T of the second + matrix in the reduced matrix pencil associated to the optimal problem. Raises ------ @@ -628,12 +625,12 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw >>> import numpy as np >>> import slycot - >>> A = np.array([[0, 1],[0, 0]]) - >>> B = np.array([[0],[1]]) - >>> C = np.array([[1, 0],[0, 1],[0, 0]]) - >>> Q = np.dot(C.T,C) - >>> R = np.ones((1,1)) - >>> out = slycot.sb02od(2,1,A,B,Q,R,'C') + >>> A = np.array([[0, 1], [0, 0]]) + >>> B = np.array([[0], [1]]) + >>> C = np.array([[1, 0], [0, 1], [0, 0]]) + >>> Q = np.dot(C.T, C) + >>> R = np.ones((1, 1)) + >>> out = slycot.sb02od(2, 1, A, B, Q, R, 'C') >>> out[0] # X array([[ 1.73205081, 1. ], [ 1. , 1.73205081]]) @@ -682,10 +679,14 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): To solve for X either the real continuous-time Lyapunov equation + :: + op(A)'*X + X*op(A) = scale*C (1) or the real discrete-time Lyapunov equation + :: + op(A)'*X*op(A) - X = scale*C (2) and/or estimate an associated condition number, called separation, @@ -694,78 +695,72 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): hand side C and the solution X are n-by-n, and scale is an output scale factor, set less than or equal to 1 to avoid overflow in X. - Required arguments - ------------------ - - n : input int - The order of the matrices A, X, and C. n > 0. - C : input rank-2 array('d'), shape (n,n) - If job = 'X' or 'B', the leading n-by-n part of this array must - contain the symmetric matrix C. If job = 'S', C is not referenced. - A : input rank-2 array('d'), shape (n,n) - On entry, the leading n-by-n part of this array must contain the - matrix A. If fact = 'F', then A contains an upper quasi-triangular - matrix in Schur canonical form; the elements below the upper - Hessenberg part of the array A are not referenced. - On exit, the leading n-by-n upper Hessenberg part of this array - contains the upper quasi-triangular matrix in Schur canonical form - from the Schur factorization of A. The contents of array A is not - modified if fact = 'F'. - U : input rank-2 array('d'), shape (n,n) - If fact = 'F', then U is an input argument and on entry the leading - n-by-n part of this array must contain the orthogonal matrix U of - the real Schur factorization of A. - If fact = 'N', then U is an output argument and on exit, it contains - the orthogonal n-by-n matrix from the real Schur factorization of A. - dico : input string(len=1) - Specifies the equation from which X is to be determined as follows: - = 'C': Equation (1), continuous-time case; - = 'D': Equation (2), discrete-time case. - - Optional arguments - ------------------ - - job := 'X' input string(len=1) - Specifies the computation to be performed, as follows: - = 'X': Compute the solution only; - = 'S': Compute the separation only; - = 'B': Compute both the solution and the separation. - fact := 'N' input string(len=1) - Specifies whether or not the real Schur factorization of the matrix - A is supplied on entry, as follows: - = 'F': On entry, A and U contain the factors from the real Schur - factorization of the matrix A; - = 'N': The Schur factorization of A will be computed and the factors - will be stored in A and U. - trana := 'N' input string(len=1) - Specifies the form of op(A) to be used, as follows: - = 'N': op(A) = A (No transpose); - = 'T': op(A) = A**T (Transpose); - = 'C': op(A) = A**T (Conjugate transpose = Transpose). - ldwork := None input int - The length of the cache array. The default value is max(2*n*n,3*n), - for optimum performance it should be larger. - - Return objects - -------------- - - X : rank-2 array('d'), shape (n,n) - If job = 'X' or 'B', the leading n-by-n part contains the symmetric - solution matrix. - scale : float - The scale factor, scale, set less than or equal to 1 to prevent - the solution from overflowing. - sep : float - If job = 'S' or 'B', sep contains the estimated separation of - the matrices op(A) and -op(A)', if dico = 'C' or of op(A) and op(A)', - if dico = 'D'. - ferr : float - If job = 'B', ferr contains an estimated forward error bound for - the solution X. If X_true is the true solution, ferr bounds the - relative error in the computed solution, measured in the Frobenius - norm: norm(X - X_true)/norm(X_true). - w : rank-1 array('c'), shape (n) - If fact = 'N', this array contain the eigenvalues of A. + Parameters + ---------- + n : int + The order of the matrices A, X, and C. n > 0. + C : (n, n) array_like + If job = 'X' or 'B', the leading n-by-n part of this array must + contain the symmetric matrix C. If job = 'S', C is not referenced. + A : (n, n) array_like + On entry, the leading n-by-n part of this array must contain the + matrix A. If fact = 'F', then A contains an upper quasi-triangular + matrix in Schur canonical form; the elements below the upper + Hessenberg part of the array A are not referenced. + On exit, the leading n-by-n upper Hessenberg part of this array + contains the upper quasi-triangular matrix in Schur canonical form + from the Schur factorization of A. The contents of array A is not + modified if fact = 'F'. + U : (n, n) array_like + If fact = 'F', then U is an input argument and on entry the leading + n-by-n part of this array must contain the orthogonal matrix U of + the real Schur factorization of A. + If fact = 'N', then U is an output argument and on exit, it contains + the orthogonal n-by-n matrix from the real Schur factorization of A. + dico : {'C', 'D'} + Specifies the equation from which X is to be determined as follows: + := 'C': Equation (1), continuous-time case; + := 'D': Equation (2), discrete-time case. + job : {'X', 'S', 'B'}, optional + Specifies the computation to be performed, as follows: + := 'X': Compute the solution only; (default) + := 'S': Compute the separation only; + := 'B': Compute both the solution and the separation. + fact : {'N', 'F'}, optional + Specifies whether or not the real Schur factorization of the matrix + A is supplied on entry, as follows: + := 'F': On entry, A and U contain the factors from the real Schur + factorization of the matrix A; + := 'N': The Schur factorization of A will be computed and the factors + will be stored in A and U. (default) + trana : {'N', 'T', 'C'}, optional + Specifies the form of op(A) to be used, as follows: + := 'N': op(A) = A (No transpose, default= + := 'T': op(A) = A**T (Transpose); + := 'C': op(A) = A**T (Conjugate transpose = Transpose). + ldwork : int, optional + The length of the cache array. The default value is max(2*n*n, 3*n), + for optimum performance it should be larger. + + Returns + ------- + X : (n, n) ndarray + If job = 'X' or 'B', the leading n-by-n part contains the symmetric + solution matrix. + scale : float + The scale factor, scale, set less than or equal to 1 to prevent + the solution from overflowing. + sep : float + If job = 'S' or 'B', sep contains the estimated separation of + the matrices op(A) and -op(A)', if dico = 'C' or of op(A) and op(A)', + if dico = 'D'. + ferr : float + If job = 'B', ferr contains an estimated forward error bound for + the solution X. If X_true is the true solution, ferr bounds the + relative error in the computed solution, measured in the Frobenius + norm: norm(X - X_true)/norm(X_true). + w : (n, ) complex ndarray + If fact = 'N', this array contain the eigenvalues of A. Warns ----- @@ -807,11 +802,17 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): To solve for X = op(U)'*op(U) either the stable non-negative definite continuous-time Lyapunov equation + + :: + 2 op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) or the convergent non-negative definite discrete-time Lyapunov equation + + :: + 2 op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) @@ -830,81 +831,75 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): and for equation (2) the matrix A must be convergent (that is, all the eigenvalues of A must lie inside the unit circle). - Required arguments - ------------------ - - n : input int - The order of the matrix A and the number of columns in - matrix op(B). n >= 0. - m : input int - The number of rows in matrix op(B). m >= 0. - A : input rank-2 array('d'), shape (n,n) - On entry, the leading n-by-n part of this array must - contain the matrix A. If fact = 'F', then A contains - an upper quasi-triangular matrix S in Schur canonical - form; the elements below the upper Hessenberg part of the - array A are not referenced. - On exit, the leading n-by-n upper Hessenberg part of this - array contains the upper quasi-triangular matrix S in - Schur canonical form from the Shur factorization of A. - The contents of array A is not modified if fact = 'F'. - Q : input rank-2 array('d'), shape (n,n) - On entry, if fact = 'F', then the leading n-by-n part of - this array must contain the orthogonal matrix Q of the - Schur factorization of A. - Otherwise, Q need not be set on entry. - On exit, the leading n-by-n part of this array contains - the orthogonal matrix Q of the Schur factorization of A. - The contents of array Q is not modified if fact = 'F'. - B : input rank-2 array('d'), shape (m,n) - On entry, if trans = 'N', the leading m-by-n part of this - array must contain the coefficient matrix B of the - equation. - On entry, if trans = 'T', the leading N-by-m part of this - array must contain the coefficient matrix B of the - equation. - On exit, the leading n-by-n part of this array contains - the upper triangular Cholesky factor U of the solution - matrix X of the problem, X = op(U)'*op(U). - If m = 0 and n > 0, then U is set to zero. - dico : input string(len=1) - Specifies the type of Lyapunov equation to be solved as - follows: - = 'C': Equation (1), continuous-time case; - = 'D': Equation (2), discrete-time case. - - Optional arguments - ------------------ - - fact := 'N' input string(len=1) - Specifies whether or not the real Schur factorization - of the matrix A is supplied on entry, as follows: - = 'F': On entry, A and Q contain the factors from the - real Schur factorization of the matrix A; - = 'N': The Schur factorization of A will be computed - and the factors will be stored in A and Q. - trans := 'N' input string(len=1) - Specifies the form of op(K) to be used, as follows: - = 'N': op(K) = K (No transpose); - = 'T': op(K) = K**T (Transpose). - ldwork := None input int - The length of the array DWORK. - If m > 0, ldwork >= max(1,4*n + min(m,n)); - If m = 0, ldwork >= 1. - For optimum performance ldwork should sometimes be larger. - - Return objects - ______________ - - U : rank-2 array('d'), shape (n,n) - The leading n-by-n part of this array contains - the upper triangular Cholesky factor U of the solution - matrix X of the problem, X = op(U)'*op(U). - scale : float - The scale factor, scale, set less than or equal to 1 to - prevent the solution overflowing. - w : rank-1 array('c'), shape (n) - If fact = 'N', this array contains the eigenvalues of A. + Parameters + ---------- + n : int + The order of the matrix A and the number of columns in + matrix op(B). n >= 0. + m : int + The number of rows in matrix op(B). m >= 0. + A : (n, n) array_like + On entry, the leading n-by-n part of this array must + contain the matrix A. If fact = 'F', then A contains + an upper quasi-triangular matrix S in Schur canonical + form; the elements below the upper Hessenberg part of the + array A are not referenced. + On exit, the leading n-by-n upper Hessenberg part of this + array contains the upper quasi-triangular matrix S in + Schur canonical form from the Shur factorization of A. + The contents of array A is not modified if fact = 'F'. + Q : (n, n) array_like + On entry, if fact = 'F', then the leading n-by-n part of + this array must contain the orthogonal matrix Q of the + Schur factorization of A. + Otherwise, Q need not be set on entry. + On exit, the leading n-by-n part of this array contains + the orthogonal matrix Q of the Schur factorization of A. + The contents of array Q is not modified if fact = 'F'. + B : (m, n) array_like + On entry, if trans = 'N', the leading m-by-n part of this + array must contain the coefficient matrix B of the + equation. + On entry, if trans = 'T', the leading N-by-m part of this + array must contain the coefficient matrix B of the + equation. + On exit, the leading n-by-n part of this array contains + the upper triangular Cholesky factor U of the solution + matrix X of the problem, X = op(U)'*op(U). + If m = 0 and n > 0, then U is set to zero. + dico : {'C', 'D'} + Specifies the type of Lyapunov equation to be solved as + follows: + := 'C': Equation (1), continuous-time case; + := 'D': Equation (2), discrete-time case. + fact : {'N', 'F'}, optional + Specifies whether or not the real Schur factorization + of the matrix A is supplied on entry, as follows: + := 'F': On entry, A and Q contain the factors from the + real Schur factorization of the matrix A; + := 'N': The Schur factorization of A will be computed + and the factors will be stored in A and Q. + trans : {'N', 'T'}, optional + Specifies the form of op(K) to be used, as follows: + := 'N': op(K) = K (No transpose, default); + := 'T': op(K) = K**T (Transpose). + ldwork : int, optional + The length of the array DWORK. + If m > 0, ldwork >= max(1, 4*n + min(m, n)); + If m = 0, ldwork >= 1. + For optimum performance ldwork should sometimes be larger. + + Returns + _______ + U : (n, n) ndarray + The leading n-by-n part of this array contains + the upper triangular Cholesky factor U of the solution + matrix X of the problem, X = op(U)'*op(U). + scale : float + The scale factor, scale, set less than or equal to 1 to + prevent the solution overflowing. + w : (n, ) complex ndarray + If fact = 'N', this array contains the eigenvalues of A. Raises ------ @@ -1002,16 +997,16 @@ def sb04md(n,m,A,B,C,ldwork=None): row shape m : int column shape - A : (n,n) array_like + A : (n, n) array_like Matrix A - B : (m,m) array_like + B : (m, m) array_like Matrix B - C : (n,m) array_like + C : (n, m) array_like Matrix C Returns ------- - X : (n,m) ndarray + X : (n, m) ndarray Matrix X Raises @@ -1045,23 +1040,22 @@ def sb04qd(n,m,A,B,C,ldwork=None): reduces A to upper Hessenberg form, H = U'AU, and B' to real Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. - Parameters ---------- n : int row shape m : int column shape - A : (n,n) array_like + A : (n, n) array_like Matrix A - B : (m,m) array_like + B : (m, m) array_like Matrix B - C : (n,m) array_like + C : (n, m) array_like Matrix C Returns ------- - X : (n,m) ndarray + X : (n, m) ndarray Matrix X Raises @@ -1089,12 +1083,16 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, To compute the matrices of an H-infinity optimal n-state controller + :: + | Ak | Bk | K = |----|----|, | Ck | Dk | using modified Glover's and Doyle's 1988 formulas, for the system + :: + | A | B1 B2 | | A | B | P = |----|---------| = |---|---| | C1 | D11 D12 | | C | D | @@ -1106,6 +1104,8 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, being provided to the controller, and then to compute the matrices of the closed-loop system + :: + | AC | BC | G = |----|----|, | CC | DC | @@ -1114,106 +1114,114 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, It is assumed that - (A1) (A,B2) is stabilizable and (C2,A) is detectable, - - (A2) D12 is full column rank and D21 is full row rank, - - (A3) | A-j*omega*I B2 | has full column rank for all omega, - | C1 D12 | - - (A4) | A-j*omega*I B1 | has full row rank for all omega. - | C2 D21 | - - - Required arguments - ------------------ - - n : int - The order of the system. (size of matrix A). - m : int - The column size of the matrix B. - np : int - The row size of the matrix C. - ncon : int - The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. - nmeas : int - The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. - gamma : double - The initial value of gamma on input. It is assumed that gamma - is sufficiently large so that the controller is admissible. gamma >= 0. - A : rank-2 array('d'), shape (n,n) - B : rank-2 array('d'), shape (n,m) - C : rank-2 array('d'), shape (np,n) - D : rank-2 array('d'), shape (np,m) - - Optional arguments - ------------------ - - job := 3 int - Specifies the computation to be performed, as follows: - = 1: Use bisection method for decreasing gamma until the closed-loop - system leaves stability - = 2: Scan from gamma to 0 trying to find the minimal gamma for which - the closed-loop system retains stability - = 3: First bisection, then scanning. - = 4: Find suboptimal controller only. - gtol : double - Tolerance used for controlling the accuracy of gamma - and its distance to the estimated minimal possible - value of gamma. - If gtol <= 0, then a default value equal to sqrt(eps) - is used, where eps is the relative machine precision. - actol : double - Upper bound for the poles of the closed-loop system used for determining - if it is stable. actol <= 0 for stable systems - liwork : int - The dimension of the integer cache array. - ldwork : int - The dimension of the double cache array. - - Return objects - -------------- - - gamma_est : double - The minimal estimated gamma. - Ak : rank-2 array('d'), shape (n,n) - The controller state matrix Ak. - Bk : rank-2 array('d') with bound s(n,nmeas) - The controller input matrix Bk. - Ck : rank-2 array('d'), shape (ncon,n) - The controller output matrix Ck. - Dk : rank-2 array('d'), shape (ncon,nmeas) - The controller input/output matrix DK. - Ac : rank-2 array('d'), shape (2n,2n) - The closed-loop system state matrix AC. - Bc : rank-2 array('d'), shape (2n,m-ncon) - The closed-loop system input matrix BC. - Cc : rank-2 array('d'), shape (np-nmeas,2n) - The closed-loop system output matrix CC. - Dc : rank-2 array('d'), shape (np-nmeas,m-ncon) - The the closed-loop system input/output matrix DC. - rcond : rank-1 array('d'), shape (4) - For the last successful step: - rcond(1) contains the reciprocal condition number of the - control transformation matrix; - rcond(2) contains the reciprocal condition number of the - measurement transformation matrix; - rcond(3) contains an estimate of the reciprocal condition - number of the X-Riccati equation; - rcond(4) contains an estimate of the reciprocal condition - number of the Y-Riccati equation. + :: + + (A1) (A,B2) is stabilizable and (C2,A) is detectable, + + (A2) D12 is full column rank and D21 is full row rank, + + (A3) | A-j*omega*I B2 | has full column rank for all omega, + | C1 D12 | + + (A4) | A-j*omega*I B1 | has full row rank for all omega. + | C2 D21 | + + + Parameters + ---------- + n : int + The order of the system. (size of matrix A). + m : int + The column size of the matrix B. + np : int + The row size of the matrix C. + ncon : int + The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. + nmeas : int + The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. + gamma : double + The initial value of gamma on input. It is assumed that gamma + is sufficiently large so that the controller is admissible. gamma >= 0. + A : (n, n) array_like + System matrix + B : (n, m) array_like + Input matrix + C : (np, n) array_like + Output matrix + D : (np, m) array_like + Direct feed-through + job : int, optional + Specifies the computation to be performed, as follows: + := 1: Use bisection method for decreasing gamma until the closed-loop + system leaves stability + := 2: Scan from gamma to 0 trying to find the minimal gamma for which + the closed-loop system retains stability + := 3: First bisection, then scanning. (default) + := 4: Find suboptimal controller only. + gtol : double, optional + Tolerance used for controlling the accuracy of gamma + and its distance to the estimated minimal possible + value of gamma. + If gtol <= 0, then a default value equal to sqrt(eps) + is used, where eps is the relative machine precision. + actol : double, optional + Upper bound for the poles of the closed-loop system used for determining + if it is stable. actol <= 0 for stable systems + liwork : int, optional + The dimension of the integer cache array. + ldwork : int, optional + The dimension of the double cache array. + + Returns + ------- + gamma_est : double + The minimal estimated gamma. + Ak : (n, n) ndarray + The controller state matrix Ak. + Bk : (n, nmeas) ndarray + The controller input matrix Bk. + Ck : (ncon, n) ndarray + The controller output matrix Ck. + Dk : (ncon, nmeas) ndarray + The controller input/output matrix DK. + Ac : (2n, 2n) ndarray + The closed-loop system state matrix AC. + Bc : (2n, m-ncon) ndarray + The closed-loop system input matrix BC. + Cc : (np-nmeas, 2n) ndarray + The closed-loop system output matrix CC. + Dc : (np-nmeas, m-ncon) ndarray + The the closed-loop system input/output matrix DC. + rcond : (4) ndarray + For the last successful step: + + - rcond(1) contains the reciprocal condition number of the + control transformation matrix; + - rcond(2) contains the reciprocal condition number of the + measurement transformation matrix; + - rcond(3) contains an estimate of the reciprocal condition + number of the X-Riccati equation; + - rcond(4) contains an estimate of the reciprocal condition + number of the Y-Riccati equation. Raises ------ SlycotArithmeticError :info = 1: - The matrix | A-j*omega*I B2 | had not full - | C1 D12 | - column rank in respect to the tolerance eps; + The matrix + + :: + + | A-j*omega*I B2 | + | C1 D12 | + had not full column rank in respect to the tolerance eps; :info = 2: - The matrix | A-j*omega*I B1 | had not full row - | C2 D21 | - rank in respect to the tolerance eps; + The matrix + :: + + | A-j*omega*I B1 | + | C2 D21 | + had not full row rank in respect to the tolerance eps; :info = 3: The matrix D12 had not full column rank in respect to the tolerance SQRT(eps); @@ -1223,8 +1231,12 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, :info = 5: The singular value decomposition (SVD) algorithm did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21); - |C1 D12| |C2 D21| + the matrices + + :: + + |A B2 |, |A B1 |, D12 or D21); + |C1 D12| |C2 D21| :info = 6: The controller is not admissible (too small value of gamma); :info = 7: @@ -1290,127 +1302,138 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): To compute the matrices of an H-infinity (sub)optimal n-state controller + :: + | AK | BK | K = |----|----|, | CK | DK | - for the discrete-time system + for the discrete-time system + + :: | A | B1 B2 | | A | B | P = |----|---------| = |---|---| | C1 | D11 D12 | | C | D | | C2 | D21 D22 | - and for a given value of gamma, where B2 has as column size the - number of control inputs (NCON) and C2 has as row size the number - of measurements (NMEAS) being provided to the controller. - - It is assumed that + and for a given value of gamma, where B2 has as column size the + number of control inputs (NCON) and C2 has as row size the number + of measurements (NMEAS) being provided to the controller. - (A1) (A,B2) is stabilizable and (C2,A) is detectable, - - (A2) D12 is full column rank and D21 is full row rank, + It is assumed that - j*Theta - (A3) | A-e *I B2 | has full column rank for all - | C1 D12 | + :: - 0 <= Theta < 2*Pi , + (A1) (A,B2) is stabilizable and (C2,A) is detectable, - j*Theta - (A4) | A-e *I B1 | has full row rank for all - | C2 D21 | + (A2) D12 is full column rank and D21 is full row rank, - 0 <= Theta < 2*Pi . + j*Theta + (A3) | A-e *I B2 | has full column rank for all + | C1 D12 | - Required arguments - ------------------ + 0 <= Theta < 2*Pi , - n : int - The order of the system. (size of matrix A). - m : int - The column size of the matrix B. - np : int - The row size of the matrix C. - ncon : int - The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. - nmeas : int - The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. - gamma : double - The initial value of gamma on input. It is assumed that gamma - is sufficiently large so that the controller is admissible. gamma >= 0. - A : rank-2 array('d'), shape (n,n) - B : rank-2 array('d'), shape (n,m) - C : rank-2 array('d'), shape (np,n) - D : rank-2 array('d'), shape (np,m) + j*Theta + (A4) | A-e *I B1 | has full row rank for all + | C2 D21 | - Optional arguments - ------------------ + 0 <= Theta < 2*Pi . - tol : double + Parameters + ---------- + n : int + The order of the system. (size of matrix A). + m : int + The column size of the matrix B. + np : int + The row size of the matrix C. + ncon : int + The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. + nmeas : int + The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. + gamma : double + The initial value of gamma on input. It is assumed that gamma + is sufficiently large so that the controller is admissible. gamma >= 0. + A : (n, n) array_like + System matrix + B : (n, m) array_like + Input matrix + C : (np, n) array_like + Output matrix + D : (np, m) array_like + Direct feed-through + tol : double, optional Tolerance used in neglecting the small singular values in rank determination. If tol <= 0, then a default value equal to 1000*eps is used, where eps is the relative machine precision. + ldwork : int, optional + The dimension of the array dwork. - ldwork : int - The dimension of the array dwork. - - Return objects - -------------- - - gamma_est : double - The minimal estimated gamma. - Ak : rank-2 array('d'), shape (n,n) - The controller state matrix Ak. - Bk : rank-2 array('d') with bound s(n,nmeas) - The controller input matrix Bk. - Ck : rank-2 array('d'), shape (ncon,n) - The controller output matrix Ck. - Dk : rank-2 array('d'), shape (ncon,nmeas) - The controller input/output matrix DK. - X : rank-2 array('d'), shape (n,n) - The matrix X, solution of the X-Riccati equation. - Z : rank-2 array('d'), shape (n,n) - The matrix Z, solution of the Z-Riccati equation. - rcond : rank-1 array('d'), shape (8) - rcond contains estimates of the reciprocal condition - numbers of the matrices which are to be inverted and - estimates of the reciprocal condition numbers of the - Riccati equations which have to be solved during the - computation of the controller. (See the description of - the algorithm in [2].) - rcond(1) contains the reciprocal condition number of the - matrix R3; - rcond(2) contains the reciprocal condition number of the - matrix R1 - R2'*inv(R3)*R2; - rcond(3) contains the reciprocal condition number of the - matrix V21; - rcond(4) contains the reciprocal condition number of the - matrix St3; - rcond(5) contains the reciprocal condition number of the - matrix V12; - rcond(6) contains the reciprocal condition number of the - matrix Im2 + dkhat*D22 - rcond(7) contains the reciprocal condition number of the - X-Riccati equation; - rcond(8) contains the reciprocal condition number of the - Z-Riccati equation. - + Returns + ------- + gamma_est : double + The minimal estimated gamma. + Ak : (n, n) ndarray + The controller state matrix Ak. + Bk : (n, nmeas) ndarray + The controller input matrix Bk. + Ck : (ncon, n) ndarray + The controller output matrix Ck. + Dk : (ncon, nmeas) ndarray + The controller input/output matrix DK. + X : (n, n) ndarray + The matrix X, solution of the X-Riccati equation. + Z : (n, n) ndarray + The matrix Z, solution of the Z-Riccati equation. + rcond : (8) ndarray + rcond contains estimates of the reciprocal condition + numbers of the matrices which are to be inverted and + estimates of the reciprocal condition numbers of the + Riccati equations which have to be solved during the + computation of the controller. (See the description of + the algorithm in [2].) + + - rcond(1) contains the reciprocal condition number of the + matrix R3; + - rcond(2) contains the reciprocal condition number of the + matrix R1 - R2'*inv(R3)*R2; + - rcond(3) contains the reciprocal condition number of the + matrix V21; + - rcond(4) contains the reciprocal condition number of the + matrix St3; + - rcond(5) contains the reciprocal condition number of the + matrix V12; + - rcond(6) contains the reciprocal condition number of the + matrix Im2 + dkhat*D22 + - rcond(7) contains the reciprocal condition number of the + X-Riccati equation; + - rcond(8) contains the reciprocal condition number of the + Z-Riccati equation. Raises ------ SlycotArithmeticError :info = 1: - . j*Theta - The matrix | A-e *I B2 | had not full + The matrix + + :: + + j*Theta + | A-e *I B2 | | C1 D12 | - column rank; + had not full column rank; :info = 2: - . j*Theta - The matrix | A-e *I B1 | had not full + The matrix + + :: + + j*Theta + | A-e *I B1 | | C2 D21 | - row rank; + had not full row rank; :info = 3: The matrix D12 had not full column rank; :info = 4: @@ -1430,8 +1453,12 @@ def sb10dd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): :info = 9: The singular value decomposition (SVD) algorithm did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21). - |C1 D12| |C2 D21| + the matrices + + :: + + |A B2 |, |A B1 |, D12 or D21). + |C1 D12| |C2 D21| """ hidden = ' (hidden by the wrapper)' @@ -1462,12 +1489,16 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): To compute the matrices of the H2 optimal n-state controller + :: + | AK | BK | K = |----|----| | CK | DK | for the system + :: + | A | B1 B2 | | A | B | P = |----|---------| = |---|---| , | C1 | 0 D12 | | C | D | @@ -1479,65 +1510,64 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): It is assumed that - (A1) (A,B2) is stabilizable and (C2,A) is detectable, - - (A2) The block D11 of D is zero, - - (A3) D12 is full column rank and D21 is full row rank. - - Required arguments - ------------------ - - n : int - The order of the system. (size of matrix A). - m : int - The column size of the matrix B - np : int - The row size of the matrix C - ncon : int - The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. - nmeas : int - The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. - A : rank-2 array('d'), shape (n,n) - B : rank-2 array('d'), shape (n,m) - C : rank-2 array('d'), shape (np,n) - D : rank-2 array('d'), shape (np,m) - - Optional arguments - ------------------ - - tol : double - Tolerance used for controlling the accuracy of the applied - transformations for computing the normalized form in - SLICOT Library routine SB10UD. Transformation matrices - whose reciprocal condition numbers are less than tol are - not allowed. If tol <= 0, then a default value equal to - sqrt(eps) is used, where eps is the relative machine - precision. - ldwork : int - The dimension of the cache array. - - Return objects - -------------- - - Ak : rank-2 array('d'), shape (n,n) - The controller state matrix Ak. - Bk : rank-2 array('d'), shape (n,nmeas) - The controller input matrix Bk. - Ck : rank-2 array('d'), shape (ncon,n) - The controller output matrix Ck. - Dk : rank-2 array('d'), shape (ncon,nmeas) - The controller input/output matrix Dk. - rcond : rank-1 array('d'), shape (4) - For the last successful step: - rcond(1) contains the reciprocal condition number of the - control transformation matrix; - rcond(2) contains the reciprocal condition number of the - measurement transformation matrix; - rcond(3) contains an estimate of the reciprocal condition - number of the X-Riccati equation; - rcond(4) contains an estimate of the reciprocal condition - number of the Y-Riccati equation. + - (A1) (A,B2) is stabilizable and (C2,A) is detectable, + + - (A2) The block D11 of D is zero, + + - (A3) D12 is full column rank and D21 is full row rank. + + Parameters + ---------- + n : int + The order of the system. (size of matrix A). + m : int + The column size of the matrix B + np : int + The row size of the matrix C + ncon : int + The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. + nmeas : int + The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. + A : (n, n) array_like + System Matrix + B : (n, m) array_like + Input Matrix + C : (np, n) array_like + Output Matrix + D : (np, m) array_like + Throughput Matrix + tol : double, optional + Tolerance used for controlling the accuracy of the applied + transformations for computing the normalized form in + SLICOT Library routine SB10UD. Transformation matrices + whose reciprocal condition numbers are less than tol are + not allowed. If tol <= 0, then a default value equal to + sqrt(eps) is used, where eps is the relative machine + precision. + ldwork : int, optional + The dimension of the cache array. + + Returns + ------- + Ak : (n, n) ndarray + The controller state matrix Ak. + Bk : (n, nmeas) ndarray + The controller input matrix Bk. + Ck : (ncon, n) ndarray + The controller output matrix Ck. + Dk : (ncon, nmeas) ndarray + The controller input/output matrix Dk. + rcond : (4) ndarray + For the last successful step: + + - rcond(1) contains the reciprocal condition number of the + control transformation matrix; + - rcond(2) contains the reciprocal condition number of the + measurement transformation matrix; + - rcond(3) contains an estimate of the reciprocal condition + number of the X-Riccati equation; + - rcond(4) contains an estimate of the reciprocal condition + number of the Y-Riccati equation. Raises ------ @@ -1578,54 +1608,60 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): To convert the descriptor state-space system - E*dx/dt = A*x + B*u - y = C*x + D*u + :: + + E*dx/dt = A*x + B*u + y = C*x + D*u into regular state-space form - dx/dt = Ad*x + Bd*u - y = Cd*x + Dd*u . - - Required arguments: - n : input int - The order of the descriptor system. n >= 0. - m : input int - The column size of the matrix B. m >= 0. - np : input int - The row size of the matrix C. np >= 0. - A : rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must - contain the state matrix A of the descriptor system. - B : rank-2 array('d') with bounds (l,m) - The leading n-by-m part of this array must - contain the input matrix B of the descriptor system. - C : rank-2 array('d') with bounds (np,n) - The leading np-by-n part of this array must - contain the output matrix C of the descriptor system. - D : rank-2 array('d') with bounds (np,m) - The leading np-by-m part of this array must - contain the matrix D of the descriptor system. - E : rank-2 array('d') with bounds (l,n) - The leading n-by-n part of this array must - contain the matrix E of the descriptor system. - Optional arguments: - ldwork : input int - The length of the cache array. - ldwork >= max( 1, 2*n*n + 2*n + n*MAX( 5, n + m + np ) ). - For good performance, ldwork must generally be larger. - Return objects: - A : rank-2 array('d') with bounds (nsys,nsys) - The leading nsys-by-nsys part of this array - contains the state matrix Ad of the converted system. - B : rank-2 array('d') with bounds (nsys,m) - The leading NSYS-by-M part of this array - contains the input matrix Bd of the converted system. - C : rank-2 array('d') with bounds (np,nsys) - The leading NP-by-NSYS part of this array - contains the output matrix Cd of the converted system. - D : rank-2 array('d') with bounds (np,m) - The leading NP-by-M part of this array contains - the matrix Dd of the converted system. + :: + + dx/dt = Ad*x + Bd*u + y = Cd*x + Dd*u . + + Parameters + ---------- + n : int + The order of the descriptor system. n >= 0. + m : int + The column size of the matrix B. m >= 0. + np : int + The row size of the matrix C. np >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must + contain the state matrix A of the descriptor system. + B : (l, m) array_like + The leading n-by-m part of this array must + contain the input matrix B of the descriptor system. + C : (np, n) array_like + The leading np-by-n part of this array must + contain the output matrix C of the descriptor system. + D : (np, m) array_like + The leading np-by-m part of this array must + contain the matrix D of the descriptor system. + E : (l, n) array_like + The leading n-by-n part of this array must + contain the matrix E of the descriptor system. + ldwork : int, optional + The length of the cache array. + ldwork >= max( 1, 2*n*n + 2*n + n*MAX( 5, n + m + np ) ). + For good performance, ldwork must generally be larger. + + Returns + ------- + A : (nsys, nsys) ndarray + The leading nsys-by-nsys part of this array + contains the state matrix Ad of the converted system. + B : (nsys, m) ndarray + The leading NSYS-by-M part of this array + contains the input matrix Bd of the converted system. + C : (np, nsys) ndarray + The leading NP-by-NSYS part of this array + contains the output matrix Cd of the converted system. + D : (np, m) ndarray + The leading NP-by-M part of this array contains + the matrix Dd of the converted system. Raises ------ @@ -1674,170 +1710,148 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): Estimates of the separation and the relative forward error norm are provided. - Required arguments - ------------------ - - dico : input string(len=1) - Specifies which type of the equation is considered: - = 'C': Continuous-time equation (1); - = 'D': Discrete-time equation (2). - - job : input string(len=1) - Specifies if the solution is to be computed and if the - separation is to be estimated: - = 'X': Compute the solution only; - = 'S': Estimate the separation only; - = 'B': Compute the solution and estimate the separation. - - fact : input string(len=1) - Specifies whether the generalized real Schur - factorization of the pencil A - lambda * E is supplied - on entry or not: - = 'N': Factorization is not supplied; - = 'F': Factorization is supplied. - - trans : input string(len=1) - Specifies whether the transposed equation is to be solved - or not: - = 'N': op(A) = A, op(E) = E; - = 'T': op(A) = A**T, op(E) = E**T. - - uplo : input string(len=1) - Specifies whether the lower or the upper triangle of the - array X is needed on input: - = 'L': Only the lower triangle is needed on input; - = 'U': Only the upper triangle is needed on input. - - N : The order of the matrix A. N >= 0. - - A : input rank-2 array('d') with bounds (n,n) - On entry, if FACT = 'F', then the leading N-by-N upper - Hessenberg part of this array must contain the - generalized Schur factor A_s of the matrix A (see - definition (3) in section METHOD). A_s must be an upper - quasitriangular matrix. The elements below the upper - Hessenberg part of the array A are not referenced. - If FACT = 'N', then the leading N-by-N part of this - array must contain the matrix A. - On exit, the leading N-by-N part of this array contains - the generalized Schur factor A_s of the matrix A. (A_s is - an upper quasitriangular matrix.) - - E : input rank-2 array('d') with bounds (n,n) - On entry, if FACT = 'F', then the leading N-by-N upper - triangular part of this array must contain the - generalized Schur factor E_s of the matrix E (see - definition (4) in section METHOD). The elements below the - upper triangular part of the array E are not referenced. - If FACT = 'N', then the leading N-by-N part of this - array must contain the coefficient matrix E of the - equation. - On exit, the leading N-by-N part of this array contains - the generalized Schur factor E_s of the matrix E. (E_s is - an upper triangular matrix.) - - Q : input rank-2 array('d') with bounds (n,n) - On entry, if FACT = 'F', then the leading N-by-N part of - this array must contain the orthogonal matrix Q from - the generalized Schur factorization (see definitions (3) - and (4) in section METHOD). - If FACT = 'N', Q need not be set on entry. - On exit, the leading N-by-N part of this array contains - the orthogonal matrix Q from the generalized Schur - factorization. - - Z : input rank-2 array('d') with bounds (n,n) - On entry, if FACT = 'F', then the leading N-by-N part of - this array must contain the orthogonal matrix Z from - the generalized Schur factorization (see definitions (3) - and (4) in section METHOD). - If FACT = 'N', Z need not be set on entry. - On exit, the leading N-by-N part of this array contains - the orthogonal matrix Z from the generalized Schur - factorization. - - X : input rank-2 array('d') with bounds (n,n) - On entry, if JOB = 'B' or 'X', then the leading N-by-N - part of this array must contain the right hand side matrix - Y of the equation. Either the lower or the upper - triangular part of this array is needed (see mode - parameter UPLO). - If JOB = 'S', X is not referenced. - On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then - the leading N-by-N part of this array contains the - solution matrix X of the equation. - If JOB = 'S', X is not referenced. - - - Optional arguments - ------------------ - - ldwork := max(1,max(2*n*n,4*n)) input int - The length of the array DWORK. The following table - contains the minimal work space requirements depending - on the choice of JOB and FACT. - - JOB FACT | LDWORK - -------------------+------------------- - 'X' 'F' | MAX(1,N) - 'X' 'N' | MAX(1,4*N) - 'B', 'S' 'F' | MAX(1,2*N**2) - 'B', 'S' 'N' | MAX(1,2*N**2,4*N) - - For optimum performance, LDWORK should be larger. - - - Return objects - -------------- - - A : rank-2 array('d') with bounds (n,n) - On exit, the leading N-by-N part of this array contains - the generalized Schur factor A_s of the matrix A. (A_s is - an upper quasitriangular matrix.) - - E : rank-2 array('d') with bounds (n,n) - On exit, the leading N-by-N part of this array contains - the generalized Schur factor E_s of the matrix E. (E_s is - an upper triangular matrix.) - - Q : rank-2 array('d') with bounds (n,n) - On exit, the leading N-by-N part of this array contains - the orthogonal matrix Q from the generalized Schur - factorization. - - Z : rank-2 array('d') with bounds (n,n) - On exit, the leading N-by-N part of this array contains - the orthogonal matrix Z from the generalized Schur - factorization. - - X : rank-2 array('d') with bounds (n,n) - On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then - the leading N-by-N part of this array contains the - solution matrix X of the equation. - If JOB = 'S', X is not referenced. - - scale : float - The scale factor set to avoid overflow in X. - (0 < SCALE <= 1) - sep : float - If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then - SEP contains an estimate of the separation of the - Lyapunov operator. - ferr : float - If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an - estimated forward error bound for the solution X. If XTRUE - is the true solution, FERR estimates the relative error - in the computed solution, measured in the Frobenius norm: - norm(X - XTRUE) / norm(XTRUE) - - alphar : rank-1 array('d') with bounds (n) - alphai : rank-1 array('d') with bounds (n) - beta : rank-1 array('d') with bounds (n) - If FACT = 'N' and INFO = 0, 3, or 4, then - (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the - eigenvalues of the matrix pencil A - lambda * E. - If FACT = 'F', ALPHAR, ALPHAI, and BETA are not - referenced. + Parameters + ---------- + dico : {'C', 'D'} + Specifies which type of the equation is considered: + := 'C': Continuous-time equation (1); + := 'D': Discrete-time equation (2). + job : {'X', 'S', 'B'} + Specifies if the solution is to be computed and if the + separation is to be estimated: + := 'X': Compute the solution only; + := 'S': Estimate the separation only; + := 'B': Compute the solution and estimate the separation. + fact : {'F', 'F'} + Specifies whether the generalized real Schur + factorization of the pencil A - lambda * E is supplied + on entry or not: + := 'N': Factorization is not supplied; + := 'F': Factorization is supplied. + trans : {'N', 'T'} + Specifies whether the transposed equation is to be solved + or not: + := 'N': op(A) = A, op(E) = E; + := 'T': op(A) = A**T, op(E) = E**T. + uplo : {'L', 'U'} + Specifies whether the lower or the upper triangle of the + array X is needed on input: + := 'L': Only the lower triangle is needed on input; + := 'U': Only the upper triangle is needed on input. + N : int + The order of the matrix A. N >= 0. + A : (n, n) array_like + On entry, if FACT = 'F', then the leading N-by-N upper + Hessenberg part of this array must contain the + generalized Schur factor A_s of the matrix A (see + definition (3) in section METHOD). A_s must be an upper + quasitriangular matrix. The elements below the upper + Hessenberg part of the array A are not referenced. + If FACT = 'N', then the leading N-by-N part of this + array must contain the matrix A. + On exit, the leading N-by-N part of this array contains + the generalized Schur factor A_s of the matrix A. (A_s is + an upper quasitriangular matrix.) + E : (n, n) array_like + On entry, if FACT = 'F', then the leading N-by-N upper + triangular part of this array must contain the + generalized Schur factor E_s of the matrix E (see + definition (4) in section METHOD). The elements below the + upper triangular part of the array E are not referenced. + If FACT = 'N', then the leading N-by-N part of this + array must contain the coefficient matrix E of the + equation. + On exit, the leading N-by-N part of this array contains + the generalized Schur factor E_s of the matrix E. (E_s is + an upper triangular matrix.) + Q : (n, n) array_like + On entry, if FACT = 'F', then the leading N-by-N part of + this array must contain the orthogonal matrix Q from + the generalized Schur factorization (see definitions (3) + and (4) in section METHOD). + If FACT = 'N', Q need not be set on entry. + On exit, the leading N-by-N part of this array contains + the orthogonal matrix Q from the generalized Schur + factorization. + Z : (n, n) array_like + On entry, if FACT = 'F', then the leading N-by-N part of + this array must contain the orthogonal matrix Z from + the generalized Schur factorization (see definitions (3) + and (4) in section METHOD). + If FACT = 'N', Z need not be set on entry. + On exit, the leading N-by-N part of this array contains + the orthogonal matrix Z from the generalized Schur + factorization. + X : (n, n) array_like + On entry, if JOB = 'B' or 'X', then the leading N-by-N + part of this array must contain the right hand side matrix + Y of the equation. Either the lower or the upper + triangular part of this array is needed (see mode + parameter UPLO). + If JOB = 'S', X is not referenced. + On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then + the leading N-by-N part of this array contains the + solution matrix X of the equation. + If JOB = 'S', X is not referenced. + ldwork : int, optional + The length of the array DWORK. The following table + contains the minimal work space requirements depending + on the choice of JOB and FACT. + + :: + + JOB FACT | LDWORK + -------------------+------------------- + 'X' 'F' | MAX(1,N) + 'X' 'N' | MAX(1,4*N) + 'B', 'S' 'F' | MAX(1,2*N**2) + 'B', 'S' 'N' | MAX(1,2*N**2,4*N) + + For optimum performance, LDWORK should be larger. + Default: max(1,max(2*n*n,4*n)) + + Returns + ------- + A : (n, n) ndarray + On exit, the leading N-by-N part of this array contains + the generalized Schur factor A_s of the matrix A. (A_s is + an upper quasitriangular matrix.) + E : (n, n) ndarray + On exit, the leading N-by-N part of this array contains + the generalized Schur factor E_s of the matrix E. (E_s is + an upper triangular matrix.) + Q : (n, n) ndarray + On exit, the leading N-by-N part of this array contains + the orthogonal matrix Q from the generalized Schur + factorization. + Z : (n, n) ndarray + On exit, the leading N-by-N part of this array contains + the orthogonal matrix Z from the generalized Schur + factorization. + X : (n, n) ndarray + On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then + the leading N-by-N part of this array contains the + solution matrix X of the equation. + If JOB = 'S', X is not referenced. + scale : float + The scale factor set to avoid overflow in X. + (0 < SCALE <= 1) + sep : float + If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then + SEP contains an estimate of the separation of the + Lyapunov operator. + ferr : float + If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an + estimated forward error bound for the solution X. If XTRUE + is the true solution, FERR estimates the relative error + in the computed solution, measured in the Frobenius norm: + norm(X - XTRUE) / norm(XTRUE) + alphar, alphai, beta : (n, ) ndarray + If FACT = 'N' and INFO = 0, 3, or 4, then + (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the + eigenvalues of the matrix pencil A - lambda * E. + If FACT = 'F', ALPHAR, ALPHAI, and BETA are not + referenced. Raises ------ @@ -1900,12 +1914,18 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, To solve for X either the continuous-time algebraic Riccati equation - -1 - Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) + + :: + + -1 + Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) or the discrete-time algebraic Riccati equation - -1 - E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) + + :: + + -1 + E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N, M-by-M and N-by-M matrices, respectively, such that Q = C'C, @@ -1914,12 +1934,18 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, spectrum of the system, i.e., the stable eigenvalues lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is the optimal gain matrix, - -1 - F = R (L+E'XB)' , for (1), + + :: + + -1 + F = R (L+E'XB)' , for (1), and - -1 - F = (R+B'XB) (L+A'XB)' , for (2). + + :: + + -1 + F = (R+B'XB) (L+A'XB)' , for (2). -1 Optionally, matrix G = BR B' may be given instead of B and R. Other options include the case with Q and/or R given in a @@ -1936,206 +1962,176 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, solution even when matrix R is singular, under mild assumptions (see METHOD). The routine SG02AD works accordingly in this case. + Parameters + ---------- + dico : {'C', 'D'} + Specifies the type of Riccati equation to be solved as + follows: + := 'C': Equation (1), continuous-time case; + := 'D': Equation (2), discrete-time case. + jobb : {'B', 'G'} + Specifies whether or not the matrix G is given, instead + of the matrices B and R, as follows: + := 'B': B and R are given; + := 'G': G is given. + fact : {'N', 'C', 'D', 'B'} + Specifies whether or not the matrices Q and/or R (if + JOBB = 'B') are factored, as follows: + := 'N': Not factored, Q and R are given; + := 'C': C is given, and Q = C'C; + := 'D': D is given, and R = D'D; + := 'B': Both factors C and D are given, Q = C'C, R = D'D. + uplo : {'U', 'L'} + If JOBB = 'G', or FACT = 'N', specifies which triangle of + the matrices G, or Q and R, is stored, as follows: + := 'U': Upper triangle is stored; + := 'L': Lower triangle is stored. + jobl : {'Z', 'N'} + Specifies whether or not the matrix L is zero, as follows: + := 'Z': L is zero; + := 'N': L is nonzero. + JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. + SLICOT Library routine SB02MT should be called just before + SG02AD, for obtaining the results when JOBB = 'G' and + JOBL = 'N'. + scal : {'G', 'N'} + If JOBB = 'B', specifies whether or not a scaling strategy + should be used to scale Q, R, and L, as follows: + := 'G': General scaling should be used; + := 'N': No scaling should be used. + SCAL is not used if JOBB = 'G'. + sort : {'S', 'U'} + Specifies which eigenvalues should be obtained in the top + of the generalized Schur form, as follows: + := 'S': Stable eigenvalues come first; + := 'U': Unstable eigenvalues come first. + acc : {'R', 'N'} + Specifies whether or not iterative refinement should be + used to solve the system of algebraic equations giving + the solution matrix X, as follows: + := 'R': Use iterative refinement; + := 'N': Do not use iterative refinement. + N : int + The actual state dimension, i.e., the order of the + matrices A, E, Q, and X, and the number of rows of the + matrices B and L. N > 0. + M : int + The number of system inputs. If JOBB = 'B', M is the + order of the matrix R, and the number of columns of the + matrix B. M >= 0. + M is not used if JOBB = 'G'. + P : int + The number of system outputs. If FACT = 'C' or 'D' or 'B', + P is the number of rows of the matrices C and/or D. + P >= 0. + Otherwise, P is not used. + A : (max(1, N), N) array_like + The leading N-by-N part of this array must contain the + state matrix A of the descriptor system. + E : (max(1, N), N) array_like + The leading N-by-N part of this array must contain the + matrix E of the descriptor system. + B : (max(1, N), *) array_like + If JOBB = 'B', the leading N-by-M part of this array must + contain the input matrix B of the system. + If JOBB = 'G', the leading N-by-N upper triangular part + (if UPLO = 'U') or lower triangular part (if UPLO = 'L') + of this array must contain the upper triangular part or + lower triangular part, respectively, of the matrix + ``G = BR{^-1}B'``. The stricly lower triangular part (if + UPLO = 'U') or stricly upper triangular part (if + UPLO = 'L') is not referenced. + Q : (ldq, N) array_like + If FACT = 'N' or 'D', the leading N-by-N upper triangular + part (if UPLO = 'U') or lower triangular part (if UPLO = + 'L') of this array must contain the upper triangular part + or lower triangular part, respectively, of the symmetric + state weighting matrix Q. The stricly lower triangular + part (if UPLO = 'U') or stricly upper triangular part (if + UPLO = 'L') is not referenced. + If FACT = 'C' or 'B', the leading P-by-N part of this + array must contain the output matrix C of the system. + If JOBB = 'B' and SCAL = 'G', then Q is modified + internally, but is restored on exit. + The leading dimension of array Q:: - - - Required arguments - ------------------ - - dico : input string(len=1) - Specifies the type of Riccati equation to be solved as - follows: - = 'C': Equation (1), continuous-time case; - = 'D': Equation (2), discrete-time case. - - jobb : input string(len=1) - Specifies whether or not the matrix G is given, instead - of the matrices B and R, as follows: - = 'B': B and R are given; - = 'G': G is given. - - fact : input string(len=1) - Specifies whether or not the matrices Q and/or R (if - JOBB = 'B') are factored, as follows: - = 'N': Not factored, Q and R are given; - = 'C': C is given, and Q = C'C; - = 'D': D is given, and R = D'D; - = 'B': Both factors C and D are given, Q = C'C, R = D'D. - - uplo : input string(len=1) - If JOBB = 'G', or FACT = 'N', specifies which triangle of - the matrices G, or Q and R, is stored, as follows: - = 'U': Upper triangle is stored; - = 'L': Lower triangle is stored. - - jobl : input string(len=1) - Specifies whether or not the matrix L is zero, as follows: - = 'Z': L is zero; - = 'N': L is nonzero. - JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. - SLICOT Library routine SB02MT should be called just before - SG02AD, for obtaining the results when JOBB = 'G' and - JOBL = 'N'. - - scal : input string(len=1) - If JOBB = 'B', specifies whether or not a scaling strategy - should be used to scale Q, R, and L, as follows: - = 'G': General scaling should be used; - = 'N': No scaling should be used. - SCAL is not used if JOBB = 'G'. - - sort : input string(len=1) - Specifies which eigenvalues should be obtained in the top - of the generalized Schur form, as follows: - = 'S': Stable eigenvalues come first; - = 'U': Unstable eigenvalues come first. - - acc : input string(len=1) - Specifies whether or not iterative refinement should be - used to solve the system of algebraic equations giving - the solution matrix X, as follows: - = 'R': Use iterative refinement; - = 'N': Do not use iterative refinement. - - N : input int - The actual state dimension, i.e., the order of the - matrices A, E, Q, and X, and the number of rows of the - matrices B and L. N > 0. - M : input int - The number of system inputs. If JOBB = 'B', M is the - order of the matrix R, and the number of columns of the - matrix B. M >= 0. - M is not used if JOBB = 'G'. - - P : input int out = _wrapper.sg02ad_bn(dico,uplo,jobl,scal,sort,acc,N,M,A,E,B,Q,R,L,tol,ldwork) - The number of system outputs. If FACT = 'C' or 'D' or 'B', - P is the number of rows of the matrices C and/or D. - P >= 0. - Otherwise, P is not used. - - A : input rank-2 array('d') with bounds (max(1,N),N) - The leading N-by-N part of this array must contain the - state matrix A of the descriptor system. - - E : input rank-2 array('d') with bounds (max(1,N),N) - The leading N-by-N part of this array must contain the - matrix E of the descriptor system. - - B : input rank-2 array('d') with bounds (max(1,N),*) - If JOBB = 'B', the leading N-by-M part of this array must - contain the input matrix B of the system. - If JOBB = 'G', the leading N-by-N upper triangular part - (if UPLO = 'U') or lower triangular part (if UPLO = 'L') - of this array must contain the upper triangular part or - lower triangular part, respectively, of the matrix - -1 - G = BR B'. The stricly lower triangular part (if - UPLO = 'U') or stricly upper triangular part (if - UPLO = 'L') is not referenced. - - - Q : input rank-2 array('d') with bounds (ldq,N) - If FACT = 'N' or 'D', the leading N-by-N upper triangular - part (if UPLO = 'U') or lower triangular part (if UPLO = - 'L') of this array must contain the upper triangular part - or lower triangular part, respectively, of the symmetric - state weighting matrix Q. The stricly lower triangular - part (if UPLO = 'U') or stricly upper triangular part (if - UPLO = 'L') is not referenced. - If FACT = 'C' or 'B', the leading P-by-N part of this - array must contain the output matrix C of the system. - If JOBB = 'B' and SCAL = 'G', then Q is modified - internally, but is restored on exit. - - The leading dimension of array Q. LDQ >= MAX(1,N) if FACT = 'N' or 'D'; LDQ >= MAX(1,P) if FACT = 'C' or 'B'. - R : input rank-2 array('d') with bounds (ldr,M) - If FACT = 'N' or 'C', the leading M-by-M upper triangular - part (if UPLO = 'U') or lower triangular part (if UPLO = - 'L') of this array must contain the upper triangular part - or lower triangular part, respectively, of the symmetric - input weighting matrix R. The stricly lower triangular - part (if UPLO = 'U') or stricly upper triangular part (if - UPLO = 'L') is not referenced. - If FACT = 'D' or 'B', the leading P-by-M part of this - array must contain the direct transmission matrix D of the - system. - If JOBB = 'B' and SCAL = 'G', then R is modified - internally, but is restored on exit. - If JOBB = 'G', this array is not referenced. - - The leading dimension of array R. + R : (ldr, M) array_like + If FACT = 'N' or 'C', the leading M-by-M upper triangular + part (if UPLO = 'U') or lower triangular part (if UPLO = + 'L') of this array must contain the upper triangular part + or lower triangular part, respectively, of the symmetric + input weighting matrix R. The stricly lower triangular + part (if UPLO = 'U') or stricly upper triangular part (if + UPLO = 'L') is not referenced. + If FACT = 'D' or 'B', the leading P-by-M part of this + array must contain the direct transmission matrix D of the + system. + If JOBB = 'B' and SCAL = 'G', then R is modified + internally, but is restored on exit. + If JOBB = 'G', this array is not referenced. + The leading dimension of array R:: + LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; LDR >= 1 if JOBB = 'G'. + L : (n, M) array_like + If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of + this array must contain the cross weighting matrix L. + If JOBB = 'B' and SCAL = 'G', then L is modified + internally, but is restored on exit. + If JOBL = 'Z' or JOBB = 'G', this array is not referenced. + ldwork : int, optional + The length of the array DWORK:: + + LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; + LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. + For optimum performance LDWORK should be larger. + Default: ``max(7*(2*n+1)+16,16*n)`` + tol : float, optional + The tolerance to be used to test for near singularity of + the original matrix pencil, specifically of the triangular + M-by-M factor obtained during the reduction process. If + the user sets TOL > 0, then the given value of TOL is used + as a lower bound for the reciprocal condition number of + that matrix; a matrix whose estimated condition number is + less than 1/TOL is considered to be nonsingular. If the + user sets TOL <= 0, then a default tolerance, defined by + TOLDEF = EPS, is used instead, where EPS is the machine + precision (see LAPACK Library routine DLAMCH). + This parameter is not referenced if JOBB = 'G'. - - L : input rank-2 array('d') with bounds (n,M) - If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of - this array must contain the cross weighting matrix L. - If JOBB = 'B' and SCAL = 'G', then L is modified - internally, but is restored on exit. - If JOBL = 'Z' or JOBB = 'G', this array is not referenced. - - - Optional arguments - ------------------ - - ldwork := max(7*(2*n+1)+16,16*n) input int - The length of the array DWORK. - LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; - LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. - For optimum performance LDWORK should be larger. - - tol := -1 input float - The tolerance to be used to test for near singularity of - the original matrix pencil, specifically of the triangular - M-by-M factor obtained during the reduction process. If - the user sets TOL > 0, then the given value of TOL is used - as a lower bound for the reciprocal condition number of - that matrix; a matrix whose estimated condition number is - less than 1/TOL is considered to be nonsingular. If the - user sets TOL <= 0, then a default tolerance, defined by - TOLDEF = EPS, is used instead, where EPS is the machine - precision (see LAPACK Library routine DLAMCH). - This parameter is not referenced if JOBB = 'G'. - - - - - Return objects - -------------- - rcondu : float - If N > 0 and INFO = 0 or INFO = 7, an estimate of the - reciprocal of the condition number (in the 1-norm) of - the N-th order system of algebraic equations from which - the solution matrix X is obtained. - - X : rank-2 array('d') with bounds (n,n) - If INFO = 0, the leading N-by-N part of this array - contains the solution matrix X of the problem. - - alfar : rank-1 array('d') with bounds (2 * n) - - alfai : rank-1 array('d') with bounds (2 * n) - - beta : rank-1 array('d') with bounds (2 * n) - The generalized eigenvalues of the 2N-by-2N matrix pair, - ordered as specified by SORT (if INFO = 0, or INFO >= 5). - For instance, if SORT = 'S', the leading N elements of - these arrays contain the closed-loop spectrum of the - system. Specifically, - lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for - k = 1,2,...,N. - - S : rank-2 array('d') with bounds (2 * n,2 * n) - The leading 2N-by-2N part of this array contains the - ordered real Schur form S of the first matrix in the - reduced matrix pencil associated to the optimal problem, - corresponding to the scaled Q, R, and L, if JOBB = 'B' - and SCAL = 'G'. That is, + Returns + ------- + rcondu : float + If N > 0 and INFO = 0 or INFO = 7, an estimate of the + reciprocal of the condition number (in the 1-norm) of + the N-th order system of algebraic equations from which + the solution matrix X is obtained. + X : (n, n) ndarray + If INFO = 0, the leading N-by-N part of this array + contains the solution matrix X of the problem. + alfar, alfai, beta : (2*n, ) ndarray + The generalized eigenvalues of the 2N-by-2N matrix pair, + ordered as specified by SORT (if INFO = 0, or INFO >= 5). + For instance, if SORT = 'S', the leading N elements of + these arrays contain the closed-loop spectrum of the + system. Specifically, + + :: + + lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for k = 1,2,...,N. + + S : (2*n, 2*n) ndarray + The leading 2N-by-2N part of this array contains the + ordered real Schur form S of the first matrix in the + reduced matrix pencil associated to the optimal problem, + corresponding to the scaled Q, R, and L, if JOBB = 'B' + and SCAL = 'G'. That is, + + :: (S S ) ( 11 12) @@ -2144,17 +2140,18 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, ( 22) where S , S and S are N-by-N matrices. - 11 12 22 - Array S must have 2*N+M columns if JOBB = 'B', and 2*N - columns, otherwise. + 11 12 22 + Array S must have 2*N+M columns if JOBB = 'B', and 2*N + columns, otherwise. + T : (2*n, 2*n) ndarray + The leading 2N-by-2N part of this array contains the + ordered upper triangular form T of the second matrix in + the reduced matrix pencil associated to the optimal + problem, corresponding to the scaled Q, R, and L, if + JOBB = 'B' and SCAL = 'G'. That is, - T : rank-2 array('d') with bounds (2 * n,2 * n) - The leading 2N-by-2N part of this array contains the - ordered upper triangular form T of the second matrix in - the reduced matrix pencil associated to the optimal - problem, corresponding to the scaled Q, R, and L, if - JOBB = 'B' and SCAL = 'G'. That is, + :: (T T ) ( 11 12) @@ -2163,13 +2160,15 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, ( 22) where T , T and T are N-by-N matrices. - 11 12 22 + 11 12 22 + + U : (2*n, 2*n) ndarray + The leading 2N-by-2N part of this array contains the right + transformation matrix U which reduces the 2N-by-2N matrix + pencil to the ordered generalized real Schur form (S, T). + That is, - U : rank-2 array('d') with bounds (2 * n,2 * n) - The leading 2N-by-2N part of this array contains the right - transformation matrix U which reduces the 2N-by-2N matrix - pencil to the ordered generalized real Schur form (S,T). - That is, + :: (U U ) ( 11 12) @@ -2178,13 +2177,13 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, ( 21 22) where U , U , U and U are N-by-N matrices. - 11 12 21 22 - If JOBB = 'B' and SCAL = 'G', then U corresponds to the - scaled pencil. If a basis for the stable deflating - subspace of the original problem is needed, then the - submatrix U must be multiplied by the scaling factor - 21 - contained in DWORK(4). + 11 12 21 22 + + If JOBB = 'B' and SCAL = 'G', then U corresponds to the + scaled pencil. If a basis for the stable deflating + subspace of the original problem is needed, then the + submatrix U_21 must be multiplied by the scaling factor + contained in DWORK(4). Raises ------ @@ -2260,13 +2259,17 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): """U,scale,alpha = sg03bd(dico,n,m,A,E,Q,Z,B,[fact,trans,ldwork]) - To compute the Cholesky factor U of the matrix X, + To compute the Cholesky factor U of the matrix X, + + :: T X = op(U) * op(U), - which is the solution of either the generalized - c-stable continuous-time Lyapunov equation + which is the solution of either the generalized + c-stable continuous-time Lyapunov equation + + :: T T op(A) * X * op(E) + op(E) * X * op(A) @@ -2274,7 +2277,9 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): 2 T = - SCALE * op(B) * op(B), (1) - or the generalized d-stable discrete-time Lyapunov equation + or the generalized d-stable discrete-time Lyapunov equation + + :: T T op(A) * X * op(A) - op(E) * X * op(E) @@ -2282,119 +2287,114 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): 2 T = - SCALE * op(B) * op(B), (2) - without first finding X and without the need to form the matrix - op(B)**T * op(B). - - op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N - matrices, op(B) is an M-by-N matrix. The resulting matrix U is an - N-by-N upper triangular matrix with non-negative entries on its - main diagonal. SCALE is an output scale factor set to avoid - overflow in U. - - In the continuous-time case (1) the pencil A - lambda * E must be - c-stable (that is, all eigenvalues must have negative real parts). - In the discrete-time case (2) the pencil A - lambda * E must be - d-stable (that is, the moduli of all eigenvalues must be smaller - than one). - - Required arguments - __________________ - - n : input int - The order of the matrix A. n >= 0. - m : input int - The number of rows in the matrix op(B). m >= 0. - A : input rank-2 array('d'), shape (n,n) - On entry, if fact = 'F', then the leading n-by-n upper - Hessenberg part of this array must contain the - generalized Schur factor A_s of the matrix A (see - definition (3) in section METHOD). A_s must be an upper - quasitriangular matrix. The elements below the upper - Hessenberg part of the array A are not referenced. - If fact = 'N', then the leading n-by-n part of this - array must contain the matrix A. - On exit, the leading n-by-n part of this array contains - the generalized Schur factor A_s of the matrix A. (A_s is - an upper quasitriangular matrix.) - E : input rank-2 array('d'), shape (n,n) - On entry, if fact = 'F', then the leading n-by-n upper - triangular part of this array must contain the - generalized Schur factor E_s of the matrix E (see - definition (4) in section METHOD). The elements below the - upper triangular part of the array E are not referenced. - If fact = 'N', then the leading n-by-n part of this - array must contain the coefficient matrix E of the - equation. - On exit, the leading n-by-n part of this array contains - the generalized Schur factor E_s of the matrix E. (E_s is - an upper triangular matrix.) - Q : input rank-2 array('d'), shape (n,n) - On entry, if fact = 'F', then the leading n-by-n part of - this array must contain the orthogonal matrix Q from - the generalized Schur factorization (see definitions (3) - and (4) in section METHOD). - If fact = 'N', Q need not be set on entry. - On exit, the leading n-by-n part of this array contains - the orthogonal matrix Q from the generalized Schur - factorization. - Z : input rank-2 array('d'), shape (n,n) - On entry, if fact = 'F', then the leading n-by-n part of - this array must contain the orthogonal matrix Z from - the generalized Schur factorization (see definitions (3) - and (4) in section METHOD). - If fact = 'N', Z need not be set on entry. - On exit, the leading n-by-n part of this array contains - the orthogonal matrix Z from the generalized Schur - factorization. - B : input rank-2 array('d'), shape (n,n1) - On entry, if trans = 'T', the leading n-by-m part of this - array must contain the matrix B and n1 >= max(m,n). - If trans = 'N', the leading m-by-n part of this array - must contain the matrix B and n1 >= n. - On exit, the leading n-by-n part of this array contains - the Cholesky factor U of the solution matrix X of the - problem, X = op(U)**T * op(U). - If m = 0 and n > 0, then U is set to zero. - dico : input string(len=1) - Specifies which type of the equation is considered: - = 'C': Continuous-time equation (1); - = 'D': Discrete-time equation (2). - - Optional arguments - __________________ - - fact := 'N' input string(len=1) - Specifies whether the generalized real Schur - factorization of the pencil A - lambda * E is supplied - on entry or not: - = 'N': Factorization is not supplied; - = 'F': Factorization is supplied. - trans := 'N' input string(len=1) - Specifies whether the transposed equation is to be solved - or not: - = 'N': op(A) = A, op(E) = E; - = 'T': op(A) = A**T, op(E) = E**T. - ldwork := None input int - The dimension of the array dwork. - ldwork >= max(1,4*n,6*n-6), if fact = 'N'; - ldwork >= max(1,2*n,6*n-6), if fact = 'F'. - For good performance, ldwork should be larger. - - Return objects - ______________ - - U : rank-2 array('d'), shape (n,n) - The leading n-by-b part of this array contains - the Cholesky factor U of the solution matrix X of the - problem, X = op(U)**T * op(U). - If m = 0 and m > 0, then U is set to zero. - scale : float - The scale factor set to avoid overflow in U. - 0 < scale <= 1. - alpha : rank-1 array('c'), shape (n) - If INFO = 0, 3, 5, 6, or 7, then - (alpha(j), j=1,...,n, are the - eigenvalues of the matrix pencil A - lambda * E. + without first finding X and without the need to form the matrix + op(B)**T * op(B). + + op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N + matrices, op(B) is an M-by-N matrix. The resulting matrix U is an + N-by-N upper triangular matrix with non-negative entries on its + main diagonal. SCALE is an output scale factor set to avoid + overflow in U. + + In the continuous-time case (1) the pencil A - lambda * E must be + c-stable (that is, all eigenvalues must have negative real parts). + In the discrete-time case (2) the pencil A - lambda * E must be + d-stable (that is, the moduli of all eigenvalues must be smaller + than one). + + Parameters + __________ + n : int + The order of the matrix A. n >= 0. + m : int + The number of rows in the matrix op(B). m >= 0. + A : (n, n) array_like + On entry, if fact = 'F', then the leading n-by-n upper + Hessenberg part of this array must contain the + generalized Schur factor A_s of the matrix A (see + definition (3) in section METHOD). A_s must be an upper + quasitriangular matrix. The elements below the upper + Hessenberg part of the array A are not referenced. + If fact = 'N', then the leading n-by-n part of this + array must contain the matrix A. + On exit, the leading n-by-n part of this array contains + the generalized Schur factor A_s of the matrix A. (A_s is + an upper quasitriangular matrix.) + E : (n, n) array_like + On entry, if fact = 'F', then the leading n-by-n upper + triangular part of this array must contain the + generalized Schur factor E_s of the matrix E (see + definition (4) in section METHOD). The elements below the + upper triangular part of the array E are not referenced. + If fact = 'N', then the leading n-by-n part of this + array must contain the coefficient matrix E of the + equation. + On exit, the leading n-by-n part of this array contains + the generalized Schur factor E_s of the matrix E. (E_s is + an upper triangular matrix.) + Q : (n, n) array_like + On entry, if fact = 'F', then the leading n-by-n part of + this array must contain the orthogonal matrix Q from + the generalized Schur factorization (see definitions (3) + and (4) in section METHOD). + If fact = 'N', Q need not be set on entry. + On exit, the leading n-by-n part of this array contains + the orthogonal matrix Q from the generalized Schur + factorization. + Z : (n, n) array_like + On entry, if fact = 'F', then the leading n-by-n part of + this array must contain the orthogonal matrix Z from + the generalized Schur factorization (see definitions (3) + and (4) in section METHOD). + If fact = 'N', Z need not be set on entry. + On exit, the leading n-by-n part of this array contains + the orthogonal matrix Z from the generalized Schur + factorization. + B : (n, n1) array_like + On entry, if trans = 'T', the leading n-by-m part of this + array must contain the matrix B and n1 >= max(m, n). + If trans = 'N', the leading m-by-n part of this array + must contain the matrix B and n1 >= n. + On exit, the leading n-by-n part of this array contains + the Cholesky factor U of the solution matrix X of the + problem, X = op(U)**T * op(U). + If m = 0 and n > 0, then U is set to zero. + dico : {C, D} + Specifies which type of the equation is considered: + := 'C': Continuous-time equation (1); + := 'D': Discrete-time equation (2). + fact : {'N', 'F'}, optional + Specifies whether the generalized real Schur + factorization of the pencil A - lambda * E is supplied + on entry or not: + := 'N': Factorization is not supplied; + := 'F': Factorization is supplied. + trans : {'N', 'T'}, optional + Specifies whether the transposed equation is to be solved + or not: + := 'N': op(A) = A, op(E) = E; + := 'T': op(A) = A**T, op(E) = E**T. + ldwork : int, optional + The dimension of the array dwork:: + + ldwork >= max(1,4*n,6*n-6), if fact = 'N'; + ldwork >= max(1,2*n,6*n-6), if fact = 'F'. + For good performance, ldwork should be larger. + + Returns + _______ + U : (n, n) ndarray + The leading n-by-b part of this array contains + the Cholesky factor U of the solution matrix X of the + problem, X = op(U)**T * op(U). + If m = 0 and m > 0, then U is set to zero. + scale : float + The scale factor set to avoid overflow in U. + 0 < scale <= 1. + alpha : (n, ) complex ndarray + If INFO = 0, 3, 5, 6, or 7, then + (alpha(j), j=1,...,n, are the + eigenvalues of the matrix pencil A - lambda * E. Raises ------ From ad28baa03a15a3f6e514b130474821cca67b8bac Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 19:01:46 +0200 Subject: [PATCH 186/405] minor cosmetics in math.py and synthesis.py docstrings [skip ci] --- slycot/math.py | 11 +++++------ slycot/synthesis.py | 14 +++++++------- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 06e24548..e59d4ea4 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -617,8 +617,7 @@ def mb05md(a, delta, balanc='N'): the matrix product ``exp(Lambda*delta)`` times the inverse of the (right) eigenvector matrix of `A`, where `Lambda` is the diagonal matrix of eigenvalues. - - w : (n,) real or complex ndarray + w : (n, ) real or complex ndarray Contains the eigenvalues of the matrix `A`. The eigenvalues are unordered except that complex conjugate pairs of values appear consecutively with the eigenvalue having positive @@ -672,7 +671,7 @@ def mb05nd(a, delta, tol=1e-7): Parameters ---------- - A : (n,n) array_like + A : (n, n) array_like Square matrix delta : float The scalar value delta of the problem. @@ -681,9 +680,9 @@ def mb05nd(a, delta, tol=1e-7): Returns ------- - F : ndarray + F : (n n) ndarray exp(A*delta) - H : ndarray + H : (n, n) ndarray Int[F(s) ds] from s = 0 to s = delta, Raises @@ -734,7 +733,7 @@ def mc01td(dico, dp, p): dp : int The degree of the polynomial `P(x)`. ``dp >= 0``. - p : (dp+1,) array_like + p : (dp+1, ) array_like This array must contain the coefficients of `P(x)` in increasing powers of `x`. diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 9ebed7d5..f00281fd 100755 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -254,7 +254,7 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): An estimate of the reciprocal of the condition number (in the 1-norm) of the n-th order system of algebraic equations from which the solution matrix X is obtained. - w : (2*n) complex ndarray + w : (2*n, ) complex ndarray This array contain the eigenvalues of the 2n-by-2n matrix S, ordered as specified by sort (except for the case hinv = 'D', when the order is opposite to that specified by sort). The leading n elements of @@ -583,17 +583,17 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw An estimate of the reciprocal of the condition number (in the 1-norm) of the n-th order system of algebraic equations from which the solution matrix X is obtained. - w : (2 * n) complex array_like + w : (2*n, ) complex array_like The generalized eigenvalues of the 2n-by-2n matrix pair, ordered as specified by sort. For instance, if sort = 'S', the leading n elements of these arrays contain the closed-loop spectrum of the system matrix A - BF, where F is the optimal feedback matrix computed based on the solution matrix X. - S : (2*n+m, 2 * n) array_like + S : (2*n+m, 2*n) array_like This array contains the ordered real Schur form S of the first matrix in the reduced matrix pencil associated to the optimal problem, or of the corresponding Hamiltonian matrix - T : (2*n+m+1, 2 * n) array_like + T : (2*n+m+1, 2*n) array_like This array contains the ordered upper triangular form T of the second matrix in the reduced matrix pencil associated to the optimal problem. @@ -1184,11 +1184,11 @@ def sb10ad(n,m,np,ncon,nmeas,gamma,A,B,C,D,job=3,gtol=0.0,actol=0.0,liwork=None, The controller output matrix Ck. Dk : (ncon, nmeas) ndarray The controller input/output matrix DK. - Ac : (2n, 2n) ndarray + Ac : (2*n, 2*n) ndarray The closed-loop system state matrix AC. - Bc : (2n, m-ncon) ndarray + Bc : (2*n, m-ncon) ndarray The closed-loop system input matrix BC. - Cc : (np-nmeas, 2n) ndarray + Cc : (np-nmeas, 2*n) ndarray The closed-loop system output matrix CC. Dc : (np-nmeas, m-ncon) ndarray The the closed-loop system input/output matrix DC. From 82b653a9bc6b96845045e10eca1a9c6fde22e1e1 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 19:19:34 +0200 Subject: [PATCH 187/405] fix infospec detection regex --- slycot/exceptions.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index 3e789a04..eb8cb852 100644 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -96,7 +96,7 @@ def _parse_docsection(section_name, docstring, checkvars): # new infospec if slycot_error: imatch = re.match( - r'(\s{' + str(error_indent + 1) + r',}):(.*):\s*(.*)', l) + r'(\s{' + str(error_indent + 1) + r',}):(.+):\s*(.*)', l) if imatch: infospec_indent = len(imatch.group(1)) infospec = imatch.group(2) From 8f6092376bb4bc1022791ce21c11033aa930b050 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 20:27:24 +0200 Subject: [PATCH 188/405] fix iwarn catchall and checkvars initialization --- slycot/exceptions.py | 10 ++++++---- slycot/tests/test_exceptions.py | 19 ++++++++++--------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/slycot/exceptions.py b/slycot/exceptions.py index eb8cb852..f08bb3f6 100644 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -131,7 +131,7 @@ def _parse_docsection(section_name, docstring, checkvars): return (slycot_error, message) -def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): +def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars=None): """Raise exceptions or warnings if slycot info returned is non-zero. Parameters @@ -221,6 +221,8 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): iwarn, info = info except TypeError: iwarn = None + if not checkvars: + checkvars = {} if docstring and (iwarn or info): # possibly override info with mandatory argument checkvars['info'] = info @@ -247,11 +249,11 @@ def raise_if_slycot_error(info, arg_list=None, docstring=None, checkvars={}): # catch all if info > 0: raise SlycotError("Caught unhandled nonzero INFO value {}" - .format(info), + "".format(info), info) - if not iwarn and 'iwarn' in checkvars: + if iwarn is None and 'iwarn' in checkvars: iwarn = checkvars['iwarn'] if iwarn: warn(SlycotWarning("Caught unhandled nonzero IWARN value {}" - .format(iwarn), + "".format(iwarn), iwarn, info)) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 178c0422..631a4cb7 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -74,16 +74,17 @@ def test_standard_info_error(): assert ex_info.value.info == -2 -def test_unhandled_info(): +def test_unhandled_info_iwarn(): with pytest.raises(SlycotError) as ex_info: - raise_if_slycot_error(2, [], docstring="no valid docstring") - assert ex_info.value.info == 2 - with pytest.warns(SlycotWarning) as wm: - raise_if_slycot_error([1, 0], [], docstring="no valid docstring") - assert wm[0].message.iwarn == 1 - assert wm[0].message.info == 0 + raise_if_slycot_error(100, [], docstring="no valid docstring") + assert ex_info.value.info == 100 with pytest.warns(SlycotWarning) as wm: + raise_if_slycot_error([101, 0], [], docstring="no valid docstring") raise_if_slycot_error(0, [], docstring="no valid docstring", - checkvars={'iwarn': 1}) - assert wm[0].message.iwarn == 1 + checkvars={'iwarn': 102}) + assert wm[0].message.iwarn == 101 assert wm[0].message.info == 0 + assert wm[1].message.iwarn == 102 + assert wm[1].message.info == 0 + + From 91fb7e6567d59c622e7c7c80b7f01fb2be5039a7 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 7 May 2020 21:06:14 +0200 Subject: [PATCH 189/405] revert file mode changes for py files [skip ci] --- slycot/synthesis.py | 0 slycot/tests/test_mb.py | 0 slycot/tests/test_sg02ad.py | 0 3 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 slycot/synthesis.py mode change 100644 => 100755 slycot/tests/test_mb.py mode change 100644 => 100755 slycot/tests/test_sg02ad.py diff --git a/slycot/synthesis.py b/slycot/synthesis.py old mode 100755 new mode 100644 diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py old mode 100644 new mode 100755 diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py old mode 100644 new mode 100755 From fd74855d3917a44ceb2aea904bf69c7697f09b93 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 7 May 2020 21:34:02 +0200 Subject: [PATCH 190/405] comma in mb05nd docstring [skip ci] --- slycot/math.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/math.py b/slycot/math.py index e59d4ea4..10583330 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -680,7 +680,7 @@ def mb05nd(a, delta, tol=1e-7): Returns ------- - F : (n n) ndarray + F : (n, n) ndarray exp(A*delta) H : (n, n) ndarray Int[F(s) ds] from s = 0 to s = delta, From f528c17eed1e10839445ab2a95e2fed30abb1d17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 21:24:55 +0200 Subject: [PATCH 191/405] add sb10fd, an alternative routine for H-infinity control --- slycot/__init__.py | 2 +- slycot/src/synthesis.pyf | 31 ++++++ slycot/synthesis.py | 209 +++++++++++++++++++++++++++++++++++++++ slycot/tests/test_sb.py | 65 ++++++++++++ 4 files changed, 306 insertions(+), 1 deletion(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 981f43ac..fdf84c6b 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -30,7 +30,7 @@ # Synthesis routines (14/50 wrapped) from .synthesis import sb01bd,sb02md,sb02mt,sb02od,sb03md,sb03od from .synthesis import sb04md,sb04qd,sb10ad,sb10dd,sb10hd,sg03ad - from .synthesis import sg02ad, sg03bd + from .synthesis import sg02ad, sg03bd, sb10fd # Transformation routines (9/40 wrapped) from .transform import tb01id, tb03ad, tb04ad diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index 56e53721..3dc0a28b 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -490,6 +490,37 @@ subroutine sb10dd(n,m,np,ncon,nmeas,gamma,a,lda,b,ldb,c,ldc,d,ldd,ak,ldak,bk,ldb logical intent(hide,cache), dimension(2*n), depend(n) :: bwork integer intent(out) :: info end subroutine sb10dd +subroutine sb10fd(n,m,np,ncon,nmeas,gamma,a,lda,b,ldb,c,ldc,d,ldd,ak,ldak,bk,ldbk,ck,ldck,dk,lddk,rcond,tol,iwork,dwork,ldwork,bwork,info) ! in SB10FD.f + integer intent(in),check(n>=0) :: n + integer intent(in),check(m>=0) :: m + integer intent(in),check(np>=0) :: np + integer intent(in),check(m>=ncon && ncon>=0 && np-nmeas>=ncon),depend(m,ncon):: ncon + integer intent(in),check(np>=nmeas && nmeas>=0 && m-ncon>=nmeas),depend(np,ncon):: nmeas + double precision intent(in),check(gamma>=0.0) :: gamma + double precision intent(in),dimension(n,n),depend(n) :: a + integer intent(hide),depend(a) :: lda=shape(a,0) + double precision intent(in),dimension(n,m),depend(n,m) :: b + integer intent(hide),depend(b) :: ldb=shape(b,0) + double precision intent(in),dimension(np,n),depend(np,n) :: c + integer intent(hide),depend(c) :: ldc=shape(c,0) + double precision intent(in),dimension(np,m),depend(np,m) :: d + integer intent(hide),depend(d) :: ldd=shape(d,0) + double precision intent(out),dimension(n,n) :: ak + integer intent(hide),depend(ak) :: ldak=shape(ak,0) + double precision intent(out),dimension(n,nmeas) :: bk + integer intent(hide),depend(bk) :: ldbk=shape(bk,0) + double precision intent(out),dimension(ncon,n) :: ck + integer intent(hide),depend(ck) :: ldck=shape(ck,0) + double precision intent(out),dimension(ncon,nmeas) :: dk + integer intent(hide),depend(dk) :: lddk=shape(dk,0) + double precision intent(out),dimension(4) :: rcond + double precision intent(in) :: tol + integer intent(hide,cache),dimension(max(2*max(n,m-ncon),2*max(np-nmeas,ncon)),n*n),depend(n,m,ncon,np,nmeas) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork + integer intent(in) :: ldwork + logical intent(hide,cache),dimension(2*n),depend(n) :: bwork + integer intent(out) :: info +end subroutine sb10fd subroutine sb10hd(n,m,np,ncon,nmeas,a,lda,b,ldb,c,ldc,d,ldd,ak,ldak,bk,ldbk,ck,ldck,dk,lddk,rcond,tol,iwork,dwork,ldwork,bwork,info) ! in :python-control:SB10HD.f integer check(n>0) :: n integer check(m>0) :: m diff --git a/slycot/synthesis.py b/slycot/synthesis.py index f00281fd..712daef5 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2448,3 +2448,212 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): alpha.real = alphar[0:n] alpha.imag = alphai[0:n] return U,scale,alpha/beta + +def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): + """ AK,BK,CK,DK,rcond = \ + sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,[tol,ldwork]) + + To compute the matrices of an H-infinity (sub)optimal n-state + controller + + | AK | BK | + K = |----|----|, + | CK | DK | + + using modified Glover's and Doyle's 1988 formulas, for the system + + | A | B1 B2 | | A | B | + P = |----|---------| = |---|---| + | C1 | D11 D12 | | C | D | + | C2 | D21 D22 | + + and for a given value of gamma, where B2 has as column size the + number of control inputs (NCON) and C2 has as row size the number + of measurements (NMEAS) being provided to the controller. + + It is assumed that + + (A1) (A,B2) is stabilizable and (C2,A) is detectable, + + (A2) D12 is full column rank and D21 is full row rank, + + (A3) | A-j*omega*I B2 | has full column rank for all omega, + | C1 D12 | + + (A4) | A-j*omega*I B1 | has full row rank for all omega. + | C2 D21 | + + Required arguments + ------------------ + + n : int + The order of the system. (size of matrix A). + m : int + The column size of the matrix B + np : int + The row size of the matrix C + ncon : int + The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. + nmeas : int + The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. + gamma : float + The value of gamma. It is assumed that gamma is + sufficiently large so that the controller is admissible. + gamma >= 0. + A : rank-2 array('d'), shape (n,n) + B : rank-2 array('d'), shape (n,m) + C : rank-2 array('d'), shape (np,n) + D : rank-2 array('d'), shape (np,m) + + Optional arguments + ------------------ + + tol : float + Tolerance used for controlling the accuracy of the applied + transformations for computing the normalized form in + SLICOT Library routine SB10PD. Transformation matrices + whose reciprocal condition numbers are less than tol are + not allowed. If tol <= 0, then a default value equal to + sqrt(eps) is used, where eps is the relative machine + precision. + + ldwork : int + The dimension of the cache array. + LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + + max(1,LW1,LW2,LW3,LW4,LW5,LW6), where + LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), + LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), + LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), + LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), + LW5 = 2*N*N + N*(M+NP) + + max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), + NP*NP + max(2*NP1,3*N*N + + max(N*NP,10*N*N+12*N+5))), + LW6 = 2*N*N + N*(M+NP) + + max(1, M2*NP2 + NP2*NP2 + M2*M2 + + max(D1*D1 + max(2*D1, (D1+D2)*NP2), + D2*D2 + max(2*D2, D2*M2), 3*N, + N*(2*NP2 + M2) + + max(2*N*M2, M2*NP2 + + max(M2*M2+3*M2, NP2*(2*NP2+ + M2+max(NP2,N)))))), + with D1 = NP1 - M2, D2 = M1 - NP2, + NP1 = NP - NP2, M1 = M - M2. + For good performance, LDWORK must generally be larger. + Denoting Q = max(M1,M2,NP1,NP2), an upper bound is + 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), + 2*N*(N+2*Q)+max(1,4*Q*Q+ + max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), + Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). + if the default (None) value is used, the size for good performance + is automatically used, when LDWORK is set to zero, the minimum + cache size will be used. + + Return objects + -------------- + + Ak : rank-2 array('d'), shape (n,n) + The controller state matrix Ak. + Bk : rank-2 array('d') with bound s(n,nmeas) + The controller input matrix Bk. + Ck : rank-2 array('d'), shape (ncon,n) + The controller output matrix Ck. + Dk : rank-2 array('d'), shape (ncon,nmeas) + The controller input/output matrix Dk. + rcond : rank-1 array('d'), shape(4,) + rcond[1] contains the reciprocal condition number of the + control transformation matrix + rcond[2] contains the reciprocal condition number of the + measurement transformation matrix + rcond[3] contains an estimate of the reciprocal condition + number of the X-Riccati equation + rcond[4] contains an estimate of the reciprocal condition + number of the Y-Riccati equation + + Raises + ------ + + SlycotParameterError : e + :e.info = -i: the i-th argument had an illegal value; + SlycotArithmeticError : e + :e.info = 1: + The matrix | A-j*omega*I B2 | had no full + . | C1 D12 | + column rank in respect to the tolerance eps + :e.info = 2: + The matrix | A-j*omega*I B1 | had not full row + . | C2 D21 | + rank in respect to the tolerance EPS + :e.info = 3: + The matrix D12 has no full column rank in + respect to the tolerance tol + :e.info = 4: + The matrix D21 had no full row rank in respect + to the tolerance tol + :e.info = 5: + The singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices |A B2 |, |A B1 |, D12 or D21). + . |C1 D12| |C2 D21| + :e.info = 6: + The controller is not admissible (too small value + of gamma) + :e.info = 7: + The X-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties) + :e.info = 8: + The Y-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties) + :e.info = 9: + The determinant of Im2 + Tu*D11HAT*Ty*D22 is zero + """ + hidden = ' (hidden by the wrapper)' + arg_list = ('n', 'm', 'np', 'ncon', 'nmeas', 'gamma', + 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, + 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, + 'AK'+hidden, 'LDAK'+hidden, 'BK'+hidden, 'LDBK'+hidden, + 'CK'+hidden, 'LDCK'+hidden, 'DK'+hidden, 'LDDK'+hidden, + 'RCOND'+hidden, 'tol', 'IWORK'+hidden, 'DWORK'+hidden, + 'ldwork', 'BWORK'+hidden, 'INFO'+hidden) + + if ldwork is None: + # M2 = NCON NP2=NMEAS M1 = M - M2 + q = max(m-ncon, ncon, np-nmeas,nmeas) + ldwork = 2*q*(3*q+2*n) + max( + 1,(n+q)*(n+q+6),q*(1+max(n,q,5)+1), + 2*n*(n+2*q)+max(1,4*q*q+ + max(2*q,3*n*n+max(2*n*q,10*n*n+12*n+5)), + q*(3*n+3*q+max(2*n,4*q+max(n,q))))) + elif ldwork == 0: + np1 = np - nmeas + np2 = nmeas + m1 = ncon + m2 = m - ncon + d1 = np1 - m2 + d2 = m1 - np2 + lw1 = (n+np1+1)*(n+m2) + max(3*(n+m2)+n+np1,5*(n+m2)) + lw2 = (n+np2)*(n+m1+1) + max(3*(n+np2)+n+m1,5*(n+np2)) + lw3 = m2 + np1*np1 + max(np1*max(n,m1),3*m2+np1,5*m2) + lw4 = np2 + m1*m1 + max(max(n,np1)*m1,3*np2+m1,5*np2) + lw5 = 2*n*n + n*(m+np) + \ + max(1,m*m + max(2*m1,3*n*n+max(n*m,10*n*n+12*n+5)), + np*np + max(2*np1,3*n*n + + max(n*np,10*n*n+12*n+5))) + lw6 = 2*n*n + n*(m+np) + \ + max(1, m2*np2 + np2*np2 + m2*m2 + + max(d1*d1 + max(2*d1, (d1+d2)*np2), + d2*d2 + max(2*d2, d2*m2), 3*n, + n*(2*np2 + m2) + + max(2*n*m2, m2*np2 + + max(m2*m2+3*m2, np2*(2*np2+ + m2+max(np2,n)))))) + ldwork = n*m + np*(n+m) + ncon*ncon + nmeas*nmeas + \ + max(1,lw1,lw2,lw3,lw4,lw5,lw6) + + out = _wrapper.sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol,ldwork) + + raise_if_slycot_error(arg_list, out[-1], sb10fd.__doc__) + + return out[:-1] diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 92bf68f7..6d4d1cd6 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -11,6 +11,7 @@ import pytest from .test_exceptions import assert_docstring_parse + def test_sb02mt(): """Test if sb02mt is callable @@ -104,6 +105,70 @@ def test_sb10jd(): assert_allclose(D_r, Dexp, atol=1e-5) +def test_sb10fd(): + A = array(((-1.0, 0.0, 4.0, 5.0, -3.0, -2.0), + (-2.0, 4.0, -7.0, -2.0, 0.0, 3.0), + (-6.0, 9.0, -5.0, 0.0, 2.0, -1.0), + (-8.0, 4.0, 7.0, -1.0, -3.0, 0.0), + ( 2.0, 5.0, 8.0, -9.0, 1.0, -4.0), + ( 3.0, -5.0, 8.0, 0.0, 2.0, -6.0))) + B = array(((-3.0, -4.0, -2.0, 1.0, 0.0), + ( 2.0, 0.0, 1.0, -5.0, 2.0), + (-5.0, -7.0, 0.0, 7.0, -2.0), + ( 4.0, -6.0, 1.0, 1.0, -2.0), + (-3.0, 9.0, -8.0, 0.0, 5.0), + ( 1.0, -2.0, 3.0, -6.0, -2.0))) + C = array(((1.0, -1.0, 2.0, -4.0, 0.0, -3.0), + (-3.0, 0.0, 5.0, -1.0, 1.0, 1.0), + (-7.0, 5.0, 0.0, -8.0, 2.0, -2.0), + ( 9.0, -3.0, 4.0, 0.0, 3.0, 7.0), + ( 0.0, 1.0, -2.0, 1.0, -6.0, -2.0))) + D = array((( 1.0, -2.0, -3.0, 0.0, 0.0), + ( 0.0, 4.0, 0.0, 1.0, 0.0), + ( 5.0, -3.0, -4.0, 0.0, 1.0), + ( 0.0, 1.0, 0.0, 1.0, -3.0), + ( 0.0, 0.0, 1.0, 7.0, 1.0))) + + gamma, tol = 15.0, 0.00000001 + n, m, np, ncon, nmeas = 6, 5, 5, 2, 2 + + assert_raises(ValueError, synthesis.sb10fd, + n, m, np, ncon, nmeas, gamma, A, B, C, D, tol, 1) + Ak, Bk, Ck, Dk, rcond = synthesis.sb10fd( + n, m, np, ncon, nmeas, gamma, A, B, C, D, tol, 900) + Ak, Bk, Ck, Dk, rcond = synthesis.sb10fd( + n, m, np, ncon, nmeas, gamma, A, B, C, D, tol, 0) + Ak, Bk, Ck, Dk, rcond = synthesis.sb10fd( + n, m, np, ncon, nmeas, gamma, A, B, C, D, tol) + + Ak_ref = array(( + ( -2.8043, 14.7367, 4.6658, 8.1596, 0.0848, 2.5290), + ( 4.6609, 3.2756, -3.5754, -2.8941, 0.2393, 8.2920), + (-15.3127, 23.5592, -7.1229, 2.7599, 5.9775, -2.0285), + (-22.0691, 16.4758, 12.5523, -16.3602, 4.4300, -3.3168), + ( 30.6789, -3.9026, -1.3868, 26.2357, -8.8267, 10.4860), + ( -5.7429, 0.0577, 10.8216, -11.2275, 1.5074, -10.7244))) + Bk_ref = array(( + ( -0.1581, -0.0793), + ( -0.9237, -0.5718), + ( 0.7984, 0.6627), + ( 0.1145, 0.1496), + ( -0.6743, -0.2376), + ( 0.0196, -0.7598))) + Ck_ref = array(( + ( -0.2480, -0.1713, -0.0880, 0.1534, 0.5016, -0.0730), + ( 2.8810, -0.3658, 1.3007, 0.3945, 1.2244, 2.5690))) + Dk_ref = array(( + ( 0.0554, 0.1334), + ( -0.3195, 0.0333))) + + assert_allclose(Ak, Ak_ref, rtol=1e-3) + assert_allclose(Bk, Bk_ref, rtol=1e-3) + assert_allclose(Ck, Ck_ref, rtol=1e-3) + assert_allclose(Dk, Dk_ref, rtol=1e-3, atol=1e-4) + assert_allclose(rcond, (1.0, 1.0, 0.011241, 0.80492e-3), rtol=1e-4) + + @pytest.mark.parametrize( 'fun, exception_class, erange, checkvars', ((synthesis.sb01bd, SlycotArithmeticError, 2, {}), From ec69a7ae24a0aa72f3ffa7435b324ae0c6d3a02e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 5 May 2020 21:55:47 +0200 Subject: [PATCH 192/405] add failing test case from python-control issue #367 --- slycot/tests/test_sb.py | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 6d4d1cd6..802f981c 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -169,6 +169,16 @@ def test_sb10fd(): assert_allclose(rcond, (1.0, 1.0, 0.011241, 0.80492e-3), rtol=1e-4) +def test_sb10fd_2(): + """ fails, from python-control issue #367""" + A = array([[-1, 0, 0], [0, -12, -5], [0, 4, 0]]) + B = array([[2, 0], [0, 0.5], [0, 0]]) + C = array([[-0.5, 0, -0.5], [0, 0, 0], [-0.5, 0, -0.5]]) + D = array([[0, 0], [0, 1], [0, 0]], dtype=float) + assert_raises(ValueError, synthesis.sb10fd, + 3, 2, 3, 1, 1, 1000, A, B, C, D) + + @pytest.mark.parametrize( 'fun, exception_class, erange, checkvars', ((synthesis.sb01bd, SlycotArithmeticError, 2, {}), From 8bdb769c99d35dfc4091ea4901210a84aa432a19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Mon, 11 May 2020 12:17:12 +0200 Subject: [PATCH 193/405] adapt testing and doc for sb10fd to new structure --- slycot/synthesis.py | 286 ++++++++++++++++++++-------------------- slycot/tests/test_sb.py | 7 +- 2 files changed, 144 insertions(+), 149 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 712daef5..ae441327 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1511,7 +1511,7 @@ def sb10hd(n,m,np,ncon,nmeas,A,B,C,D,tol=0.0,ldwork=None): It is assumed that - (A1) (A,B2) is stabilizable and (C2,A) is detectable, - + - (A2) The block D11 of D is zero, - (A3) D12 is full column rank and D21 is full row rank. @@ -2449,8 +2449,9 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): alpha.imag = alphai[0:n] return U,scale,alpha/beta + def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): - """ AK,BK,CK,DK,rcond = \ + """Ak,Bk,Ck,Dk,rcond = \ sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,[tol,ldwork]) To compute the matrices of an H-infinity (sub)optimal n-state @@ -2468,8 +2469,8 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): | C2 | D21 D22 | and for a given value of gamma, where B2 has as column size the - number of control inputs (NCON) and C2 has as row size the number - of measurements (NMEAS) being provided to the controller. + number of control inputs (ncon) and C2 has as row size the number + of measurements (nmeas) being provided to the controller. It is assumed that @@ -2483,131 +2484,123 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): (A4) | A-j*omega*I B1 | has full row rank for all omega. | C2 D21 | - Required arguments - ------------------ - - n : int - The order of the system. (size of matrix A). - m : int - The column size of the matrix B - np : int - The row size of the matrix C - ncon : int - The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. - nmeas : int - The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. - gamma : float - The value of gamma. It is assumed that gamma is - sufficiently large so that the controller is admissible. - gamma >= 0. - A : rank-2 array('d'), shape (n,n) - B : rank-2 array('d'), shape (n,m) - C : rank-2 array('d'), shape (np,n) - D : rank-2 array('d'), shape (np,m) - - Optional arguments - ------------------ - - tol : float - Tolerance used for controlling the accuracy of the applied - transformations for computing the normalized form in - SLICOT Library routine SB10PD. Transformation matrices - whose reciprocal condition numbers are less than tol are - not allowed. If tol <= 0, then a default value equal to - sqrt(eps) is used, where eps is the relative machine - precision. - - ldwork : int - The dimension of the cache array. - LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + - max(1,LW1,LW2,LW3,LW4,LW5,LW6), where - LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), - LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), - LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), - LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), - LW5 = 2*N*N + N*(M+NP) + - max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), - NP*NP + max(2*NP1,3*N*N + - max(N*NP,10*N*N+12*N+5))), - LW6 = 2*N*N + N*(M+NP) + - max(1, M2*NP2 + NP2*NP2 + M2*M2 + - max(D1*D1 + max(2*D1, (D1+D2)*NP2), - D2*D2 + max(2*D2, D2*M2), 3*N, - N*(2*NP2 + M2) + - max(2*N*M2, M2*NP2 + - max(M2*M2+3*M2, NP2*(2*NP2+ - M2+max(NP2,N)))))), - with D1 = NP1 - M2, D2 = M1 - NP2, - NP1 = NP - NP2, M1 = M - M2. - For good performance, LDWORK must generally be larger. - Denoting Q = max(M1,M2,NP1,NP2), an upper bound is - 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), - 2*N*(N+2*Q)+max(1,4*Q*Q+ - max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), - Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). - if the default (None) value is used, the size for good performance - is automatically used, when LDWORK is set to zero, the minimum - cache size will be used. - - Return objects - -------------- - - Ak : rank-2 array('d'), shape (n,n) - The controller state matrix Ak. - Bk : rank-2 array('d') with bound s(n,nmeas) - The controller input matrix Bk. - Ck : rank-2 array('d'), shape (ncon,n) - The controller output matrix Ck. - Dk : rank-2 array('d'), shape (ncon,nmeas) - The controller input/output matrix Dk. - rcond : rank-1 array('d'), shape(4,) - rcond[1] contains the reciprocal condition number of the - control transformation matrix - rcond[2] contains the reciprocal condition number of the - measurement transformation matrix - rcond[3] contains an estimate of the reciprocal condition - number of the X-Riccati equation - rcond[4] contains an estimate of the reciprocal condition - number of the Y-Riccati equation + Parameters + ---------- + n : int + The order of the system. (size of matrix A). + m : int + The column size of the matrix B + np : int + The row size of the matrix C + ncon : int + The number of control inputs. m >= ncon >= 0, np-nmeas >= ncon. + nmeas : int + The number of measurements. np >= nmeas >= 0, m-ncon >= nmeas. + gamma : float + The value of gamma. It is assumed that gamma is + sufficiently large so that the controller is admissible. + gamma >= 0. + A : (n, n) array_like + B : (n, m) array_like + C : (np, n) array_like + D : (np, m) array_like + tol : float, optional + Tolerance used for controlling the accuracy of the applied + transformations for computing the normalized form in + SLICOT Library routine SB10PD. Transformation matrices + whose reciprocal condition numbers are less than tol are + not allowed. If tol <= 0, then a default value equal to + sqrt(eps) is used, where eps is the relative machine + precision. + ldwork : int + The dimension of the cache array. + ldwork >= n*m + np*(n+m) + m2*m2 + np2*np2 + + max(1,lw1,lw2,lw3,lw4,lw5,lw6), where + lw1 = (n+np1+1)*(n+m2) + max(3*(n+m2)+n+np1,5*(n+m2)), + lw2 = (n+np2)*(n+m1+1) + max(3*(n+np2)+n+m1,5*(n+np2)), + lw3 = m2 + np1*np1 + max(np1*max(n,m1),3*m2+np1,5*m2), + lw4 = np2 + m1*m1 + max(max(n,np1)*m1,3*np2+m1,5*np2), + lw5 = 2*n*n + n*(m+np) + + max(1,m*m + max(2*m1,3*n*n+max(n*m,10*n*n+12*n+5)), + np*np + max(2*np1,3*n*n + + max(n*np,10*n*n+12*n+5))), + lw6 = 2*n*n + n*(m+np) + + max(1, m2*np2 + np2*np2 + m2*m2 + + max(d1*d1 + max(2*d1, (d1+d2)*np2), + d2*d2 + max(2*d2, d2*m2), 3*n, + n*(2*np2 + m2) + + max(2*n*m2, m2*np2 + + max(m2*m2+3*m2, np2*(2*np2+ + m2+max(np2,n)))))), + with d1 = np1 - m2, d2 = m1 - np2, + np1 = np - np2, m1 = m - m2. + For good performance, ldwork must generally be larger. + Denoting q = max(m1,m2,np1,np2), an upper bound is + 2*q*(3*q+2*n)+max(1,(n+q)*(n+q+6),q*(q+max(n,q,5)+1), + 2*n*(n+2*q)+max(1,4*q*q+ + max(2*q,3*n*n+max(2*n*q,10*n*n+12*n+5)), + q*(3*n+3*q+max(2*n,4*q+max(n,q))))). + if the default (None) value is used, the size for good performance + is automatically used, when ldwork is set to zero, the minimum + cache size will be used. + + Returns + ------- + Ak : (n, n) ndarray + The controller state matrix Ak. + Bk : (n, nmeas) ndarray + The controller input matrix Bk. + Ck : (ncon, n) ndarray + The controller output matrix Ck. + Dk : (ncon, nmeas) mdarrau + The controller input/output matrix Dk. + rcond : (4, ) ndarray + rcond[1] contains the reciprocal condition number of the + control transformation matrix + rcond[2] contains the reciprocal condition number of the + measurement transformation matrix + rcond[3] contains an estimate of the reciprocal condition + number of the X-Riccati equation + rcond[4] contains an estimate of the reciprocal condition + number of the Y-Riccati equation Raises ------ - - SlycotParameterError : e - :e.info = -i: the i-th argument had an illegal value; - SlycotArithmeticError : e - :e.info = 1: - The matrix | A-j*omega*I B2 | had no full - . | C1 D12 | - column rank in respect to the tolerance eps - :e.info = 2: - The matrix | A-j*omega*I B1 | had not full row - . | C2 D21 | - rank in respect to the tolerance EPS - :e.info = 3: - The matrix D12 has no full column rank in - respect to the tolerance tol - :e.info = 4: - The matrix D21 had no full row rank in respect - to the tolerance tol - :e.info = 5: - The singular value decomposition (SVD) algorithm - did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21). - . |C1 D12| |C2 D21| - :e.info = 6: - The controller is not admissible (too small value - of gamma) - :e.info = 7: - The X-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties) - :e.info = 8: - The Y-Riccati equation was not solved - successfully (the controller is not admissible or - there are numerical difficulties) - :e.info = 9: - The determinant of Im2 + Tu*D11HAT*Ty*D22 is zero + SlycotParameterError + :info = -i: the i-th argument had an illegal value; + SlycotArithmeticError + :info = 1: + The matrix | A-j*omega*I B2 | had no full + | C1 D12 | + column rank in respect to the tolerance eps + :info = 2: + The matrix | A-j*omega*I B1 | had not full row + | C2 D21 | + rank in respect to the tolerance EPS + :info = 3: + The matrix D12 has no full column rank in + respect to the tolerance tol + :info = 4: + The matrix D21 had no full row rank in respect + to the tolerance tol + :info = 5: + The singular value decomposition (SVD) algorithm + did not converge (when computing the SVD of one of + the matrices |A B2 |, |A B1 |, D12 or D21). + |C1 D12| |C2 D21| + :info = 6: + The controller is not admissible (too small value + of gamma) + :info = 7: + The X-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties) + :info = 8: + The Y-Riccati equation was not solved + successfully (the controller is not admissible or + there are numerical difficulties) + :info = 9: + The determinant of Im2 + Tu*D11HAT*Ty*D22 is zero """ hidden = ' (hidden by the wrapper)' arg_list = ('n', 'm', 'np', 'ncon', 'nmeas', 'gamma', @@ -2620,12 +2613,13 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): if ldwork is None: # M2 = NCON NP2=NMEAS M1 = M - M2 - q = max(m-ncon, ncon, np-nmeas,nmeas) - ldwork = 2*q*(3*q+2*n) + max( - 1,(n+q)*(n+q+6),q*(1+max(n,q,5)+1), - 2*n*(n+2*q)+max(1,4*q*q+ - max(2*q,3*n*n+max(2*n*q,10*n*n+12*n+5)), - q*(3*n+3*q+max(2*n,4*q+max(n,q))))) + q = max(m-ncon, ncon, np-nmeas, nmeas) + ldwork = 2*q*(3*q + 2*n) + max( + 1, (n + q)*(n + q + 6), q*(1 + max(n, q, 5) + 1), + 2*n*(n + 2*q) + max(1, 4*q*q + + max(2*q, 3*n*n + + max(2*n*q, 10*n*n + 12*n + 5)), + q*(3*n + 3*q + max(2*n, 4*q + max(n, q))))) elif ldwork == 0: np1 = np - nmeas np2 = nmeas @@ -2633,27 +2627,27 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): m2 = m - ncon d1 = np1 - m2 d2 = m1 - np2 - lw1 = (n+np1+1)*(n+m2) + max(3*(n+m2)+n+np1,5*(n+m2)) - lw2 = (n+np2)*(n+m1+1) + max(3*(n+np2)+n+m1,5*(n+np2)) - lw3 = m2 + np1*np1 + max(np1*max(n,m1),3*m2+np1,5*m2) - lw4 = np2 + m1*m1 + max(max(n,np1)*m1,3*np2+m1,5*np2) + lw1 = (n + np1 + 1)*(n + m2) + max(3*(n + m2) + n + np1, 5*(n + m2)) + lw2 = (n + np2)*(n + m1 + 1) + max(3*(n + np2) + n + m1, 5*(n + np2)) + lw3 = m2 + np1*np1 + max(np1*max(n, m1), 3*m2 + np1, 5*m2) + lw4 = np2 + m1*m1 + max(max(n, np1)*m1, 3*np2 + m1, 5*np2) lw5 = 2*n*n + n*(m+np) + \ - max(1,m*m + max(2*m1,3*n*n+max(n*m,10*n*n+12*n+5)), - np*np + max(2*np1,3*n*n + - max(n*np,10*n*n+12*n+5))) + max(1, m*m + max(2*m1, 3*n*n + max(n*m, 10*n*n + 12*n + 5)), + np*np + max(2*np1, 3*n*n + max(n*np, 10*n*n + 12*n + 5))) lw6 = 2*n*n + n*(m+np) + \ max(1, m2*np2 + np2*np2 + m2*m2 + max(d1*d1 + max(2*d1, (d1+d2)*np2), - d2*d2 + max(2*d2, d2*m2), 3*n, + d2*d2 + max(2*d2, d2*m2), 3*n, n*(2*np2 + m2) + - max(2*n*m2, m2*np2 + - max(m2*m2+3*m2, np2*(2*np2+ - m2+max(np2,n)))))) + max(2*n*m2, m2*np2 + + max(m2*m2 + 3*m2, np2*(2*np2 + + m2 + max(np2, n)))))) ldwork = n*m + np*(n+m) + ncon*ncon + nmeas*nmeas + \ - max(1,lw1,lw2,lw3,lw4,lw5,lw6) + max(1, lw1, lw2, lw3, lw4, lw5, lw6) - out = _wrapper.sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol,ldwork) + out = _wrapper.sb10fd(n, m, np, ncon, nmeas, gamma, + A, B, C, D, tol, ldwork) - raise_if_slycot_error(arg_list, out[-1], sb10fd.__doc__) + raise_if_slycot_error(out[-1], arg_list, sb10fd.__doc__) return out[:-1] diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 802f981c..63530c61 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -175,8 +175,8 @@ def test_sb10fd_2(): B = array([[2, 0], [0, 0.5], [0, 0]]) C = array([[-0.5, 0, -0.5], [0, 0, 0], [-0.5, 0, -0.5]]) D = array([[0, 0], [0, 1], [0, 0]], dtype=float) - assert_raises(ValueError, synthesis.sb10fd, - 3, 2, 3, 1, 1, 1000, A, B, C, D) + assert_raises(SlycotArithmeticError, synthesis.sb10fd, + 3, 2, 3, 1, 1, 100, A, B, C, D, 1e-7, None) @pytest.mark.parametrize( @@ -207,6 +207,7 @@ def test_sb10fd_2(): (synthesis.sg03ad, SlycotArithmeticError, 2, {}), (synthesis.sg03ad, SlycotResultWarning, [3, 4], {}), (synthesis.sg03bd, SlycotResultWarning, 1, {}), - (synthesis.sg03bd, SlycotArithmeticError, range(2, 8), {}))) + (synthesis.sg03bd, SlycotArithmeticError, range(2, 8), {}), + (synthesis.sb10fd, SlycotArithmeticError, 9, {}))) def test_sb_docparse(fun, exception_class, erange, checkvars): assert_docstring_parse(fun.__doc__, exception_class, erange, checkvars) From 3955b013e669312684c3a815f19277528ed650fb Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:03:18 +0200 Subject: [PATCH 194/405] Update slycot/synthesis.py Co-authored-by: Ben Greiner --- slycot/synthesis.py | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index ae441327..bd4b8858 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2456,12 +2456,16 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): To compute the matrices of an H-infinity (sub)optimal n-state controller + + :: | AK | BK | K = |----|----|, | CK | DK | using modified Glover's and Doyle's 1988 formulas, for the system + + :: | A | B1 B2 | | A | B | P = |----|---------| = |---|---| @@ -2473,16 +2477,18 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): of measurements (nmeas) being provided to the controller. It is assumed that + + :: - (A1) (A,B2) is stabilizable and (C2,A) is detectable, + (A1) (A,B2) is stabilizable and (C2,A) is detectable, - (A2) D12 is full column rank and D21 is full row rank, + (A2) D12 is full column rank and D21 is full row rank, - (A3) | A-j*omega*I B2 | has full column rank for all omega, - | C1 D12 | + (A3) | A-j*omega*I B2 | has full column rank for all omega, + | C1 D12 | - (A4) | A-j*omega*I B1 | has full row rank for all omega. - | C2 D21 | + (A4) | A-j*omega*I B1 | has full row rank for all omega. + | C2 D21 | Parameters ---------- From 7c087dc42b6d842e8354580e73f6411967e51fe7 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:03:38 +0200 Subject: [PATCH 195/405] Update slycot/synthesis.py Co-authored-by: Ben Greiner --- slycot/synthesis.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index bd4b8858..61397cc4 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2572,8 +2572,6 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): Raises ------ - SlycotParameterError - :info = -i: the i-th argument had an illegal value; SlycotArithmeticError :info = 1: The matrix | A-j*omega*I B2 | had no full From 88be4c8f3fbbe0afbb93961426a030ee1b8a3757 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:04:11 +0200 Subject: [PATCH 196/405] Update slycot/synthesis.py Co-authored-by: Ben Greiner --- slycot/synthesis.py | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 61397cc4..217e2a71 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2574,13 +2574,23 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): ------ SlycotArithmeticError :info = 1: - The matrix | A-j*omega*I B2 | had no full - | C1 D12 | - column rank in respect to the tolerance eps + The matrix + + :: + + | A-j*omega*I B2 | + | C1 D12 | + + had no full column rank in respect to the tolerance eps :info = 2: - The matrix | A-j*omega*I B1 | had not full row - | C2 D21 | - rank in respect to the tolerance EPS + The matrix + + :: + + | A-j*omega*I B1 | + | C2 D21 | + + had not full row rank in respect to the tolerance EPS :info = 3: The matrix D12 has no full column rank in respect to the tolerance tol @@ -2590,8 +2600,13 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): :info = 5: The singular value decomposition (SVD) algorithm did not converge (when computing the SVD of one of - the matrices |A B2 |, |A B1 |, D12 or D21). - |C1 D12| |C2 D21| + the matrices + + :: + + |A B2 |, |A B1 |, D12 or D21). + |C1 D12| |C2 D21| + :info = 6: The controller is not admissible (too small value of gamma) @@ -2604,7 +2619,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): successfully (the controller is not admissible or there are numerical difficulties) :info = 9: - The determinant of Im2 + Tu*D11HAT*Ty*D22 is zero + The determinant of ``Im2 + Tu*D11HAT*Ty*D22`` is zero """ hidden = ' (hidden by the wrapper)' arg_list = ('n', 'm', 'np', 'ncon', 'nmeas', 'gamma', From 825a84af09a5719956f006c8c7fd6f0caed8689f Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:04:36 +0200 Subject: [PATCH 197/405] Update slycot/synthesis.py Co-authored-by: Ben Greiner --- slycot/synthesis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 217e2a71..0cbe296b 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2518,7 +2518,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): not allowed. If tol <= 0, then a default value equal to sqrt(eps) is used, where eps is the relative machine precision. - ldwork : int + ldwork : int, optional The dimension of the cache array. ldwork >= n*m + np*(n+m) + m2*m2 + np2*np2 + max(1,lw1,lw2,lw3,lw4,lw5,lw6), where From 1c9d2b493b3e1998cd37446cb7538a3e64271fe4 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:04:54 +0200 Subject: [PATCH 198/405] Update slycot/synthesis.py Co-authored-by: Ben Greiner --- slycot/synthesis.py | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 0cbe296b..fc1c93f1 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2572,6 +2572,11 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): Raises ------ + SlycotParameterError + :info = -27: + The dimension ldwork of the cache array is too small. + Use ldwork=0 for the minimum size or ldwork=None for automatic + sizing. SlycotArithmeticError :info = 1: The matrix From 4443cc95cf666e2ee64795eae6a3c1e55b864866 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:06:00 +0200 Subject: [PATCH 199/405] Update slycot/tests/test_sb.py Co-authored-by: Ben Greiner --- slycot/tests/test_sb.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 63530c61..b8c2271b 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -132,7 +132,8 @@ def test_sb10fd(): gamma, tol = 15.0, 0.00000001 n, m, np, ncon, nmeas = 6, 5, 5, 2, 2 - assert_raises(ValueError, synthesis.sb10fd, + # ldwork too small + assert_raises(SlycotParameterError, synthesis.sb10fd, n, m, np, ncon, nmeas, gamma, A, B, C, D, tol, 1) Ak, Bk, Ck, Dk, rcond = synthesis.sb10fd( n, m, np, ncon, nmeas, gamma, A, B, C, D, tol, 900) From 79cb1c0bc8db5a22bed603c989c1497a9312cae3 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 16:06:57 +0200 Subject: [PATCH 200/405] Update slycot/synthesis.py Co-authored-by: Ben Greiner --- slycot/synthesis.py | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index fc1c93f1..5ba678be 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2625,6 +2625,36 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): there are numerical difficulties) :info = 9: The determinant of ``Im2 + Tu*D11HAT*Ty*D22`` is zero + [3]_. + + Notes + ----- + Method + The routine implements the Glover's and Doyle's 1988 formulas [1]_, + [2]_ modified to improve the efficiency as described in [3]_. + Numerical Aspects + The accuracy of the result depends on the condition numbers of the + input and output transformations and on the condition numbers of + the two Riccati equations, as given by the values of RCOND(1), + RCOND(2), RCOND(3) and RCOND(4), respectively. + + References + ---------- + .. [1] Glover, K. and Doyle, J.C., + State-space formulae for all stabilizing controllers that + satisfy an Hinf norm bound and relations to risk sensitivity. + Systems and Control Letters, vol. 11, pp. 167-172, 1988. + + .. [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and + Smith, R., + mu-Analysis and Synthesis Toolbox. + The MathWorks Inc., Natick, Mass., 1995. + + .. [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M., + Fortran 77 routines for Hinf and H2 design of continuous-time + linear control systems. + Rep. 98-14, Department of Engineering, Leicester University, + Leicester, U.K., 1998. """ hidden = ' (hidden by the wrapper)' arg_list = ('n', 'm', 'np', 'ncon', 'nmeas', 'gamma', From 055c46332d72592a8947d4802f1bb37ae6f20020 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Mon, 11 May 2020 17:18:54 +0200 Subject: [PATCH 201/405] some final tweaks to docstring --- slycot/synthesis.py | 57 ++++++++++++++++++++++------------------- slycot/tests/test_sb.py | 3 ++- 2 files changed, 33 insertions(+), 27 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 5ba678be..5bba98ee 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2519,33 +2519,38 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): sqrt(eps) is used, where eps is the relative machine precision. ldwork : int, optional - The dimension of the cache array. - ldwork >= n*m + np*(n+m) + m2*m2 + np2*np2 + - max(1,lw1,lw2,lw3,lw4,lw5,lw6), where - lw1 = (n+np1+1)*(n+m2) + max(3*(n+m2)+n+np1,5*(n+m2)), - lw2 = (n+np2)*(n+m1+1) + max(3*(n+np2)+n+m1,5*(n+np2)), - lw3 = m2 + np1*np1 + max(np1*max(n,m1),3*m2+np1,5*m2), - lw4 = np2 + m1*m1 + max(max(n,np1)*m1,3*np2+m1,5*np2), - lw5 = 2*n*n + n*(m+np) + - max(1,m*m + max(2*m1,3*n*n+max(n*m,10*n*n+12*n+5)), - np*np + max(2*np1,3*n*n + - max(n*np,10*n*n+12*n+5))), - lw6 = 2*n*n + n*(m+np) + - max(1, m2*np2 + np2*np2 + m2*m2 + - max(d1*d1 + max(2*d1, (d1+d2)*np2), - d2*d2 + max(2*d2, d2*m2), 3*n, - n*(2*np2 + m2) + - max(2*n*m2, m2*np2 + - max(m2*m2+3*m2, np2*(2*np2+ - m2+max(np2,n)))))), - with d1 = np1 - m2, d2 = m1 - np2, - np1 = np - np2, m1 = m - m2. + The dimension of the cache array:: + + ldwork >= n*m + np*(n+m) + m2*m2 + np2*np2 + + max(1,lw1,lw2,lw3,lw4,lw5,lw6), where + lw1 = (n+np1+1)*(n+m2) + max(3*(n+m2)+n+np1,5*(n+m2)), + lw2 = (n+np2)*(n+m1+1) + max(3*(n+np2)+n+m1,5*(n+np2)), + lw3 = m2 + np1*np1 + max(np1*max(n,m1),3*m2+np1,5*m2), + lw4 = np2 + m1*m1 + max(max(n,np1)*m1,3*np2+m1,5*np2), + lw5 = 2*n*n + n*(m+np) + + max(1,m*m + max(2*m1,3*n*n+max(n*m,10*n*n+12*n+5)), + np*np + max(2*np1,3*n*n + + max(n*np,10*n*n+12*n+5))), + lw6 = 2*n*n + n*(m+np) + + max(1, m2*np2 + np2*np2 + m2*m2 + + max(d1*d1 + max(2*d1, (d1+d2)*np2), + d2*d2 + max(2*d2, d2*m2), 3*n, + n*(2*np2 + m2) + + max(2*n*m2, m2*np2 + + max(m2*m2+3*m2, np2*(2*np2+ + m2+max(np2,n)))))), + + with `d1 = np1 - m2`, `d2 = m1 - np2`, + `np1 = np - np2`, `m1 = m - m2`. + For good performance, ldwork must generally be larger. - Denoting q = max(m1,m2,np1,np2), an upper bound is - 2*q*(3*q+2*n)+max(1,(n+q)*(n+q+6),q*(q+max(n,q,5)+1), - 2*n*(n+2*q)+max(1,4*q*q+ - max(2*q,3*n*n+max(2*n*q,10*n*n+12*n+5)), + Denoting q = max(m1,m2,np1,np2), an upper bound is:: + + 2*q*(3*q+2*n)+max(1,(n+q)*(n+q+6),q*(q+max(n,q,5)+1), + 2*n*(n+2*q)+max(1,4*q*q+ + max(2*q,3*n*n+max(2*n*q,10*n*n+12*n+5)), q*(3*n+3*q+max(2*n,4*q+max(n,q))))). + if the default (None) value is used, the size for good performance is automatically used, when ldwork is set to zero, the minimum cache size will be used. @@ -2590,7 +2595,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): :info = 2: The matrix - :: + :: | A-j*omega*I B1 | | C2 D21 | diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index b8c2271b..556a09d3 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -209,6 +209,7 @@ def test_sb10fd_2(): (synthesis.sg03ad, SlycotResultWarning, [3, 4], {}), (synthesis.sg03bd, SlycotResultWarning, 1, {}), (synthesis.sg03bd, SlycotArithmeticError, range(2, 8), {}), - (synthesis.sb10fd, SlycotArithmeticError, 9, {}))) + (synthesis.sb10fd, SlycotArithmeticError, 9, {}), + (synthesis.sb10fd, SlycotParameterError, (-27, ), {}))) def test_sb_docparse(fun, exception_class, erange, checkvars): assert_docstring_parse(fun.__doc__, exception_class, erange, checkvars) From a9d9f9ebebb0b9d0bcf01a3127212abfbc206789 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 17:25:43 +0200 Subject: [PATCH 202/405] Apply suggestions from code review more docstring fixes accepted. [skip ci] Co-authored-by: Ben Greiner --- slycot/synthesis.py | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 5bba98ee..2cbcd51a 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -2507,9 +2507,13 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): sufficiently large so that the controller is admissible. gamma >= 0. A : (n, n) array_like + System state matrix B : (n, m) array_like + System input matrix C : (np, n) array_like + System output matrix D : (np, m) array_like + System input/output matrix tol : float, optional Tolerance used for controlling the accuracy of the applied transformations for computing the normalized form in @@ -2566,13 +2570,17 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): Dk : (ncon, nmeas) mdarrau The controller input/output matrix Dk. rcond : (4, ) ndarray - rcond[1] contains the reciprocal condition number of the + rcond[0] + contains the reciprocal condition number of the control transformation matrix - rcond[2] contains the reciprocal condition number of the + rcond[1] + contains the reciprocal condition number of the measurement transformation matrix - rcond[3] contains an estimate of the reciprocal condition + rcond[2] + contains an estimate of the reciprocal condition number of the X-Riccati equation - rcond[4] contains an estimate of the reciprocal condition + rcond[3] + contains an estimate of the reciprocal condition number of the Y-Riccati equation Raises @@ -2640,8 +2648,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): Numerical Aspects The accuracy of the result depends on the condition numbers of the input and output transformations and on the condition numbers of - the two Riccati equations, as given by the values of RCOND(1), - RCOND(2), RCOND(3) and RCOND(4), respectively. + the two Riccati equations, as given by the values of `rcond[0:4]` References ---------- From 429989b13c65e705082d18837d717c7ac79e345c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Mon, 11 May 2020 19:45:59 +0200 Subject: [PATCH 203/405] add more tests of the exception messages --- slycot/analysis.py | 2 +- slycot/synthesis.py | 2 +- slycot/tests/CMakeLists.txt | 2 ++ slycot/tests/test_analysis.py | 44 ++++++++++++++++++++++++++++++++++ slycot/tests/test_mb.py | 17 ++++++++++++- slycot/tests/test_transform.py | 21 ++++++++++++++++ 6 files changed, 85 insertions(+), 3 deletions(-) create mode 100755 slycot/tests/test_analysis.py create mode 100755 slycot/tests/test_transform.py diff --git a/slycot/analysis.py b/slycot/analysis.py index aacc0c8f..4ae19b27 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1620,7 +1620,7 @@ def ab13fd(n, A, tol = 0.0): 'dwork' + hidden, 'ldwork' + hidden, 'cwork' + hidden, 'lcwork' + hidden, 'info' + hidden] out = _wrapper.ab13fd(n, A, tol) - raise_if_slycot_error(out[-1], arg_list, ab13fd.__dict__) + raise_if_slycot_error(out[-1], arg_list, ab13fd.__doc__) return out[0], out[1] def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): diff --git a/slycot/synthesis.py b/slycot/synthesis.py index f00281fd..cfbc6cba 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1904,7 +1904,7 @@ def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): out = _wrapper.sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork) - raise_if_slycot_error(out[-1], arg_list, sg03ad.__dict__) + raise_if_slycot_error(out[-1], arg_list, sg03ad.__doc__) return out[:-1] diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index cdf3d65f..55aee8df 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -8,6 +8,8 @@ set(PYSOURCE test_mb.py test_mc.py test_sb.py + test_analysis.py + test_transform.py test_sg02ad.py test_sg03ad.py test_tb05ad.py diff --git a/slycot/tests/test_analysis.py b/slycot/tests/test_analysis.py new file mode 100755 index 00000000..f7577791 --- /dev/null +++ b/slycot/tests/test_analysis.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python +# +# test_ab.py - generic tests for analysis programs +# repagh Date: Mon, 11 May 2020 19:48:23 +0200 Subject: [PATCH 204/405] Update slycot/__init__.py [skip ci] Co-authored-by: Ben Greiner --- slycot/__init__.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index fdf84c6b..0c2b3c70 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -27,7 +27,8 @@ # Mathematical routines (7/81 wrapped) from .math import mc01td, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd - # Synthesis routines (14/50 wrapped) + # Synthesis routines (15/50 wrapped) + from .synthesis import sb01bd,sb02md,sb02mt,sb02od,sb03md,sb03od from .synthesis import sb04md,sb04qd,sb10ad,sb10dd,sb10hd,sg03ad from .synthesis import sg02ad, sg03bd, sb10fd From e25906f997b3f5245030c789c94a01e819260494 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 11 May 2020 21:58:27 +0200 Subject: [PATCH 205/405] Update coveralls badge The coveralls badge still seems to have problems. --- README.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.rst b/README.rst index 51af1048..652d69d7 100644 --- a/README.rst +++ b/README.rst @@ -10,8 +10,8 @@ Slycot .. image:: https://travis-ci.org/python-control/Slycot.svg?branch=master :target: https://travis-ci.org/python-control/Slycot -.. image:: https://coveralls.io/repos/github/python-control/Slycot/badge.svg - :target: https://coveralls.io/github/python-control/Slycot +.. image:: https://coveralls.io/repos/github/python-control/Slycot/badge.svg?branch=master + :target: https://coveralls.io/github/python-control/Slycot?branch=master Python wrapper for selected SLICOT routines, notably including solvers for Riccati, Lyapunov, and Sylvester equations. From 6080601094acf7cfffb540accd5c40dbebef2a13 Mon Sep 17 00:00:00 2001 From: Rene van Paassen Date: Mon, 11 May 2020 22:07:24 +0200 Subject: [PATCH 206/405] Apply suggestions from code review Co-authored-by: Ben Greiner --- slycot/tests/test_analysis.py | 2 -- slycot/tests/test_transform.py | 1 - 2 files changed, 3 deletions(-) diff --git a/slycot/tests/test_analysis.py b/slycot/tests/test_analysis.py index f7577791..701eab4a 100755 --- a/slycot/tests/test_analysis.py +++ b/slycot/tests/test_analysis.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # test_ab.py - generic tests for analysis programs # repagh Date: Tue, 12 May 2020 00:57:24 +0200 Subject: [PATCH 207/405] fix for DGEBAL transformation application, issue #11 --- slycot/src/TB01TD.f | 2 +- slycot/src/TB05AD.f | 4 ++-- slycot/tests/test_tb05ad.py | 29 +++++++++++++++++++++++++++-- 3 files changed, 30 insertions(+), 5 deletions(-) diff --git a/slycot/src/TB01TD.f b/slycot/src/TB01TD.f index 7c52957a..8f2fc650 100644 --- a/slycot/src/TB01TD.f +++ b/slycot/src/TB01TD.f @@ -245,7 +245,7 @@ SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW, C to transform B and C. C DO 10 K = 1, N - KOLD = K + KOLD = N + 1 - K ! RvP, rabraker, slycot #11 IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD KNEW = INT( SCSTAT(KOLD) ) diff --git a/slycot/src/TB05AD.f b/slycot/src/TB05AD.f index c7b93e91..55490b84 100644 --- a/slycot/src/TB05AD.f +++ b/slycot/src/TB05AD.f @@ -346,10 +346,10 @@ SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB, C defined in the subroutine DGEBAL. C DO 10 J = 1, N - JJ = J + JJ = N + 1 - J ! RvP, rabraker, slycot #11 IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN IF ( JJ.LT.LOW ) JJ = LOW - JJ - JP = DWORK(JJ) + JP = INT( DWORK(JJ) ) IF ( JP.NE.JJ ) THEN C C Permute rows of B. diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index e64f7360..b5330cca 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -11,6 +11,7 @@ from numpy.testing import assert_almost_equal + # set the random seed so we can get consistent results. np.random.seed(40) CASES = {} @@ -47,9 +48,10 @@ def test_tb05ad_ng(self): for key in CASES: sys = CASES[key] self.check_tb05ad_AG_NG(sys, 10*1j, 'NG') + self.check_tb05ad_AG_NG(sys, 10*1j, 'AG') - @unittest.expectedFailure - def test_tb05ad_ag_failure(self): + #@unittest.expectedFailure + def test_tb05ad_ag_no_longer_failure(self): """ Test tb05ad and job 'AG' (i.e., balancing enabled) fails on certain A matrices. """ @@ -187,6 +189,29 @@ def test_tb05ad_resonance(self): transform.tb05ad(2, 1, 1, jomega, A, B, C, job='NH') assert cm.exception.info == 2 + def test_tb05ad_balance(self): + """Specifically check for the balancing output. + + Based on https://rdrr.io/rforge/expm/man/balance.html + """ + A = np.array(((-1, -1, 0, 0), + ( 0, 0, 10, 10), + ( 0, 0, 10, 0), + ( 0, 10, 0, 0)), dtype=float) + B = np.eye(4) + C = np.eye(4) + Ar = np.array(((-1, -1, 0, 0), + ( 0, 0, 10, 10), + ( 0, 10, 0, 0), + ( 0, 0, 0, 10))) + jomega = 1.0 + At, Bt, Ct, rcond, g_jw, ev, hinvb, info = transform.tb05ad( + 4, 4, 4, jomega, A, B, C, job='AG') + assert_almost_equal(At, Ar) + + At, Bt, Ct, rcond, g_jwb, ev, hinvb, info = transform.tb05ad( + 4, 4, 4, jomega, A, B, C, job='AG') + if __name__ == "__main__": unittest.main() From 41c162ce2458ef50eb281e2ec4f2beca5e56ad27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Tue, 12 May 2020 09:38:27 +0200 Subject: [PATCH 208/405] tweak tb05ad test cases --- slycot/tests/test_tb05ad.py | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index b5330cca..8a723716 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -48,12 +48,20 @@ def test_tb05ad_ng(self): for key in CASES: sys = CASES[key] self.check_tb05ad_AG_NG(sys, 10*1j, 'NG') + + def test_tb05ad_ag(self): + """ + Test that tb05ad with job 'AG' computes the correct + frequency response. + """ + for key in CASES: + sys = CASES[key] self.check_tb05ad_AG_NG(sys, 10*1j, 'AG') - #@unittest.expectedFailure - def test_tb05ad_ag_no_longer_failure(self): - """ Test tb05ad and job 'AG' (i.e., balancing enabled) fails - on certain A matrices. + def test_tb05ad_ag_fixed_bug_no11(self): + """ Test tb05ad and job 'AG' (i.e., balancing enabled). + + Failed on certain A matrices before, issue #11. """ self.check_tb05ad_AG_NG(CASES['fail1'], 10*1j, 'AG') From b18c7a16bf7c772de7c5feee95a72290878b3488 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Wed, 13 May 2020 21:10:04 +0200 Subject: [PATCH 209/405] created new test for permutations, removed double runs --- slycot/tests/test_tb05ad.py | 98 +++++++++++++++++++++---------------- 1 file changed, 57 insertions(+), 41 deletions(-) diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index 8a723716..b8867240 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -3,31 +3,28 @@ from slycot import transform from slycot.exceptions import SlycotArithmeticError, SlycotParameterError - import sys import numpy as np - +from scipy.linalg import matrix_balance, eig import unittest from numpy.testing import assert_almost_equal - - # set the random seed so we can get consistent results. np.random.seed(40) CASES = {} -# This is a known failure for tb05ad when running job 'AG' -CASES['fail1'] = {'A': np.array([[-0.5, 0., 0., 0. ], - [ 0., -1., 0. , 0. ], - [ 1., 0., -0.5, 0. ], - [ 0., 1., 0., -1. ]]), - 'B': np.array([[ 1., 0.], - [ 0., 1.], - [ 0., 0.], - [ 0., 0.]]), - 'C': np.array([[ 0., 1., 1., 0.], - [ 0., 1., 0., 1.], - [ 0., 1., 1., 1.]])} +# This was (pre 2020) a known failure for tb05ad when running job 'AG' +CASES['known'] = {'A': np.array([[-0.5, 0., 0., 0.], + [ 0., -1., 0., 0.], + [ 1., 0., -0.5, 0.], + [ 0., 1., 0., -1.]]), + 'B': np.array([[ 1., 0.], + [ 0., 1.], + [ 0., 0.], + [ 0., 0.]]), + 'C': np.array([[ 0., 1., 1., 0.], + [ 0., 1., 0., 1.], + [ 0., 1., 1., 1.]])} n = 20 p = 10 @@ -58,13 +55,6 @@ def test_tb05ad_ag(self): sys = CASES[key] self.check_tb05ad_AG_NG(sys, 10*1j, 'AG') - def test_tb05ad_ag_fixed_bug_no11(self): - """ Test tb05ad and job 'AG' (i.e., balancing enabled). - - Failed on certain A matrices before, issue #11. - """ - self.check_tb05ad_AG_NG(CASES['fail1'], 10*1j, 'AG') - def test_tb05ad_nh(self): """Test that tb05ad with job = 'NH' computes the correct frequency response after conversion to Hessenberg form. @@ -180,7 +170,7 @@ def check_tb05ad_errors(self, sys): def test_tb05ad_resonance(self): """ Test tb05ad resonance failure. - Actually test one of the exception messages. For many routines these + Actually test one of the exception messages. These are parsed from the docstring, tests both the info index and the message """ @@ -198,27 +188,53 @@ def test_tb05ad_resonance(self): assert cm.exception.info == 2 def test_tb05ad_balance(self): - """Specifically check for the balancing output. + """Test balancing in tb05ad. - Based on https://rdrr.io/rforge/expm/man/balance.html + Tests for the cause of the problem reported in issue #11 + balancing permutations were not correctly applied to the + C and D matrix. """ - A = np.array(((-1, -1, 0, 0), - ( 0, 0, 10, 10), - ( 0, 0, 10, 0), - ( 0, 10, 0, 0)), dtype=float) - B = np.eye(4) - C = np.eye(4) - Ar = np.array(((-1, -1, 0, 0), - ( 0, 0, 10, 10), - ( 0, 10, 0, 0), - ( 0, 0, 0, 10))) + + # find a good test case. Some sparsity, + # some zero eigenvalues, some non-zero eigenvalues, + # and proof that the 1st step, with dgebal, does some + # permutation + crit = False + while not crit: + A = np.random.randn(8, 8) + A[np.random.uniform(size=(8, 8)) > 0.35] = 0.0 + + Aeig = eig(A)[0] + neig0 = np.sum(np.abs(Aeig) == 0) + As, T = matrix_balance(A) + nperm = np.sum(np.diag(T == 0)) + + crit = nperm < 8 and nperm >= 4 and \ + neig0 > 1 and neig0 <= 3 + + # print("number of permutations", nperm, "eigenvalues=0", neig0) + B = np.random.randn(8, 4) + C = np.random.randn(3, 8) + + # do a run jomega = 1.0 At, Bt, Ct, rcond, g_jw, ev, hinvb, info = transform.tb05ad( - 4, 4, 4, jomega, A, B, C, job='AG') - assert_almost_equal(At, Ar) - - At, Bt, Ct, rcond, g_jwb, ev, hinvb, info = transform.tb05ad( - 4, 4, 4, jomega, A, B, C, job='AG') + 8, 4, 3, jomega, A, B, C, job='AG') + + # remove information on Q, in lower sub-triangle part of A + At = np.triu(At, k=-1) + + # now after the balancing in DGEBAL, and conversion to + # upper Hessenberg form: + # At = Q^T * (P^-1 * A * P ) * Q + # with Q orthogonal + # Ct = C * P * Q + # Bt = Q^T * P^-1 * B + # so test with Ct * At * Bt == C * A * B + # and verify that eigenvalues of both A matrices are close + assert_almost_equal(np.dot(np.dot(Ct, At), Bt), + np.dot(np.dot(C, A), B)) + assert_almost_equal(eig(At)[0], eig(A)[0]) if __name__ == "__main__": From 55b35ddcf8ead09f7f910953dea5bf0b0885fd9d Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 13 May 2020 23:26:07 +0200 Subject: [PATCH 210/405] change test matrix for mb05md --- slycot/tests/test_mb.py | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index f426dcc3..88b883d0 100755 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -268,12 +268,9 @@ def test_mb05md(self): # TODO: move this to pytest recwarn together with the whole class @unittest.skipIf(sys.version < "3", "no assertWarns in old Python") def test_mb05md_warning(self): - """ Check that the correct warning is raised from docstring""" - A = np.array([[5, 4, 2, 1], - [0, 1, -1, -1], - [-1, -1, 3, 0], - [1, 1, -1, 2]]) - delta = 0. + """Check that the correct warning is raised from docstring""" + A = np.diag([3., 3., 3., 3.]) + np.diag([1., 1., 1.], k=1) + delta = 0.1 with self.assertWarns(SlycotResultWarning, msg="\n" From 5695a43fad89491edd30a7a1c8bdf7ce30ef9c0b Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 13 May 2020 23:59:37 +0200 Subject: [PATCH 211/405] chmod a-x tests/*.py --- slycot/tests/CMakeLists.txt | 3 --- slycot/tests/test_analysis.py | 0 slycot/tests/test_mb.py | 1 - slycot/tests/test_mc.py | 1 - slycot/tests/test_sg02ad.py | 0 slycot/tests/test_sg03ad.py | 1 - slycot/tests/test_td04ad.py | 1 - slycot/tests/test_transform.py | 0 8 files changed, 7 deletions(-) mode change 100755 => 100644 slycot/tests/test_analysis.py mode change 100755 => 100644 slycot/tests/test_mb.py mode change 100755 => 100644 slycot/tests/test_sg02ad.py mode change 100755 => 100644 slycot/tests/test_transform.py diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 55aee8df..7a5d126e 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -18,7 +18,4 @@ set(PYSOURCE test_tg01fd.py ) install(FILES ${PYSOURCE} - PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE - GROUP_READ GROUP_EXECUTE - WORLD_READ WORLD_EXECUTE DESTINATION slycot/tests) diff --git a/slycot/tests/test_analysis.py b/slycot/tests/test_analysis.py old mode 100755 new mode 100644 diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py old mode 100755 new mode 100644 index f426dcc3..0dc0f356 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # test_mb.py - test suite for linear algebra commands # bnavigator , Aug 2019 diff --git a/slycot/tests/test_mc.py b/slycot/tests/test_mc.py index db02cedf..5c3012d5 100644 --- a/slycot/tests/test_mc.py +++ b/slycot/tests/test_mc.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # test_mc.py - test suite for polynomial and rational function manipulation # bnavigator , Aug 2019 diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py old mode 100755 new mode 100644 diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index 830f3fc3..dc0f262a 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # test_sg03ad.py - test suite for stability margin commands # RvP, 15 Jun 2017 diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index 7a2bbd7a..50206360 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -1,4 +1,3 @@ -#!/usr/bin/env python # # test_td04ad.py - test suite for tf -> ss conversion # RvP, 04 Jun 2018 diff --git a/slycot/tests/test_transform.py b/slycot/tests/test_transform.py old mode 100755 new mode 100644 From b67fbf9540006091b912ec0d9cefd80d744a029e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Fri, 15 May 2020 08:52:52 +0200 Subject: [PATCH 212/405] order eigenvalues before check --- slycot/tests/test_tb05ad.py | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index b8867240..c0ef5310 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -234,7 +234,12 @@ def test_tb05ad_balance(self): # and verify that eigenvalues of both A matrices are close assert_almost_equal(np.dot(np.dot(Ct, At), Bt), np.dot(np.dot(C, A), B)) - assert_almost_equal(eig(At)[0], eig(A)[0]) + # uses a sort, there is no guarantee on the order of eigenvalues + eigAt = eig(At)[0] + idxAt = np.argsort(eigAt) + eigA = eig(A)[0] + idxA = np.argsort(eigA) + assert_almost_equal(eigA[idxA], eigAt[idxAt]) if __name__ == "__main__": From 6f1d2e4e88293ad41be27f0cd1e2142a8a24067a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ren=C3=A9=20van=20Paassen?= Date: Fri, 15 May 2020 13:03:41 +0200 Subject: [PATCH 213/405] ensure dgebal does some scaling too on the test case --- slycot/tests/test_tb05ad.py | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index c0ef5310..5732a660 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -198,19 +198,20 @@ def test_tb05ad_balance(self): # find a good test case. Some sparsity, # some zero eigenvalues, some non-zero eigenvalues, # and proof that the 1st step, with dgebal, does some - # permutation + # permutation and some scaling crit = False + n = 8 while not crit: - A = np.random.randn(8, 8) - A[np.random.uniform(size=(8, 8)) > 0.35] = 0.0 + A = np.random.randn(n, n) + A[np.random.uniform(size=(n, n)) > 0.35] = 0.0 Aeig = eig(A)[0] neig0 = np.sum(np.abs(Aeig) == 0) As, T = matrix_balance(A) nperm = np.sum(np.diag(T == 0)) - - crit = nperm < 8 and nperm >= 4 and \ - neig0 > 1 and neig0 <= 3 + nscale = n - np.sum(T == 1.0) + crit = nperm < n and nperm >= n//2 and \ + neig0 > 1 and neig0 <= 3 and nscale > 0 # print("number of permutations", nperm, "eigenvalues=0", neig0) B = np.random.randn(8, 4) From 5743e8a0d04188cbbb621bb7db5f325c596dc56d Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 18 May 2020 22:39:20 +0200 Subject: [PATCH 214/405] override XERBLA with noop --- slycot/CMakeLists.txt | 4 ++-- slycot/src/XERBLA.f | 13 +++++++++++++ slycot/src/_helper.pyf | 6 ++++-- 3 files changed, 19 insertions(+), 4 deletions(-) create mode 100644 slycot/src/XERBLA.f diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index c481cea6..928c4737 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -104,7 +104,7 @@ set(FSOURCES src/delctg.f src/select.f src/SLCT_DLATZM.f src/SLCT_ZLATZM.f - src/ftruefalse.f + src/ftruefalse.f src/XERBLA.f ) set(F2PYSOURCE src/_wrapper.pyf) @@ -139,7 +139,7 @@ add_custom_command( add_library( ${SLYCOT_MODULE} MODULE - _wrappermodule.c + _wrappermodule.c ${PYTHON_SITE}/numpy/f2py/src/fortranobject.c _wrapper-f2pywrappers.f ${FSOURCES}) diff --git a/slycot/src/XERBLA.f b/slycot/src/XERBLA.f new file mode 100644 index 00000000..0d3c8067 --- /dev/null +++ b/slycot/src/XERBLA.f @@ -0,0 +1,13 @@ + SUBROUTINE XERBLA(SRNAME, INFO) +C +C SLYCOT +C Override LAPACK XERBLA routine to noop instead +C of PRINT and STOP +C + CHARACTER*(*) SRNAME + INTEGER INFO +C + RETURN +C + END +C diff --git a/slycot/src/_helper.pyf b/slycot/src/_helper.pyf index ed59e106..41bf0459 100644 --- a/slycot/src/_helper.pyf +++ b/slycot/src/_helper.pyf @@ -6,5 +6,7 @@ subroutine ftruefalse(ftrue,ffalse) ! in src/ftruefalse.f logical intent(out) :: ffalse end subroutine ftruefalse -! This file was auto-generated with f2py (version:2). -! See http://cens.ioc.ee/projects/f2py2e/ +subroutine xerbla(srname, info) ! in src/XERBLA.f + character*(*) :: srname + integer :: info +end subroutine From 73cd89c7e5e97205be8fa856158e25901b4b0914 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Mon, 18 May 2020 23:26:13 +0200 Subject: [PATCH 215/405] add test for overidden XERBLA We call the _wrapper function directly so the python wrapper in analysis.py does not raise an exception or in a future version does not eventually handle the wrong parameter by checking it before the Fortran call. Because the file descriptors for the Fortran module are set at import time, we cannot use the pytest fixtures capsys or capfd, but need to start a new process. --- slycot/tests/test_exceptions.py | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 631a4cb7..13e2da27 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -19,6 +19,8 @@ """ import pytest +import subprocess +import sys from slycot.exceptions import raise_if_slycot_error, \ SlycotError, SlycotWarning, SlycotParameterError @@ -88,3 +90,19 @@ def test_unhandled_info_iwarn(): assert wm[1].message.info == 0 +# Test code for test_xerbla_override +CODE = """ +from slycot._wrapper import ab08nd +# equil='X' is invalid +out = ab08nd(1, 1, 1, [1], [1], [1], [1], equil='X') +print("INFO={}".format(out[-1])) +""" + + +def test_xerbla_override(): + """Test that Fortran routines calling XERBLA do not print to stdout.""" + + stdout = subprocess.check_output([sys.executable, '-c', CODE], + stderr=subprocess.STDOUT, + text=True) + assert stdout == "INFO=-1\n" From 048592db253037d760cc390f5b9416fd2283f244 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 19 May 2020 02:29:46 +0200 Subject: [PATCH 216/405] add test for ab01nd --- slycot/tests/CMakeLists.txt | 1 + slycot/tests/test_ab01.py | 66 +++++++++++++++++++++++++++++++++++++ slycot/tests/test_ab08n.py | 4 +-- 3 files changed, 69 insertions(+), 2 deletions(-) create mode 100755 slycot/tests/test_ab01.py diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 7a5d126e..2aafab3f 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -1,6 +1,7 @@ set(PYSOURCE __init__.py + test_ab01.py test_ab08n.py test_ag08bd.py test_examples.py diff --git a/slycot/tests/test_ab01.py b/slycot/tests/test_ab01.py new file mode 100755 index 00000000..ec544b13 --- /dev/null +++ b/slycot/tests/test_ab01.py @@ -0,0 +1,66 @@ +""" +Test ab01 wrappers + +@author: bnavigator +""" + +from numpy import array +from numpy.testing import assert_allclose, assert_equal + +from scipy.linalg.lapack import dorgqr + +from slycot.analysis import ab01nd + + +def test_ab01nd(): + """SLICOT doc example + + http://slicot.org/objects/software/shared/doc/AB01ND.html""" + + # Example program data + n = 3 + m = 2 + tol = 0.0 + + A = array([[-1., 0., 0.], + [-2., -2., -2.], + [-1., 0., -3.]]) + B = array([[1., 0.], + [0, 2.], + [0., 1.]]) + + for jobz in ['N', 'I', 'F']: + Ac, Bc, ncont, indcon, nblk, Z, tau = ab01nd(n, m, A, B, + jobz=jobz, tol=tol) + + # The transformed state dynamics matrix of a controllable realization + assert_allclose(Ac[:ncont, :ncont], array([[-3.0000, 2.2361], + [ 0.0000, -1.0000]]), + atol=0.0001) + + # and the dimensions of its diagonal blocks are + assert_equal(nblk[:indcon], array([2])) + + # The transformed input/state matrix B of a controllable realization + assert_allclose(Bc[:ncont, :],array([[ 0.0000, -2.2361], + [ 1.0000, 0.0000]]), + atol=0.0001) + + # The controllability index of the transformed system representation + assert indcon == 1 + + if jobz == 'N': + assert Z is None + continue + elif jobz == 'I': + Z_ = Z + elif jobz == 'F': + Z_, _, info = dorgqr(Z, tau) + assert info == 0 + + # The similarity transformation matrix Z + assert_allclose(Z_, array([[ 0.0000, 1.0000, 0.0000], + [-0.8944, 0.0000, -0.4472], + [-0.4472, 0.0000, 0.8944]]), + atol=0.0001) + diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py index bdeb0b88..81d1000f 100644 --- a/slycot/tests/test_ab08n.py +++ b/slycot/tests/test_ab08n.py @@ -1,5 +1,5 @@ # =================================================== -# ag08bd tests +# ab08nX tests import unittest from slycot import analysis @@ -9,7 +9,7 @@ from numpy.testing import assert_equal, assert_allclose -class test_ab08n(unittest.TestCase): +class test_ab08nX(unittest.TestCase): """ Test regular pencil construction ab08nX with input parameters according to example in documentation """ From 3708ea19fe7fa6d4bb830093852f86dea91c2fac Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 19 May 2020 02:31:21 +0200 Subject: [PATCH 217/405] fix ab01nd: no tuple assignment. +numpydoc --- slycot/analysis.py | 149 ++++++++++++++++++++++++--------------------- 1 file changed, 79 insertions(+), 70 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 4ae19b27..f38fe793 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -21,19 +21,23 @@ from .exceptions import raise_if_slycot_error, SlycotParameterError -def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): +def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): """ Ac,Bc,ncont,indcon,nblk,Z,tau = ab01nd_i(n,m,A,B,[jobz,tol,ldwork]) To find a controllable realization for the linear time-invariant multi-input system + :: + dX/dt = A * X + B * U, where A and B are N-by-N and N-by-M matrices, respectively, which are reduced by this routine to orthogonal canonical form using (and optionally accumulating) orthogonal similarity - transformations. Specifically, the pair (A, B) is reduced to - the pair (Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B, given by + transformations. Specifically, the pair ``(A, B)`` is reduced to + the pair ``(Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B``, given by + + :: [ Acont * ] [ Bcont ] Ac = [ ], Bc = [ ], @@ -49,69 +53,73 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): [ . . . . . ] [ . ] [ 0 0 . . . Ap,p-1 App ] [ 0 ] - where the blocks B1, A21, ..., Ap,p-1 have full row ranks and - p is the controllability index of the pair. The size of the - block Auncont is equal to the dimension of the uncontrollable - subspace of the pair (A, B). + where the blocks ``B1, A21, ..., Ap,p-1`` have full row ranks and + `p` is the controllability index of the pair. The size of the + block `Auncont` is equal to the dimension of the uncontrollable + subspace of the pair ``(A, B)``. - Required arguments: - n : input int - The order of the original state-space representation, i.e. - the order of the matrix A. N > 0. - m : input int - The number of system inputs, or of columns of B. M > 0. - A : rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the original - state dynamics matrix A. - B : rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input - matrix B. - Optional arguments: - jobz := 'N' input string(len=1) - Indicates whether the user wishes to accumulate in a matrix Z - the orthogonal similarity transformations for reducing the system, - as follows: - = 'N': Do not form Z and do not store the orthogonal transformations; - = 'F': Do not form Z, but store the orthogonal transformations in - the factored form; - = 'I': Z is initialized to the unit matrix and the orthogonal - transformation matrix Z is returned. - tol := 0 input float - The tolerance to be used in rank determination when transforming - (A, B). If tol <= 0 a default value is used. - ldwork := max(n,3*m) input int - The length of the cache array. ldwork >= max(n, 3*m). - For optimum performance it should be larger. - Return objects: - Ac : rank-2 array('d') with bounds (n,n) - The leading ncont-by-ncont part contains the upper block - Hessenberg state dynamics matrix Acont in Ac, given by Z'*A*Z, - of a controllable realization for the original system. The - elements below the first block-subdiagonal are set to zero. - Bc : rank-2 array('d') with bounds (n,m) - The leading ncont-by-m part of this array contains the transformed - input matrix Bcont in Bc, given by Z'*B, with all elements but the - first block set to zero. - ncont : int - The order of the controllable state-space representation. - indcon : int - The controllability index of the controllable part of the system - representation. - nblk : rank-1 array('i') with bounds (n) - The leading indcon elements of this array contain the the orders of - the diagonal blocks of Acont. - Z : rank-2 array('d') with bounds (n,n) - If jobz = 'I', then the leading N-by-N part of this array contains - the matrix of accumulated orthogonal similarity transformations - which reduces the given system to orthogonal canonical form. - If jobz = 'F', the elements below the diagonal, with the array tau, - represent the orthogonal transformation matrix as a product of - elementary reflectors. The transformation matrix can then be - obtained by calling the LAPACK Library routine DORGQR. - If jobz = 'N', the array Z is None. - tau : rank-1 array('d') with bounds (n) - The elements of tau contain the scalar factors of the - elementary reflectors used in the reduction of B and A.""" + Parameters + ---------- + n : int + The order of the original state-space representation, i.e. + the order of the matrix A. ``n > 0``. + m : int + The number of system inputs, or of columns of B. ``m > 0``. + A : (n,n) array_like + The original state dynamics matrix A. + B : (n,m) array_like + The input matrix B. + jobz : {'N', 'F', 'I'}, optional + Indicates whether the user wishes to accumulate in a matrix Z + the orthogonal similarity transformations for reducing the system, + as follows: + + := 'N': Do not form Z and do not store the orthogonal transformations; + (default) + := 'F': Do not form Z, but store the orthogonal transformations in + the factored form; + := 'I': Z is initialized to the unit matrix and the orthogonal + transformation matrix Z is returned. + tol : float, optional + The tolerance to be used in rank determination when transforming + ``(A, B)``. If ``tol <= 0`` a default value is used. + ldwork : int, optional + The length of the cache array. ``ldwork >= max(n, 3*m)``. + For optimum performance it should be larger. + default: ``ldwork = max(n, 3*m)`` + + Returns + ------- + Ac : (n,n) ndarray + The leading ncont-by-ncont part contains the upper block + Hessenberg state dynamics matrix Acont in Ac, given by Z'*A*Z, + of a controllable realization for the original system. The + elements below the first block-subdiagonal are set to zero. + Bc : (n,m) ndarray + The leading ncont-by-m part of this array contains the transformed + input matrix Bcont in Bc, given by ``Z'*B``, with all elements but the + first block set to zero. + ncont : int + The order of the controllable state-space representation. + indcon : int + The controllability index of the controllable part of the system + representation. + nblk : (n,) int ndarray + The leading indcon elements of this array contain the the orders of + the diagonal blocks of Acont. + Z : (n,n) ndarray + - If jobz = 'I', then the leading N-by-N part of this array contains + the matrix of accumulated orthogonal similarity transformations + which reduces the given system to orthogonal canonical form. + - If jobz = 'F', the elements below the diagonal, with the array tau, + represent the orthogonal transformation matrix as a product of + elementary reflectors. The transformation matrix can then be + obtained by calling the LAPACK Library routine DORGQR. + - If jobz = 'N', the array Z is `None`. + tau : (n, ) ndarray + The elements of tau contain the scalar factors of the + elementary reflectors used in the reduction of B and A. + """ hidden = ' (hidden by the wrapper)' arg_list = ['jobz', 'n', 'm', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, @@ -125,12 +133,13 @@ def ab01nd(n,m,A,B,jobz='N',tol=0,ldwork=None): if ldwork is None: ldwork = max(n, 3*m) - out = wrappermap[jobz](n, m, A, B, tol=tol, ldwork=ldwork) - raise_if_slycot_error(out[-1], arg_list) - # sets Z to None + Ac, Bc, ncont, indcon, nblk, Z, tau, info = \ + wrappermap[jobz](n, m, A, B, tol=tol, ldwork=ldwork) + raise_if_slycot_error(info, arg_list) + if jobz == "N": - out[5] = None - return out[:-1] + Z = None + return Ac, Bc, ncont, indcon, nblk, Z, tau def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): From 8a99d919ac8c311108aef81b8908ef5fe8ed13c9 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 19 May 2020 02:43:08 +0200 Subject: [PATCH 218/405] merge the wrapper suite for mb01nd --- slycot/analysis.py | 8 ++----- slycot/src/analysis.pyf | 49 +++-------------------------------------- 2 files changed, 5 insertions(+), 52 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index f38fe793..6073c013 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -126,15 +126,11 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): 'ncont', 'indcon', 'nblk', 'Z', 'LDZ'+hidden, 'tau', 'tol', 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'info'+hidden] - wrappermap = {"N": _wrapper.ab01nd_n, - "I": _wrapper.ab01nd_i, - "F": _wrapper.ab01nd_f} - if ldwork is None: ldwork = max(n, 3*m) - Ac, Bc, ncont, indcon, nblk, Z, tau, info = \ - wrappermap[jobz](n, m, A, B, tol=tol, ldwork=ldwork) + Ac, Bc, ncont, indcon, nblk, Z, tau, info = _wrapper.ab01nd( + jobz, n, m, A, B, tol=tol, ldwork=ldwork) raise_if_slycot_error(info, arg_list) if jobz == "N": diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 2904949c..01172cfe 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -1,7 +1,6 @@ ! -*- f90 -*- -subroutine ab01nd_i(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwork,ldwork,info) ! in AB01ND.f - fortranname ab01nd - character intent(hide) :: jobz = 'I' +subroutine ab01nd(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwork,ldwork,info) ! in AB01ND.f + character :: jobz integer check(n>0) :: n integer check(n>0) :: m double precision intent(in,out),dimension(n,n),depend(n) :: a @@ -19,49 +18,7 @@ subroutine ab01nd_i(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,d double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork integer :: ldwork = max(n,3*m) integer intent(out) :: info -end subroutine ab01nd_i -subroutine ab01nd_f(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwork,ldwork,info) ! in AB01ND.f - fortranname ab01nd - character intent(hide) :: jobz = 'F' - integer check(n>0) :: n - integer check(n>0) :: m - double precision intent(in,out),dimension(n,n),depend(n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) - double precision intent(in,out),dimension(n,m),depend(n,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) - integer intent(out) :: ncont - integer intent(out) :: indcon - integer intent(out),dimension(n),depend(n) :: nblk - double precision intent(out),dimension(n,n),depend(n) :: z - integer intent(hide),depend(z) :: ldz=shape(z,0) - double precision intent(out),dimension(n),depend(n) :: tau - double precision :: tol = 0 - integer intent(hide,cache),dimension(m),depend(m) :: iwork - double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork - integer :: ldwork = max(n,3*m) - integer intent(out) :: info -end subroutine ab01nd_f -subroutine ab01nd_n(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwork,ldwork,info) ! in AB01ND.f - fortranname ab01nd - character intent(hide) :: jobz = 'N' - integer check(n>0) :: n - integer check(n>0) :: m - double precision intent(in,out),dimension(n,n),depend(n) :: a - integer intent(hide),depend(a) :: lda=shape(a,0) - double precision intent(in,out),dimension(n,m),depend(n,m) :: b - integer intent(hide),depend(b) :: ldb=shape(b,0) - integer intent(out) :: ncont - integer intent(out) :: indcon - integer intent(out),dimension(n),depend(n) :: nblk - double precision intent(out),dimension(1,1),depend(n) :: z - integer intent(hide),depend(z) :: ldz=shape(z,0) - double precision intent(out),dimension(n),depend(n) :: tau - double precision :: tol = 0 - integer intent(hide,cache),dimension(m),depend(m) :: iwork - double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork - integer :: ldwork = max(n,3*m) - integer intent(out) :: info -end subroutine ab01nd_n +end subroutine ab01nd subroutine ab05md(uplo,over,n1,m1,p1,n2,p2,a1,lda1,b1,ldb1,c1,ldc1,d1,ldd1,a2,lda2,b2,ldb2,c2,ldc2,d2,ldd2,n,a,lda,b,ldb,c,ldc,d,ldd,dwork,ldwork,info) ! in AB05MD.f character :: uplo = 'U' character intent(hide) :: over = 'N' ! not sure how the overlap works From db2c5354e159a6305148327948c11457a7d28389 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 19 May 2020 02:55:05 +0200 Subject: [PATCH 219/405] make compatible with older pythons --- slycot/tests/test_exceptions.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 13e2da27..beb3fa0c 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -104,5 +104,5 @@ def test_xerbla_override(): stdout = subprocess.check_output([sys.executable, '-c', CODE], stderr=subprocess.STDOUT, - text=True) + universal_newlines=True) assert stdout == "INFO=-1\n" From 0fd455a4e3b2f78887ff0e5b1acb862c708c8347 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 19 May 2020 03:18:20 +0200 Subject: [PATCH 220/405] allocate less memory fo Z if unneeded --- slycot/src/analysis.pyf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 01172cfe..3115d983 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -10,8 +10,8 @@ subroutine ab01nd(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwo integer intent(out) :: ncont integer intent(out) :: indcon integer intent(out),dimension(n),depend(n) :: nblk - double precision intent(out),dimension(n,n),depend(n) :: z - integer intent(hide),depend(z) :: ldz=shape(z,0) + double precision intent(out),dimension(ldz,n),depend(n,ldz) :: z + integer intent(hide),depend(n) :: ldz = (*jobz == 'N' ? 1 : n) double precision intent(out),dimension(n),depend(n) :: tau double precision :: tol = 0 integer intent(hide,cache),dimension(m),depend(m) :: iwork From 822f69d52e1d2d61f6fd5d924928f4985a78cf26 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Tue, 19 May 2020 05:31:33 +0200 Subject: [PATCH 221/405] fix typo in wrapper --- slycot/src/analysis.pyf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 3115d983..3b36aeb3 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -2,7 +2,7 @@ subroutine ab01nd(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwork,ldwork,info) ! in AB01ND.f character :: jobz integer check(n>0) :: n - integer check(n>0) :: m + integer check(m>0) :: m double precision intent(in,out),dimension(n,n),depend(n) :: a integer intent(hide),depend(a) :: lda=shape(a,0) double precision intent(in,out),dimension(n,m),depend(n,m) :: b @@ -11,7 +11,7 @@ subroutine ab01nd(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwo integer intent(out) :: indcon integer intent(out),dimension(n),depend(n) :: nblk double precision intent(out),dimension(ldz,n),depend(n,ldz) :: z - integer intent(hide),depend(n) :: ldz = (*jobz == 'N' ? 1 : n) + integer intent(hide),depend(n, jobz) :: ldz = (*jobz == 'N' ? 1 : n) double precision intent(out),dimension(n),depend(n) :: tau double precision :: tol = 0 integer intent(hide,cache),dimension(m),depend(m) :: iwork From 9862672ee3a97d221641bc8e8074ff857ab94ff0 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 19 May 2020 12:51:20 +0200 Subject: [PATCH 222/405] update header comment in test_ab08n AB08NX is a Fortran subroutine --- slycot/tests/test_ab08n.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py index 81d1000f..06fd0c0d 100644 --- a/slycot/tests/test_ab08n.py +++ b/slycot/tests/test_ab08n.py @@ -1,5 +1,5 @@ # =================================================== -# ab08nX tests +# ab08n* tests import unittest from slycot import analysis From 92f9be6fd86cfa5b3e2e7a84261bf13a450e8c8e Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 20 May 2020 13:17:02 +0200 Subject: [PATCH 223/405] expand test_xerbla_override to allow debugging --- slycot/tests/test_exceptions.py | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index beb3fa0c..9ed6415e 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -24,6 +24,7 @@ from slycot.exceptions import raise_if_slycot_error, \ SlycotError, SlycotWarning, SlycotParameterError +from slycot import _wrapper def assert_docstring_parse(docstring, exception_class, erange, checkvars={}): @@ -92,7 +93,8 @@ def test_unhandled_info_iwarn(): # Test code for test_xerbla_override CODE = """ -from slycot._wrapper import ab08nd +from slycot._wrapper import __file__, ab08nd +print(__file__) # equil='X' is invalid out = ab08nd(1, 1, 1, [1], [1], [1], [1], equil='X') print("INFO={}".format(out[-1])) @@ -102,7 +104,17 @@ def test_unhandled_info_iwarn(): def test_xerbla_override(): """Test that Fortran routines calling XERBLA do not print to stdout.""" - stdout = subprocess.check_output([sys.executable, '-c', CODE], - stderr=subprocess.STDOUT, - universal_newlines=True) - assert stdout == "INFO=-1\n" + ret = subprocess.run([sys.executable, '-c', CODE], + capture_output=True, + universal_newlines=True) + if ret.returncode: + raise RuntimeError("Trying to call _wrapper.ab08nd() failed with " + "returncode {}.\n" + "Captured STDOUT: \n {}\n" + "Captured STDERR: \n {}\n" + "".format(ret.returncode, ret.stdout, ret.stderr)) + + outlines = ret.stdout.splitlines() + assert len(outlines) == 2 + assert outlines[0] == _wrapper.__file__ + assert outlines[1] == "INFO=-1" From e197bde6093a06ef6cb434461726fcd08d377d19 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 20 May 2020 16:25:23 +0200 Subject: [PATCH 224/405] older pythons --- slycot/tests/test_exceptions.py | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 9ed6415e..8e6d9232 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -104,17 +104,18 @@ def test_unhandled_info_iwarn(): def test_xerbla_override(): """Test that Fortran routines calling XERBLA do not print to stdout.""" - ret = subprocess.run([sys.executable, '-c', CODE], - capture_output=True, - universal_newlines=True) - if ret.returncode: + try: + out = subprocess.check_output([sys.executable, '-c', CODE], + stderr=subprocess.STDOUT, + universal_newlines=True) + except subprocess.CalledProcessError as cpe: raise RuntimeError("Trying to call _wrapper.ab08nd() failed with " "returncode {}.\n" "Captured STDOUT: \n {}\n" "Captured STDERR: \n {}\n" - "".format(ret.returncode, ret.stdout, ret.stderr)) + "".format(cpe.returncode, cpe.stdout, cpe.stderr)) - outlines = ret.stdout.splitlines() + outlines = out.splitlines() assert len(outlines) == 2 assert outlines[0] == _wrapper.__file__ assert outlines[1] == "INFO=-1" From 9f18918932bb7a4af8f6781432001e14c3f70129 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 21 May 2020 00:04:36 +0200 Subject: [PATCH 225/405] pop first sys.path element --- slycot/tests/test_exceptions.py | 2 ++ 1 file changed, 2 insertions(+) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 8e6d9232..4953cb04 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -93,6 +93,8 @@ def test_unhandled_info_iwarn(): # Test code for test_xerbla_override CODE = """ +import sys +sys.path.pop(0) # do not import from current directory ('') from slycot._wrapper import __file__, ab08nd print(__file__) # equil='X' is invalid From 60399567b66eed688436d7b1838e333dd3331233 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 21 May 2020 01:45:40 +0200 Subject: [PATCH 226/405] enhance testing section in README [skip ci] --- README.rst | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/README.rst b/README.rst index 652d69d7..5f83a12f 100644 --- a/README.rst +++ b/README.rst @@ -91,7 +91,7 @@ you'll have to choose the right recipe directory. On Linux you can choose between ``conda-recipe-openblas`` and ``conda-recipe-mkl`` -On macOS you should use ``conda-recipe-apple``. See the +On macOS you should use ``conda-recipe-apple``. See the `conda-build documentation`_ how to get the required macOS SDK. .. _conda-build documentation: https://docs.conda.io/projects/conda-build/en/latest/resources/compiler-tools.html#macos-sdk @@ -129,9 +129,16 @@ install Slycot (this example creates a Python 3.8 environment):: conda activate build-slycot python setup.py install - pytest -The final ``pytest`` command is optional; it runs the Slycot unit tests. +Testing +~~~~~~~ +To test if the installation was successful, you can run the slycot unit tests:: + + pytest --pyargs slycot + +Running ``pytest`` without ``--pyargs slycot`` from inside the source directory +will fail, unless either ``setup.cfg`` or the compiled wrapper library have +been installed into that directory. General notes on compiling ~~~~~~~~~~~~~~~~~~~~~~~~~~ From 36ceb478b1a88fdb00eae9eca036716a7bb057f5 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 24 May 2020 18:28:33 +0200 Subject: [PATCH 227/405] make test_example more verbose on failures --- slycot/CMakeLists.txt | 5 +++-- slycot/tests/test_examples.py | 21 ++++++++++++++++++--- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 928c4737..c8c564a1 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -117,8 +117,9 @@ configure_file(version.py.in version.py @ONLY) set(PYSOURCE - __init__.py analysis.py examples.py math.py synthesis.py - transform.py ${CMAKE_CURRENT_BINARY_DIR}/version.py) + __init__.py examples.py exceptions.py + analysis.py math.py synthesis.py transform.py + ${CMAKE_CURRENT_BINARY_DIR}/version.py) set(SLYCOT_MODULE "_wrapper") find_package(PythonExtensions REQUIRED) diff --git a/slycot/tests/test_examples.py b/slycot/tests/test_examples.py index b926e2ea..bf43200d 100644 --- a/slycot/tests/test_examples.py +++ b/slycot/tests/test_examples.py @@ -14,7 +14,10 @@ if isfunction(fun) and "_example" in fname] +#ignore numpy ABI changes https://github.com/numpy/numpy/pull/432 @pytest.mark.parametrize('examplefun', examplefunctions) +@pytest.mark.filterwarnings("ignore:numpy.dtype size changed") +@pytest.mark.filterwarnings("ignore:numpy.ufunc size changed") def test_example(examplefun, capsys, recwarn): """ Test the examples. @@ -24,6 +27,18 @@ def test_example(examplefun, capsys, recwarn): """ examplefun() captured = capsys.readouterr() - assert len(captured.out) > 0 - assert not captured.err - assert not recwarn + + # fail for first in order + failconditions = [ + ((not len(captured.out) > 0), "Example {} did not print any results\n"), + (captured.err, "Example {} wrote to stderr\n"), + (recwarn, "Example {} produced a warning.\n")] + for failed, msgfmt in failconditions: + if failed: + pytest.fail(msgfmt.format(examplefun.__name__) + + "Captured output:\n{}\n" + "Captured stderr:\n{}\n" + "Captured warnings:\n{}\n" + "".format(captured.out, + captured.err, + [w.message for w in recwarn])) From 443577d595a79d09cfae5be08ee84e1a23b90380 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 24 May 2020 18:48:38 +0200 Subject: [PATCH 228/405] move test_mc to pytest This fixes a failure with -Werror not taking into account that the warning is expected --- slycot/tests/test_mc.py | 87 ++++++++++++++++++----------------------- 1 file changed, 39 insertions(+), 48 deletions(-) diff --git a/slycot/tests/test_mc.py b/slycot/tests/test_mc.py index 5c3012d5..b27c0481 100644 --- a/slycot/tests/test_mc.py +++ b/slycot/tests/test_mc.py @@ -2,53 +2,44 @@ # test_mc.py - test suite for polynomial and rational function manipulation # bnavigator , Aug 2019 -import unittest -import warnings +import pytest +import re from slycot import mc01td - - -class test_mc(unittest.TestCase): - - def test_mc01td(self): - """ test_mc01td: doc example - data from http://slicot.org/objects/software/shared/doc/MC01TD.html - """ - (dp, stable, nz) = mc01td('C', 4, [2, 0, 1, -1, 1]) - self.assertEqual(dp, 4) - self.assertEqual(stable, 0) - self.assertEqual(nz, 2) - - def test_mc01td_D(self): - """ test_mc01td_D: test discrete option """ - (dp, stable, nz) = mc01td('D', 3, [1, 2, 3, 4]) - self.assertEqual(dp, 3) - self.assertEqual(stable, 1) - self.assertEqual(nz, 0) - (dp, stable, nz) = mc01td('D', 3, [4, 3, 2, 1]) - self.assertEqual(dp, 3) - self.assertEqual(stable, 0) - self.assertEqual(nz, 3) - - def test_mc01td_warnings(self): - """ test_mc01td_warnings: Test warnings """ - T = [([0, 0], "\n" - "Entry ``P(x)`` is the zero polynomial."), - ([0, 1], "\n" - "The polynomial ``P(x)`` is most probably unstable,\n" - "although it may be stable with one or more zeros\n" - "very close to the imaginary axis.\n" - "The number of unstable zeros (NZ) is not determined."), - ([1, 0], "\n" - "The degree of the polynomial ``P(x)`` has been\n" - "reduced to ``(DB - 1)`` because\n" - "``P(DB+1-j) = 0.0`` on entry\n" - "for ``j = 0, 1,..., k-1`` and ``P(DB+1-k) <> 0.0``.")] - for P, m in T: - with warnings.catch_warnings(record=True) as w: - (dp, stable, nz) = mc01td('C', len(P)-1, P) - self.assertEqual(str(w[0].message), m) - - -if __name__ == "__main__": - unittest.main() +from slycot.exceptions import SlycotResultWarning + + +def test_mc01td(): + """ test_mc01td: doc example + data from http://slicot.org/objects/software/shared/doc/MC01TD.html + """ + (dp, stable, nz) = mc01td('C', 4, [2, 0, 1, -1, 1]) + assert dp == 4 + assert stable == 0 + assert nz == 2 + +def test_mc01td_D(): + """ test_mc01td_D: test discrete option """ + (dp, stable, nz) = mc01td('D', 3, [1, 2, 3, 4]) + assert dp == 3 + assert stable == 1 + assert nz == 0 + (dp, stable, nz) = mc01td('D', 3, [4, 3, 2, 1]) + assert dp == 3 + assert stable == 0 + assert nz == 3 + +def test_mc01td_warnings(): + """ test_mc01td_warnings: Test warnings """ + T = [([0, 0], "Entry ``P(x)`` is the zero polynomial."), + ([0, 1], "The polynomial ``P(x)`` is most probably unstable,\n" + "although it may be stable with one or more zeros\n" + "very close to the imaginary axis.\n" + "The number of unstable zeros (NZ) is not determined."), + ([1, 0], "The degree of the polynomial ``P(x)`` has been\n" + "reduced to ``(DB - 1)`` because\n" + "``P(DB+1-j) = 0.0`` on entry\n" + "for ``j = 0, 1,..., k-1`` and ``P(DB+1-k) <> 0.0``.")] + for P, m in T: + with pytest.warns(SlycotResultWarning, match=re.escape(m)): + (dp, stable, nz) = mc01td('C', len(P)-1, P) From af98e9fca2d94e2ade6518034eea3405ee2fa0bd Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 24 May 2020 20:23:08 +0200 Subject: [PATCH 229/405] allow ab13fd_example to warn about computation of beta(A) --- slycot/tests/test_examples.py | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/slycot/tests/test_examples.py b/slycot/tests/test_examples.py index bf43200d..1197e14a 100644 --- a/slycot/tests/test_examples.py +++ b/slycot/tests/test_examples.py @@ -13,9 +13,25 @@ examplefunctions = [fun for (fname, fun) in getmembers(examples) if isfunction(fun) and "_example" in fname] +# Exempt certain functions to produce warnings with attributes (iwarn, info) +# +# Failed to compute beta(A) within the specified tolerance +examples.ab13fd_example.allow_iwarninfo = [(None, 1)] + + +def check_warn(recwarn, examplefun): + """Returns True if a warning occurs that is not exempt""" + for w in recwarn: + try: + if (w.message.iwarn, w.message.info) in examplefun.allow_iwarninfo: + continue + except AttributeError: + pass + return True + -#ignore numpy ABI changes https://github.com/numpy/numpy/pull/432 @pytest.mark.parametrize('examplefun', examplefunctions) +#ignore numpy ABI change warnings https://github.com/numpy/numpy/pull/432 @pytest.mark.filterwarnings("ignore:numpy.dtype size changed") @pytest.mark.filterwarnings("ignore:numpy.ufunc size changed") def test_example(examplefun, capsys, recwarn): @@ -32,7 +48,7 @@ def test_example(examplefun, capsys, recwarn): failconditions = [ ((not len(captured.out) > 0), "Example {} did not print any results\n"), (captured.err, "Example {} wrote to stderr\n"), - (recwarn, "Example {} produced a warning.\n")] + (check_warn(recwarn, examplefun), "Example {} produced a warning.\n")] for failed, msgfmt in failconditions: if failed: pytest.fail(msgfmt.format(examplefun.__name__) + From ee91d27bae22bb142c5b41f7ff45da4d9a300a42 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 30 May 2020 23:37:15 +0200 Subject: [PATCH 230/405] better samefile assertion for test_xerbla_override --- slycot/tests/test_exceptions.py | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index 4953cb04..c0ce66a3 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -1,5 +1,5 @@ """ -docstring_check.py +test_exceptions.py Copyright 2020 Slycot team @@ -18,10 +18,12 @@ MA 02110-1301, USA. """ -import pytest +import os import subprocess import sys +import pytest + from slycot.exceptions import raise_if_slycot_error, \ SlycotError, SlycotWarning, SlycotParameterError from slycot import _wrapper @@ -119,5 +121,5 @@ def test_xerbla_override(): outlines = out.splitlines() assert len(outlines) == 2 - assert outlines[0] == _wrapper.__file__ + assert os.path.samefile(outlines[0], _wrapper.__file__) assert outlines[1] == "INFO=-1" From bd54ced70c8b3a91603f094b9ac71fff2c35d998 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sat, 30 May 2020 23:59:31 +0200 Subject: [PATCH 231/405] switch old numpy nosetester to pytest call --- slycot/__init__.py | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 0c2b3c70..bad973fe 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -43,6 +43,7 @@ # Version information from .version import version as __version__ - from numpy.testing import Tester - test = Tester().test - bench = Tester().bench + +def test(): + import pytest + pytest.main(['--pyargs', 'slycot']) From 8d732dc3f1ba94bf0566cfc4cc0a35c602d66995 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 31 May 2020 01:13:34 +0200 Subject: [PATCH 232/405] mention slycot.test() call to README --- README.rst | 13 ++++++++++--- slycot/__init__.py | 2 +- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/README.rst b/README.rst index 5f83a12f..aaec6eb5 100644 --- a/README.rst +++ b/README.rst @@ -136,9 +136,16 @@ To test if the installation was successful, you can run the slycot unit tests:: pytest --pyargs slycot -Running ``pytest`` without ``--pyargs slycot`` from inside the source directory -will fail, unless either ``setup.cfg`` or the compiled wrapper library have -been installed into that directory. +You may also run the tests by calling ``slycot.test()`` from within the python +interpreter:: + + import slycot + slycot.test() + +Importing ``slycot`` or running ``pytest`` without ``--pyargs slycot`` from +inside the source directory will fail, unless the compiled wrapper library has +been installed into that directory. Note that the ``[tool:pytest]`` section +in ``setup.cfg`` enforces the ``--pyargs slycot`` argument by default. General notes on compiling ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/slycot/__init__.py b/slycot/__init__.py index bad973fe..cf777c38 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -6,7 +6,7 @@ if __SLYCOT_SETUP__: import sys as _sys - _sys.stderr.write('Running from numpy source directory.\n') + _sys.stderr.write('Running from Slycot source directory.\n') del _sys else: From 1cadd325c24efb606479304b2af237ae0aba9f0b Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Wed, 30 Dec 2020 12:47:26 +0200 Subject: [PATCH 233/405] BUG: correct mb03rd for default X=None argument Added a test for this case. --- slycot/math.py | 4 ++-- slycot/tests/test_mb.py | 21 +++++++++++++++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 10583330..35f00e33 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -42,7 +42,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): The matrix `A` to be block-diagonalized, in real Schur form. X : (n, n) array_like, optional A given matrix `X`, for accumulation of transformations (only if - `jobx`='U') + `jobx`='U'). Default value is identity matrix of order `n`. jobx : {'N', 'U'}, optional Specifies whether or not the transformations are accumulated, as follows: @@ -230,7 +230,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): 'dwork' + hidden, 'info'] if X is None: - X = np.zeros((1, n)) + X = np.eye(n) Ar, Xr, nblcks, blsize, wr, wi, info = _wrapper.mb03rd( jobx, sort, n, pmax, A, X, tol) diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index 99d320d1..ff0456bb 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -86,6 +86,27 @@ def test_mb03rd(self): test1_n, A, X, 'N', sort, test1_pmax, test1_tol) assert Xr is None + + def test_mb03rd_default(self): + # regression: mb03rd was failing with no third arg (X) supplied + A = np.array([[ 6, -1, -7, -2, 2], + [-3, 4, 2, -7, 6], + [-6, -9, -3, -1, 10], + [-2, -4, 1, 5, 7], + [-7, -5, -6, 6, 7]]) + + Aschur, Tschur = schur(A) + + X = Tschur.copy() + + Ar, Xr, blsize, W = mb03rd(Aschur.shape[0], Aschur, X, 'U', 'N', pmax=1.0, tol=0.0) + + Ar2, Xr2, blsize2, W2 = mb03rd(Aschur.shape[0], Aschur) + + assert_allclose(Ar, Ar2) + assert_allclose(Xr, Tschur.dot(Xr2)) + + def test_mb03vd_mb03vy_ex(self): """Test MB03VD and MB03VY with the example given in the MB03VD SLICOT documentation""" From cc350e9fd1e6da4c547955e89a1978972050f1e7 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 31 Dec 2020 15:52:29 +0100 Subject: [PATCH 234/405] fix conda install of built package in travis --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 53a96738..f5fe00d0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -124,7 +124,8 @@ install: $conda_blas conda activate test-environment export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib" - conda build --python "$SLYCOT_PYTHON_VERSION" $conda_recipe + numpyversion=$(python -c 'import numpy; print(numpy.version.version)') + conda build --python "$SLYCOT_PYTHON_VERSION" --numpy $numpyversion $conda_recipe conda install local::slycot elif [[ $TEST_PKG == dist ]]; then pip install scikit-build pytest-cov matplotlib scipy; From 060aada5edd7dde8021b45adddc8169876d754c3 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 31 Dec 2020 18:17:45 +0100 Subject: [PATCH 235/405] Drop Python2 and Python 3.5, Add Python 3.9 testing --- .travis.yml | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/.travis.yml b/.travis.yml index f5fe00d0..9c397bec 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,6 +6,7 @@ services: xvfb # needed for the python-control tests # Start with a 2x4 matrix of Linux builds python: + - "3.9 - "3.8" - "3.7" env: @@ -20,14 +21,6 @@ jobs: - name: "Linux, Conda Python 3.6" python: "3.6" env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - name: "Linux, Conda Python 3.5" - python: "3.5" - env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - name: "Linux, Ubuntu 16.04, System Python 2.7" - python: "2.7" - dist: xenial - env: TEST_PKG="dist" BLA_VENDOR="OpenBLAS" - # (Conda Python 2 is broken due to pytest-cov dependencies) - name: "MacOSX, Conda Python 3" os: osx language: shell @@ -36,14 +29,10 @@ jobs: os: osx language: shell env: TEST_PKG="dist" BLA_VENDOR="Apple" - - name: "MacOSX, pyenv 3.8.0" - os: osx - language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 - - name: "MacOSX, pyenv 2.7.17" + - name: "MacOSX, pyenv 3.8.7" os: osx language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=2.7.17 + env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.7 before_install: From ccae062c8ceef03696b302c694aa8aef36a22084 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 5 Jan 2021 22:39:14 +0100 Subject: [PATCH 236/405] Whitespace style update --- slycot/math.py | 2 +- slycot/tests/test_mb.py | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 35f00e33..336b4b4b 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -42,7 +42,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): The matrix `A` to be block-diagonalized, in real Schur form. X : (n, n) array_like, optional A given matrix `X`, for accumulation of transformations (only if - `jobx`='U'). Default value is identity matrix of order `n`. + `jobx`='U'). Default value is identity matrix of order `n`. jobx : {'N', 'U'}, optional Specifies whether or not the transformations are accumulated, as follows: diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index ff0456bb..1c8e137e 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -86,7 +86,6 @@ def test_mb03rd(self): test1_n, A, X, 'N', sort, test1_pmax, test1_tol) assert Xr is None - def test_mb03rd_default(self): # regression: mb03rd was failing with no third arg (X) supplied A = np.array([[ 6, -1, -7, -2, 2], @@ -106,7 +105,6 @@ def test_mb03rd_default(self): assert_allclose(Ar, Ar2) assert_allclose(Xr, Tschur.dot(Xr2)) - def test_mb03vd_mb03vy_ex(self): """Test MB03VD and MB03VY with the example given in the MB03VD SLICOT documentation""" From 5a2798d331c3aa26870052550c632f5c477527c3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 6 Jan 2021 14:33:29 +0100 Subject: [PATCH 237/405] Fix travis --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 9c397bec..454753e8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ services: xvfb # needed for the python-control tests # Start with a 2x4 matrix of Linux builds python: - - "3.9 + - "3.9" - "3.8" - "3.7" env: From 579f88758e9a04597d2d678169fec47b34ea231d Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 Jan 2021 03:08:15 +0100 Subject: [PATCH 238/405] clean setup.py and CMakeLists.txt --- CMakeLists.txt | 33 +++--------------- README.rst | 6 ++-- setup.py | 80 ++++--------------------------------------- slycot/CMakeLists.txt | 6 ++-- 4 files changed, 16 insertions(+), 109 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 26c01c5c..b018ff83 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -7,46 +7,21 @@ if (CMAKE_VERSION VERSION_GREATER "3.11.99") endif() project(slycot VERSION ${SLYCOT_VERSION} LANGUAGES NONE) -# Fortran detection fails on windows, use the CMAKE_C_SIMULATE flag to -# force success -if(WIN32) - set(CMAKE_Fortran_SIMULATE_VERSION 19.0) -endif() -# this does not seem to work, maybe scikit-build's doing? the cxx compiler is -# still tested enable_language(C) enable_language(Fortran) -# base site dir, use python installation for location specific includes -execute_process( - COMMAND "${PYTHON_EXECUTABLE}" -c - "import os,numpy; print(os.path.dirname(numpy.__path__[0]))" - OUTPUT_VARIABLE PYTHON_SITE - OUTPUT_STRIP_TRAILING_WHITESPACE) -if(WIN32) - string(REPLACE "\\" "/" PYTHON_SITE ${PYTHON_SITE}) -endif() - find_package(PythonLibs REQUIRED) +find_package(PythonExtensions REQUIRED) find_package(NumPy REQUIRED) +find_package(F2PY REQUIRED) find_package(BLAS REQUIRED) find_package(LAPACK REQUIRED) -message(STATUS "NumPy: ${NumPy_INCLUDE_DIR}") +message(STATUS "NumPy included from: ${NumPy_INCLUDE_DIR}") +message(STATUS "F2PY included from: ${F2PY_INCLUDE_DIR}") message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") message(STATUS "BLAS: ${BLAS_LIBRARIES}") message(STATUS "Slycot version: ${SLYCOT_VERSION}") -# find python, standard packages, F2PY find flaky on Windows -if (NOT WIN32) - find_package(F2PY REQUIRED) -endif() - -# pic option for flang not correct, remove for Windows -if (WIN32) - set(CMAKE_Fortran_COMPILE_OPTIONS_PIC "") -endif() - add_subdirectory(slycot) - diff --git a/README.rst b/README.rst index aaec6eb5..769fdea3 100644 --- a/README.rst +++ b/README.rst @@ -19,18 +19,18 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ -Slycot supports Python versions 2.7, and 3.5 or later. +Slycot supports Python versions 3.6 or later. To run the compiled Slycot package, the following must be installed as dependencies: -- Python 2.7, 3.5+ +- Python 3.6+ - NumPy If you are compiling and installing Slycot from source, you will need the following dependencies: -- Python 2.7, 3.5+ +- 3.6+ - NumPy - scikit-build >= 0.10.0 - CMake diff --git a/setup.py b/setup.py index 9e1e6dfc..be412257 100644 --- a/setup.py +++ b/setup.py @@ -6,6 +6,7 @@ """ +import builtins import os import sys import subprocess @@ -16,19 +17,14 @@ except ImportError: import ConfigParser as configparser -if sys.version_info[0] >= 3: - import builtins -else: - import __builtin__ as builtins - try: from skbuild import setup from skbuild.command.sdist import sdist except ImportError: raise ImportError('scikit-build must be installed before running setup.py') -if sys.version_info[:2] < (2, 7) or (3, 0) <= sys.version_info[0:2] < (3, 5): - raise RuntimeError("Python version 2.7 or >= 3.5 required.") +if sys.version_info[0:2] < (3, 6): + raise RuntimeError("Python version >= 3.6 required.") DOCLINES = __doc__.split("\n") @@ -41,8 +37,10 @@ Programming Language :: C Programming Language :: Fortran Programming Language :: Python -Programming Language :: Python :: 2 -Programming Language :: Python :: 3 +Programming Language :: Python :: 3.6 +Programming Language :: Python :: 3.7 +Programming Language :: Python :: 3.8 +Programming Language :: Python :: 3.9 Topic :: Software Development Topic :: Scientific/Engineering Operating System :: Microsoft :: Windows @@ -190,35 +188,6 @@ def get_version_info(srcdir=None): return FULLVERSION, GIT_REVISION -def check_submodules(): - """ verify that the submodules are checked out and clean - use `git submodule update --init`; on failure - """ - if not os.path.exists('.git'): - return - with open('.gitmodules') as f: - for l in f: - if 'path' in l: - p = l.split('=')[-1].strip() - if not os.path.exists(p): - raise ValueError('Submodule %s missing' % p) - - proc = subprocess.Popen(['git', 'submodule', 'status'], - stdout=subprocess.PIPE) - status, _ = proc.communicate() - status = status.decode("ascii", "replace") - for line in status.splitlines(): - if line.startswith('-') or line.startswith('+'): - raise ValueError('Submodule not clean: %s' % line) - - -class sdist_checked(sdist): - """ check submodules on sdist to prevent incomplete tarballs """ - def run(self): - # slycot had no submodules currently - # check_submodules() - sdist.run(self) - def setup_package(): src_path = os.path.dirname(os.path.abspath(__file__)) @@ -241,7 +210,6 @@ def setup_package(): license='GPL-2.0', classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], - cmdclass={"sdist": sdist_checked}, cmake_args=['-DSLYCOT_VERSION:STRING=' + VERSION, '-DGIT_REVISION:STRING=' + gitrevision, '-DISRELEASE:STRING=' + str(ISRELEASED), @@ -250,40 +218,6 @@ def setup_package(): install_requires=['numpy'], ) - # Windows builds use Flang. - # Flang detection and configuration is not automatic yet; the CMAKE - # settings below are to circumvent that; when scikit-build and cmake - # tools have improved, most of this might be removed? - if platform.system() == 'Windows': - - pbase = r'/'.join(sys.executable.split(os.sep)[:-1]) - env2cmakearg = { - 'FC': ('-DCMAKE_Fortran_COMPILER=', - pbase + r'/Library/bin/flang.exe'), - 'F2PY': ('-DF2PY_EXECUTABLE=', - pbase + r'/Scripts/f2py.exe'), - 'NUMPY_INCLUDE': ('-DNumPy_INCLUDE_DIR=', - pbase + r'/Include') - } - - metadata['cmake_args'].extend(['-GNMake Makefiles']) - - for k, v in env2cmakearg.items(): - print(k, v, os.environ.get(k, '')) - envval = os.environ.get(k, None) - if envval: - # get from environment - metadata['cmake_args'].append( - v[0] + envval.replace('\\', '/')) - else: - # default - metadata['cmake_args'].append(v[0] + v[1]) - - metadata['cmake_args'].extend([ - '-DCMAKE_Fortran_SIMULATE_VERSION=5.0.0', - '-DCMAKE_Fortran_COMPILER_ID=Flang', - '-DCMAKE_VERBOSE_MAKEFILE:BOOL=ON']) - print(metadata['cmake_args']) try: setup(**metadata) finally: diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index c8c564a1..8687d0eb 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -122,7 +122,6 @@ set(PYSOURCE ${CMAKE_CURRENT_BINARY_DIR}/version.py) set(SLYCOT_MODULE "_wrapper") -find_package(PythonExtensions REQUIRED) set(GENERATED_MODULE ${CMAKE_CURRENT_BINARY_DIR}/${SLYCOT_MODULE}${PYTHON_EXTENSION_MODULE_SUFFIX}) @@ -141,7 +140,7 @@ add_custom_command( add_library( ${SLYCOT_MODULE} MODULE _wrappermodule.c - ${PYTHON_SITE}/numpy/f2py/src/fortranobject.c + ${F2PY_INCLUDE_DIR}/fortranobject.c _wrapper-f2pywrappers.f ${FSOURCES}) @@ -150,8 +149,7 @@ target_link_libraries(${SLYCOT_MODULE} target_include_directories( ${SLYCOT_MODULE} PUBLIC - ${PYTHON_SITE}/numpy/core/include - ${PYTHON_SITE}/numpy/f2py/src + ${F2PY_INCLUDE_DIRS} ${PYTHON_INCLUDE_DIRS} ) From a45be5fa76c43a845c5aa8166f6e48abde59dd03 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 Jan 2021 15:42:46 +0100 Subject: [PATCH 239/405] allow failure of python 3.9 conda, mkl --- .travis.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 454753e8..c12b813d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,11 +29,13 @@ jobs: os: osx language: shell env: TEST_PKG="dist" BLA_VENDOR="Apple" - - name: "MacOSX, pyenv 3.8.7" + - name: "MacOSX, pyenv 3.8.0" os: osx language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.7 - + env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 + allow_failures: + - python: "3.9" + env: TEST_PKG="conda" BLA_VENDOR="Intel10_64lp" before_install: - | From 77b28a4a30e7a1b3ed47687464206434bc5c42d6 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 Jan 2021 03:09:41 +0100 Subject: [PATCH 240/405] merge conda-recipes --- .travis.yml | 38 ++++++------- conda-recipe-apple/conda_build_config.yaml | 2 - conda-recipe-apple/meta.yaml | 46 ---------------- conda-recipe-mkl/build.sh | 10 ---- conda-recipe-mkl/meta.yaml | 46 ---------------- conda-recipe-openblas/build.sh | 11 ---- conda-recipe-openblas/meta.yaml | 46 ---------------- conda-recipe/bld.bat | 6 ++ {conda-recipe-apple => conda-recipe}/build.sh | 10 ++-- conda-recipe/meta.yaml | 55 +++++++++++++++++++ 10 files changed, 81 insertions(+), 189 deletions(-) delete mode 100644 conda-recipe-apple/conda_build_config.yaml delete mode 100644 conda-recipe-apple/meta.yaml delete mode 100644 conda-recipe-mkl/build.sh delete mode 100644 conda-recipe-mkl/meta.yaml delete mode 100644 conda-recipe-openblas/build.sh delete mode 100644 conda-recipe-openblas/meta.yaml create mode 100644 conda-recipe/bld.bat rename {conda-recipe-apple => conda-recipe}/build.sh (57%) create mode 100644 conda-recipe/meta.yaml diff --git a/.travis.yml b/.travis.yml index c12b813d..5e7ef02c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,7 +13,7 @@ env: - TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - TEST_PKG="conda" BLA_VENDOR="Intel10_64lp" # MKL - TEST_PKG="dist" BLA_VENDOR="OpenBLAS" - - TEST_PKG="dist" BLA_VENDOR="Generic" # reference BLAS/LAPACK + - TEST_PKG="dist" BLA_VENDOR="Generic" # force reference BLAS/LAPACK jobs: # additional single Linux and OSX jobs @@ -33,9 +33,6 @@ jobs: os: osx language: shell env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 - allow_failures: - - python: "3.9" - env: TEST_PKG="conda" BLA_VENDOR="Intel10_64lp" before_install: - | @@ -90,34 +87,31 @@ install: source "$HOME/miniconda/etc/profile.d/conda.sh" hash -r conda config --set always_yes yes --set changeps1 no - conda update -q --all conda install conda-build conda install conda-verify - conda config --append channels conda-forge; + conda config --add channels conda-forge; + conda update -q --all conda info -a; - if [[ $BLA_VENDOR == "OpenBLAS" ]]; then - conda_blas=openblas - conda_recipe=conda-recipe-openblas - elif [[ $BLA_VENDOR == "Intel10_64lp" ]]; then - conda_blas=mkl - conda_recipe=conda-recipe-mkl - elif [[ $BLA_VENDOR == "Apple" ]]; then - conda_blas= - conda_recipe=conda-recipe-apple - else - echo "Unsupported BLA_VENDOR for conda builds: $BLA_VENDOR" - exit 3 - fi conda create -q -n test-environment \ python="$SLYCOT_PYTHON_VERSION" \ pip coverage pytest-cov \ - numpy scipy matplotlib \ - $conda_blas + numpy scipy matplotlib conda activate test-environment export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib" numpyversion=$(python -c 'import numpy; print(numpy.version.version)') - conda build --python "$SLYCOT_PYTHON_VERSION" --numpy $numpyversion $conda_recipe + conda build --python "$SLYCOT_PYTHON_VERSION" --numpy $numpyversion conda-recipe conda install local::slycot + if [[ $BLA_VENDOR == "OpenBLAS" ]]; then + conda install 'libblas=*=*openblas' + elif [[ $BLA_VENDOR == "Intel10_64lp" ]]; then + conda install 'libblas=*=*mkl' + elif [[ $BLA_VENDOR == "Apple" ]]; then + export LD_LIBRARY_PATH="/opt/MacOSX10.9.sdk/usr/lib" + else + echo "Unsupported BLA_VENDOR for conda builds: $BLA_VENDOR" + exit 3 + fi + elif [[ $TEST_PKG == dist ]]; then pip install scikit-build pytest-cov matplotlib scipy; CMAKE_GENERATOR="Unix Makefiles" python setup.py install; diff --git a/conda-recipe-apple/conda_build_config.yaml b/conda-recipe-apple/conda_build_config.yaml deleted file mode 100644 index 34222a64..00000000 --- a/conda-recipe-apple/conda_build_config.yaml +++ /dev/null @@ -1,2 +0,0 @@ -CONDA_BUILD_SYSROOT: - - /opt/MacOSX10.9.sdk diff --git a/conda-recipe-apple/meta.yaml b/conda-recipe-apple/meta.yaml deleted file mode 100644 index 0e44b35e..00000000 --- a/conda-recipe-apple/meta.yaml +++ /dev/null @@ -1,46 +0,0 @@ -package: - name: slycot - version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} - -source: - git_url: ../ - -build: - number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_apple_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - -requirements: - build: - - {{ compiler('c') }} - - {{ compiler('fortran') }} # [unix] - - flang # [win] - - cmake - - host: - - numpy - - python - - python - # conda-forge::scikit-build>=0.10.0 includes MACOSX_DEPLOYMENT_TARGET - # patches from https://github.com/scikit-build/scikit-build/pull/441 - - scikit-build >=0.10.0 - - run: - - python - - {{ pin_compatible('numpy') }} - -test: - requires: - - pytest - - scipy - imports: - - slycot - commands: - - pytest --pyargs slycot - -about: - home: https://github.com/python-control/Slycot - dev_url: https://github.com/python-control/Slycot - license: GPL-2.0 - license_family: GPL - license_file: COPYING - summary: 'Slycot: A wrapper for the SLICOT control and systems library' diff --git a/conda-recipe-mkl/build.sh b/conda-recipe-mkl/build.sh deleted file mode 100644 index 2e670f98..00000000 --- a/conda-recipe-mkl/build.sh +++ /dev/null @@ -1,10 +0,0 @@ -cd $RECIPE_DIR/.. - -# ensure we are not building with old cmake files -rm -rf _skbuild -rm -rf _cmake_test_compile - -# do the build -$PYTHON setup.py build_ext -lmkl install -- \ - -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ - -DBLA_VENDOR=Intel10_64lp diff --git a/conda-recipe-mkl/meta.yaml b/conda-recipe-mkl/meta.yaml deleted file mode 100644 index ef778be3..00000000 --- a/conda-recipe-mkl/meta.yaml +++ /dev/null @@ -1,46 +0,0 @@ -package: - name: slycot - version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} - -source: - git_url: ../ - -build: - number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_mkl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - -requirements: - build: - - {{ compiler('c') }} - - {{ compiler('fortran') }} # [unix] - - flang # [win] - - cmake - - numpy - - host: - - numpy - - mkl - - python - - scikit-build - - run: - - python {{ PY_VER }} - - {{ pin_compatible('numpy') }} - - mkl - -test: - requires: - - pytest - - scipy - imports: - - slycot - commands: - - pytest --pyargs slycot - -about: - home: https://github.com/python-control/Slycot - dev_url: https://github.com/python-control/Slycot - license: GPL-2.0 - license_family: GPL - license_file: COPYING - summary: 'Slycot: A wrapper for the SLICOT control and systems library' diff --git a/conda-recipe-openblas/build.sh b/conda-recipe-openblas/build.sh deleted file mode 100644 index 9896e862..00000000 --- a/conda-recipe-openblas/build.sh +++ /dev/null @@ -1,11 +0,0 @@ -cd $RECIPE_DIR/.. - -# ensure we are not building with old cmake files -rm -rf _skbuild -rm -rf _cmake_test_compile - -# do the build -$PYTHON setup.py build_ext install -- \ - -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ - -DBLA_VENDOR=OpenBLAS - diff --git a/conda-recipe-openblas/meta.yaml b/conda-recipe-openblas/meta.yaml deleted file mode 100644 index d3093411..00000000 --- a/conda-recipe-openblas/meta.yaml +++ /dev/null @@ -1,46 +0,0 @@ -package: - name: slycot - version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} - -source: - git_url: ../ - -build: - number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - string: py{{ environ.get('PY_VER').replace('.', '') }}{{ environ.get('GIT_DESCRIBE_HASH', '') }}_obl_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} - -requirements: - build: - - {{ compiler('c') }} - - {{ compiler('fortran') }} # [unix] - - flang # [win] - - cmake - - host: - - numpy - - libopenblas - - openblas - - python - - scikit-build - - run: - - python {{ PY_VER }} - - {{ pin_compatible('numpy') }} - - libopenblas - -test: - requires: - - pytest - - scipy - imports: - - slycot - commands: - - pytest --pyargs slycot - -about: - home: https://github.com/python-control/Slycot - dev_url: https://github.com/python-control/Slycot - license: GPL-2.0 - license_family: GPL - license_file: COPYING - summary: 'Slycot: A wrapper for the SLICOT control and systems library' diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat new file mode 100644 index 00000000..6f2397c6 --- /dev/null +++ b/conda-recipe/bld.bat @@ -0,0 +1,6 @@ +set BLAS_ROOT=%PREFIX% +set LAPACK_ROOT=%PREFIX% + +"%PYTHON%" setup.py install -G "NMake Makefiles" -DBLA_VENDOR=Generic + +if errorlevel 1 exit 1 diff --git a/conda-recipe-apple/build.sh b/conda-recipe/build.sh similarity index 57% rename from conda-recipe-apple/build.sh rename to conda-recipe/build.sh index c3b0fe61..1e72fa01 100644 --- a/conda-recipe-apple/build.sh +++ b/conda-recipe/build.sh @@ -1,5 +1,3 @@ -cd $RECIPE_DIR/.. - # ensure we are not building with old cmake files rm -rf _skbuild rm -rf _cmake_test_compile @@ -8,9 +6,9 @@ export LDFLAGS="$LDFLAGS -v" if [[ "$target_platform" == osx-64 ]]; then export LDFLAGS="${LDFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" export CFLAGS="${CFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" + export CMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} fi -$PYTHON setup.py build_ext install -- \ - -DNumPy_INCLUDE_DIR=${SP_DIR}/numpy/core/include \ - -DCMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} \ - -DBLA_VENDOR=Apple +# Always build against netlib implementation +# https://conda-forge.org/docs/maintainer/knowledge_base.html#blas +$PYTHON setup.py build_ext install -DBLA_VENDOR=Generic diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml new file mode 100644 index 00000000..832dffed --- /dev/null +++ b/conda-recipe/meta.yaml @@ -0,0 +1,55 @@ +package: + name: slycot + version: {{ environ.get('GIT_DESCRIBE_TAG', 'v0.0.0')[1:] }} + +source: + git_url: ../ + +build: + number: {{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + string: py{{ environ.get('PY_VER').replace('.', '') }}_{{ environ.get('GIT_DESCRIBE_HASH', '') }}_{{ environ.get('GIT_DESCRIBE_NUMBER', 0) }} + +requirements: + build: + - {{ compiler('fortran') }} # [not win] + - {{ compiler('c') }} + - cmake + - flang # [win] + + host: + # Always build against NETLIB ('Generic') LAPACK/Blas + # https://conda-forge.org/docs/maintainer/knowledge_base.html#blas + # deviating from above link: we have to specifiy netlib variant, because + # the mkl variant selected by default for older pythons on windows + # does not provide the generic headers + - libblas * *netlib + - libcblas * *netlib + - liblapack * *netlib + - python + - numpy + - scikit-build >=0.10.0 + + run: + - python {{ PY_VER }} + - {{ pin_compatible('numpy') }} + - libflang # [win] + +test: + requires: + - pytest + - scipy + imports: + - slycot + commands: + - pytest --pyargs slycot + +about: + home: https://github.com/python-control/Slycot + dev_url: https://github.com/python-control/Slycot + license: GPL-2.0-only + license_family: GPL + license_file: COPYING + summary: 'Slycot: a wrapper for the SLICOT control and systems library' + description: | + Slycot wraps the SLICOT library which is used for control and systems + analysis. From f5c5db4df9714acc83e8c7ad093720f3d54caecd Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 13 Jan 2021 23:38:14 +0100 Subject: [PATCH 241/405] Update REAMDE.rst for conda single recipe and general compiling instructions --- README.rst | 126 +++++++++++++++++++++++++++++------------------------ 1 file changed, 70 insertions(+), 56 deletions(-) diff --git a/README.rst b/README.rst index 769fdea3..909f20b6 100644 --- a/README.rst +++ b/README.rst @@ -34,18 +34,18 @@ following dependencies: - NumPy - scikit-build >= 0.10.0 - CMake -- C compiler (e.g. gcc, MS Visual C++) +- C compiler (e.g. gcc, MS Visual C++, clang) - FORTRAN compiler (e.g. gfortran, ifort, flang) - BLAS/LAPACK (e.g. OpenBLAS, ATLAS, MKL) -To run the Slycot unit tests and examples, you'll also need scipy and +To run the Slycot unit tests and examples, you'll also need SciPy and pytest. There are a variety of ways to install these dependencies on different operating systems. See the individual packages' documentation for options. Installing ------------ +---------- The easiest way to get started with Slycot is to install pre-compiled binaries from conda-forge (see below); these are available for Linux, @@ -62,10 +62,23 @@ from the conda-forge channel with the following command:: conda install -c conda-forge slycot +Compiling from source +--------------------- + +The hardest part about installing from source is getting a working +version of FORTRAN and LAPACK (provided by OpenBLAS, MKL, etc.) +installed on your system. Depending on where you get your NumPy and SciPy +from, you will need to use a compatible LAPACK implementation. Make sure that +the correct header files are installed, and specify the environment variable +`BLA_VENDOR`_, if necessary. + +.. _BLA_VENDOR: https://cmake.org/cmake/help/latest/module/FindBLAS.html#input-variables + + From source without conda (Linux, macOS, Windows) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unpack the source code to a directory of your choice, +Unpack the source code (or clone the git repository) to a directory of your choice, e.g. ``/path/to/slycot_src/`` If you need to specify a specific compiler, set the environment variable FC @@ -82,23 +95,33 @@ To build and install, execute:: cd /path/to/slycot_src/ python setup.py install -From source using a conda recipe (Linux and macOS) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From source using the conda recipe +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You can also use conda to build and install Slycot from source, but -you'll have to choose the right recipe directory. +You can use conda to compile and install Slycot from source. The recipe is +located in the folder ``conda-recipe`` and is intended to work for all +platforms. -On Linux you can choose between ``conda-recipe-openblas`` and -``conda-recipe-mkl`` +The ``conda-forge`` channel provides almost all requirements to compile +Slycot with `conda-build`_, except: -On macOS you should use ``conda-recipe-apple``. See the -`conda-build documentation`_ how to get the required macOS SDK. +- On macOS, you need the macOS SDK. See the + `conda-build documentation for macOS`_ how to get it. +- On Windows, you need to install `Microsoft Visual C++ 14.x`_ provided e.g. + by `Microsoft Visual Studio`_. To build, you'll need a command shell setup + for both conda and the Visual Studio build tools. See `conda activation`_ + and `Microsoft Visual Studio setup`_ for information on this. -.. _conda-build documentation: https://docs.conda.io/projects/conda-build/en/latest/resources/compiler-tools.html#macos-sdk +.. _conda-build: https://docs.conda.io/projects/conda-build/en/latest/resources/commands/conda-build.html +.. _conda-build documentation for macOS: https://docs.conda.io/projects/conda-build/en/latest/resources/compiler-tools.html#macos-sdk +.. _Microsoft Visual C++ 14.x: https://wiki.python.org/moin/WindowsCompilers +.. _Microsoft Visual Studio: https://visualstudio.microsoft.com/de/vs/ +.. _conda activation: https://docs.conda.io/projects/conda/en/latest/user-guide/troubleshooting.html#windows-environment-has-not-been-activated +.. _Microsoft Visual Studio setup: https://docs.microsoft.com/en-us/cpp/build/setting-the-path-and-environment-variables-for-command-line-builds -For example, to build with the OpenBLAS recipe:: +To build and install:: - conda build -c conda-forge conda-recipe-openblas + conda build -c conda-forge conda-recipe conda install -c conda-forge --use-local slycot From source in a conda environment (Windows) @@ -110,28 +133,46 @@ dependencies, *except* for the C compiler. This procedure has been tested on Python 3.7 and 3.8. -First, install the `correct Visual Studio compiler for the Python -version`_ you wish to build for. +1. Install `Microsoft Visual Studio`_. +2. Unpack the source code to a directory of your choice, +3. Create a command shell setup that can run the conda commands and the Visual + Studio build tools (see above) +4. In such a command shell, within the Slycot source code directory, run the + following commands to build and install Slycot (this example creates a + Python 3.8 environment):: -.. _correct Visual Studio compiler for the Python version: https://wiki.python.org/moin/WindowsCompilers + conda create --channel conda-forge --name build-slycot python=3.8 numpy scipy libblas=*=*netlib liblapack=*=*netlib scikit-build flang pytest + conda activate build-slycot -To build, you'll need a command shell setup for both conda and the -Visual Studio build tools. See `conda activation`_ and `Microsoft -Visual Studio setup`_ for information on this. + python setup.py install -.. _conda activation: https://docs.conda.io/projects/conda/en/latest/user-guide/troubleshooting.html#windows-environment-has-not-been-activated -.. _Microsoft Visual Studio setup: https://docs.microsoft.com/en-us/cpp/build/setting-the-path-and-environment-variables-for-command-line-builds?view=vs-2019 +Using pip +~~~~~~~~~ -In such a command shell, run the following commands to build and -install Slycot (this example creates a Python 3.8 environment):: +We publish Slycot to the Python package index, but only as a source +package, so to install using pip you'll first need to install the +build prerequisites (compilers, libraries, etc.) - conda create --channel conda-forge --name build-slycot python=3.8 numpy scipy libblas=*=*netlib liblapack=*=*netlib scikit-build flang pytest - conda activate build-slycot +If you have these build prerequisites, the command:: - python setup.py install + pip install slycot + +will download the latest release of the source code from `PyPI`_, compile, and +install Slycot into the currently configured location (virtual environment or +user site-packages). + +.. _PyPI: https://pypi.org/project/slycot + +Additional hints +~~~~~~~~~~~~~~~~ + +Additional hints for how to install Slycot from source can be found in the +``.travis.yml`` (commands used for Travis CI) and the ``conda-recipe`` +directory (conda pre-requisites, install and test commands) both which are +included in the source code repository. Testing -~~~~~~~ +------- To test if the installation was successful, you can run the slycot unit tests:: pytest --pyargs slycot @@ -146,30 +187,3 @@ Importing ``slycot`` or running ``pytest`` without ``--pyargs slycot`` from inside the source directory will fail, unless the compiled wrapper library has been installed into that directory. Note that the ``[tool:pytest]`` section in ``setup.cfg`` enforces the ``--pyargs slycot`` argument by default. - -General notes on compiling -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Additional tips for how to install Slycot from source can be found in the -``.travis.yml`` (commands used for Travis CI) and the ``conda-recipe-*/`` -directories (conda pre-requisites) both which are included in the source -code repository. - -The hardest part about installing from source is getting a working -version of FORTRAN and LAPACK (provided by OpenBLAS, MKL, etc.) -installed on your system, and working properly with Python. - -Note that in some cases you may need to set the ``LIBRARY_PATH`` environment -variable to pick up dependencies such as ``-lpythonN.m`` (where N.m is the -version of python you are using). - -Using pip -~~~~~~~~~ - -We publish Slycot to the Python package index, but only as a source -package, so to install using pip you'll first need to install the -build prerequisites (compilers, libraries, etc.) - -If you have these build prerequisites, install in the standard way with: - - pip install slycot From 2e22674df3149d3f22a3d88ad6eae65a597fb2b3 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 14 Jan 2021 00:49:43 +0100 Subject: [PATCH 242/405] update MANIFEST --- MANIFEST.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/MANIFEST.in b/MANIFEST.in index cc943fea..d677f984 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -3,10 +3,10 @@ include COPYING include AUTHORS include gpl-2.0.txt include README.rst -include MANIFEST.in -include setup.cfg.in include CMakeLists.txt include pyproject.toml +include .travis.yml +include conda-recipe/* include slycot/CMakeLists.txt include slycot/tests/CMakeLists.txt include slycot/*.py From 4893608d53090b18860d2cd9501677840f0a57bb Mon Sep 17 00:00:00 2001 From: bnavigator Date: Wed, 6 Jan 2021 03:11:32 +0100 Subject: [PATCH 243/405] Github actions workflow with split jobs --- .github/conda-env/test-env.yml | 9 + .github/scripts/run-tests.sh | 34 ++ .github/scripts/set-conda-test-matrix.py | 33 ++ .github/scripts/set-pip-test-matrix.py | 28 ++ .github/workflows/slycot-build-and-test.yml | 348 ++++++++++++++++++++ README.rst | 3 + 6 files changed, 455 insertions(+) create mode 100644 .github/conda-env/test-env.yml create mode 100644 .github/scripts/run-tests.sh create mode 100644 .github/scripts/set-conda-test-matrix.py create mode 100644 .github/scripts/set-pip-test-matrix.py create mode 100644 .github/workflows/slycot-build-and-test.yml diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml new file mode 100644 index 00000000..ffcf4896 --- /dev/null +++ b/.github/conda-env/test-env.yml @@ -0,0 +1,9 @@ +name: test-env +dependencies: + # in addtion to package dependencies and explicit LAPACK/BLAS implementations installed in workflow + - conda-build # for conda index + - scipy + - matplotlib + - pytest-cov + - coverage + - coveralls diff --git a/.github/scripts/run-tests.sh b/.github/scripts/run-tests.sh new file mode 100644 index 00000000..0c12237e --- /dev/null +++ b/.github/scripts/run-tests.sh @@ -0,0 +1,34 @@ +#!/bin/bash + +set -e + +echo "::group::Slycot unit tests" +pytest -v --pyargs slycot \ + --cov=${slycot_libdir:=$(python -c "import slycot; print(slycot.__path__[0])")} \ + --cov-config=${slycot_srcdir:=$(realpath ./slycot-src)}/.coveragerc +mv .coverage ${slycot_srcdir}/.coverage.slycot +echo "::endgroup::" + +echo "::group::python-control unit tests" +pushd ${python_control_srcdir:=./python-control} +# test_root_locus_zoom, test_sisotool: problems with the toolbar for MPL backends, not relevant to Slycot +pytest control/tests \ + --cov=$slycot_libdir \ + --cov-config=${slycot_srcdir}/.coveragerc \ + -k "not (test_root_locus_zoom or test_sisotool)" +mv .coverage ${slycot_srcdir}/.coverage.control +popd +echo "::endgroup::" + +echo "::group::run slycot.test() inside interpreter" +echo 'import slycot; slycot.test()' > runtest.py +coverage run --source ${slycot_libdir} --rcfile ${slycot_srcdir}/.coveragerc runtest.py +mv .coverage ${slycot_srcdir}/.coverage.slycot-inline + +echo "::group::Combine coverage" +# needs to run from within slycot source dir +cd ${slycot_srcdir} +echo " ${slycot_libdir}" >> .coveragerc +coverage combine +coverage report +echo "::endgroup::" diff --git a/.github/scripts/set-conda-test-matrix.py b/.github/scripts/set-conda-test-matrix.py new file mode 100644 index 00000000..fcdb2134 --- /dev/null +++ b/.github/scripts/set-conda-test-matrix.py @@ -0,0 +1,33 @@ +""" set-conda-test-matrix.py + +Create test matrix for conda packages +""" +import json, re +from pathlib import Path + +osmap = {'linux': 'ubuntu', + 'osx': 'macos', + 'win': 'windows', + } + +conda_jobs = [] +for conda_pkg_file in Path("slycot-conda-pkgs").glob("*/*.tar.bz2"): + cos = osmap[conda_pkg_file.parent.name.split("-")[0]] + m = re.search(r'py(\d)(\d+)_', conda_pkg_file.name) + pymajor, pyminor = int(m[1]), int(m[2]) + cpy = f'{pymajor}.{pyminor}' + for cbl in ['unset', 'Generic', 'OpenBLAS', 'Intel10_64lp']: + cjob = {'packagekey': f'{cos}-{cpy}', + 'os': cos, + 'python': cpy, + 'blas_lib': cbl} + if (cos == 'windows' and + pyminor < 8 and + cbl not in ['unset', 'Intel10_64lp']): + # fatal windows error because numpy and matplotlib directly + # link to mkl on older versions + cjob['failok'] = "FAILOK" + conda_jobs.append(cjob) + +matrix = { 'include': conda_jobs } +print(json.dumps(matrix)) \ No newline at end of file diff --git a/.github/scripts/set-pip-test-matrix.py b/.github/scripts/set-pip-test-matrix.py new file mode 100644 index 00000000..ed18239d --- /dev/null +++ b/.github/scripts/set-pip-test-matrix.py @@ -0,0 +1,28 @@ +""" set-pip-test-matrix.py + +Create test matrix for pip wheels +""" +import json +from pathlib import Path + +system_opt_blas_libs = {'ubuntu': ['OpenBLAS'], + 'macos' : ['OpenBLAS', 'Apple']} + +wheel_jobs = [] +for wkey in Path("slycot-wheels").iterdir(): + wos, wpy, wbl = wkey.name.split("-") + wheel_jobs.append({'packagekey': wkey.name, + 'os': wos, + 'python': wpy, + 'blas_lib': wbl, + }) + if wbl == "Generic": + for bl in system_opt_blas_libs[wos]: + wheel_jobs.append({ 'packagekey': wkey.name, + 'os': wos, + 'python': wpy, + 'blas_lib': bl, + }) + +matrix = { 'include': wheel_jobs } +print(json.dumps(matrix)) \ No newline at end of file diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml new file mode 100644 index 00000000..07b1a486 --- /dev/null +++ b/.github/workflows/slycot-build-and-test.yml @@ -0,0 +1,348 @@ +name: Build and Test Slycot +on: + push: + pull_request: + paths-ignore: + - '.gitignore' + - 'AUTHORS' + - 'COPYING' + - 'gpl-2.0.txt' + - 'MANIFEST.in' + - 'README.rst' + +jobs: + + build-pip: + name: Build pip Py${{ matrix.python }}, ${{ matrix.os }}, ${{ matrix.bla_vendor}} BLA_VENDOR + runs-on: ${{ matrix.os }}-latest + strategy: + fail-fast: false + matrix: + os: + - 'ubuntu' + - 'macos' + python: + - '3.6' + - '3.7' + - '3.8' + - '3.9' + bla_vendor: [ 'unset' ] + include: + - os: 'ubuntu' + python: '3.9' + bla_vendor: 'Generic' + - os: 'ubuntu' + python: '3.9' + bla_vendor: 'OpenBLAS' + - os: 'macos' + python: '3.9' + bla_vendor: 'Apple' + - os: 'macos' + python: '3.9' + bla_vendor: 'Generic' + - os: 'macos' + python: '3.9' + bla_vendor: 'OpenBLAS' + + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + with: + fetch-depth: 0 + - name: Set up Python + uses: actions/setup-python@v2 + with: + python-version: ${{ matrix.python }} + - name: Setup Ubuntu + if: matrix.os == 'ubuntu' + run: | + sudo apt-get -y update + sudo apt-get -y install gfortran cmake --fix-missing + case ${{ matrix.bla_vendor }} in + unset | Generic ) sudo apt-get -y install libblas-dev liblapack-dev ;; + OpenBLAS ) sudo apt-get -y install libopenblas-dev ;; + *) + echo "bla_vendor option ${{ matrix.bla_vendor }} not supported" + exit 1 ;; + esac + - name: Setup macOS + if: matrix.os == 'macos' + run: | + case ${{ matrix.bla_vendor }} in + unset | Generic | Apple ) ;; # Found in system + OpenBLAS ) + brew install openblas + echo "BLAS_ROOT=/usr/local/opt/openblas/" >> $GITHUB_ENV + echo "LAPACK_ROOT=/usr/local/opt/openblas/" >> $GITHUB_ENV + ;; + *) + echo "bla_vendor option ${{ matrix.bla_vendor }} not supported" + exit 1 ;; + esac + echo "FC=gfortran-10" >> $GITHUB_ENV + - name: Build wheel + env: + BLA_VENDOR: ${{ matrix.bla_vendor }} + CMAKE_GENERATOR: Unix Makefiles + run: | + if [[ $BLA_VENDOR = unset ]]; then unset BLA_VENDOR; fi + python -m pip install --upgrade pip + pip wheel -v -w . . + wheeldir=slycot-wheels/${{ matrix.os }}-${{ matrix.python }}-${{ matrix.bla_vendor }} + mkdir -p ${wheeldir} + cp ./slycot*.whl ${wheeldir}/ + - name: Save wheel + uses: actions/upload-artifact@v2 + with: + name: slycot-wheels + path: slycot-wheels + + build-conda: + name: Build conda Py${{ matrix.python }}, ${{ matrix.os }} + runs-on: ${{ matrix.os }}-latest + strategy: + fail-fast: false + matrix: + os: + - 'ubuntu' + - 'macos' + - 'windows' + python: + - '3.6' + - '3.9' + + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + with: + fetch-depth: 0 + - name: Setup Conda + uses: conda-incubator/setup-miniconda@v2 + with: + python-version: ${{ matrix.python }} + activate-environment: build-env + channels: conda-forge + channel-priority: strict + auto-update-conda: false + auto-activate-base: false + - name: Conda build + shell: bash -l {0} + run: | + set -e + conda install conda-build numpy + numpyversion=$(python -c 'import numpy; print(numpy.version.version)') + conda-build --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe + # preserve directory structure for custom conda channel + find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do + conda_platform=$(basename $(dirname "${conda_pkg}")) + mkdir -p "slycot-conda-pkgs/${conda_platform}" + cp "${conda_pkg}" "slycot-conda-pkgs/${conda_platform}/" + done + - name: Save to local conda pkg channel + uses: actions/upload-artifact@v2 + with: + name: slycot-conda-pkgs + path: slycot-conda-pkgs + + create-wheel-test-matrix: + name: Create wheel test matrix + runs-on: ubuntu-latest + needs: build-pip + if: always() # run tests for all successful builds, even if others failed + outputs: + matrix: ${{ steps.set-matrix.outputs.matrix }} + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + - name: Download wheels (if any) + uses: actions/download-artifact@v2 + with: + name: slycot-wheels + path: slycot-wheels + - id: set-matrix + run: | + matrix=$(python3 .github/scripts/set-pip-test-matrix.py) + echo "::set-output name=matrix::$matrix" + + create-conda-test-matrix: + name: Create conda test matrix + runs-on: ubuntu-latest + needs: build-conda + if: always() # run tests for all successful builds, even if others failed + outputs: + matrix: ${{ steps.set-matrix.outputs.matrix }} + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + - name: Download conda packages + uses: actions/download-artifact@v2 + with: + name: slycot-conda-pkgs + path: slycot-conda-pkgs + - id: set-matrix + run: | + matrix=$(python3 .github/scripts/set-conda-test-matrix.py) + echo "::set-output name=matrix::$matrix" + + + test-wheel: + name: Test wheel ${{ matrix.packagekey }}, ${{matrix.blas_lib}} BLAS lib ${{ matrix.failok }} + needs: create-wheel-test-matrix + runs-on: ${{ matrix.os }}-latest + continue-on-error: ${{ matrix.failok == 'FAILOK' }} + + strategy: + fail-fast: false + matrix: ${{ fromJSON(needs.create-wheel-test-matrix.outputs.matrix) }} + + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + with: + path: slycot-src + - name: Checkout python-control + uses: actions/checkout@v2 + with: + repository: 'python-control/python-control' + path: python-control + - name: Setup Python + uses: actions/setup-python@v2 + with: + python-version: ${{ matrix.python }} + - name: Setup Ubuntu + if: matrix.os == 'ubuntu' + run: | + set -xe + sudo apt-get -y update + case ${{ matrix.blas_lib }} in + Generic ) sudo apt-get -y install libblas3 liblapack3 ;; + unset | OpenBLAS ) sudo apt-get -y install libopenblas-base ;; + *) + echo "BLAS ${{ matrix.blas_lib }} not supported for wheels on Ubuntu" + exit 1 ;; + esac + update-alternatives --display libblas.so.3-x86_64-linux-gnu + update-alternatives --display liblapack.so.3-x86_64-linux-gnu + - name: Setup macOS + if: matrix.os == 'macos' + run: | + set -xe + brew install coreutils + case ${{ matrix.blas_lib }} in + unset | Generic | Apple ) ;; # system provided (Uses Apple Accelerate Framework) + OpenBLAS ) + brew install openblas + echo "DYLIB_LIBRARY_PATH=/usr/local/opt/openblas/lib" >> $GITHUB_ENV + ;; + *) + echo "BLAS option ${{ matrix.blas_lib }} not supported for wheels on MacOS" + exit 1 ;; + esac + - name: Download wheels + uses: actions/download-artifact@v2 + with: + name: slycot-wheels + path: slycot-wheels + - name: Install Wheel + run: | + python -m pip install --upgrade pip + pip install matplotlib scipy pytest pytest-cov coverage coveralls + pip install slycot-wheels/${{ matrix.packagekey }}/slycot*.whl + pip show slycot + - name: Slycot and python-control tests + run: bash slycot-src/.github/scripts/run-tests.sh + - name: report coverage + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + COVERALLS_FLAG_NAME: wheel-${{ matrix.packagekey }}-${{matrix.blas_lib}} + COVERALLS_PARALLEL: true + working-directory: slycot-src + run: coveralls + + test-conda: + name: Test conda ${{ matrix.packagekey }}, ${{matrix.blas_lib}} BLAS lib ${{ matrix.failok }} + needs: create-conda-test-matrix + runs-on: ${{ matrix.os }}-latest + continue-on-error: ${{ matrix.failok == 'FAILOK' }} + + strategy: + fail-fast: false + matrix: ${{ fromJSON(needs.create-conda-test-matrix.outputs.matrix) }} + + defaults: + run: + shell: bash -l {0} + + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + with: + path: slycot-src + - name: Checkout python-control + uses: actions/checkout@v2 + with: + repository: 'python-control/python-control' + path: python-control + - name: Setup macOS + if: matrix.os == 'macos' + run: brew install coreutils + - name: Setup Conda + uses: conda-incubator/setup-miniconda@v2 + with: + python-version: ${{ matrix.python }} + activate-environment: test-env + environment-file: slycot-src/.github/conda-env/test-env.yml + channels: conda-forge + channel-priority: strict + auto-activate-base: false + - name: Download conda packages + uses: actions/download-artifact@v2 + with: + name: slycot-conda-pkgs + path: slycot-conda-pkgs + - name: Install Conda package + run: | + set -e + case ${{ matrix.blas_lib }} in + unset ) # the conda-forge default (os dependent) + conda install libblas libcblas liblapack + ;; + Generic ) + conda install 'libblas=*=*netlib' 'libcblas=*=*netlib' 'liblapack=*=*netlib' + echo "libblas * *netlib" >> $CONDA_PREFIX/conda-meta/pinned + ;; + OpenBLAS ) + conda install 'libblas=*=*openblas' openblas + echo "libblas * *openblas" >> $CONDA_PREFIX/conda-meta/pinned + ;; + Intel10_64lp ) + conda install 'libblas=*=*mkl' mkl + echo "libblas * *mkl" >> $CONDA_PREFIX/conda-meta/pinned + ;; + esac + conda index --no-progress ./slycot-conda-pkgs + conda install -c ./slycot-conda-pkgs slycot + conda list + - name: Slycot and python-control tests + run: bash slycot-src/.github/scripts/run-tests.sh + - name: Report coverage + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + COVERALLS_FLAG_NAME: conda-${{ matrix.packagekey }}-${{matrix.blas_lib}} + COVERALLS_PARALLEL: true + working-directory: slycot-src + run: coveralls + + coveralls-final: + name: Finalize parallel coveralls + if: always() + needs: + - test-conda + - test-wheel + runs-on: ubuntu-latest + steps: + - name: Coveralls Finished + uses: coverallsapp/github-action@master + with: + github-token: ${{ secrets.GITHUB_TOKEN }} + parallel-finished: true diff --git a/README.rst b/README.rst index 909f20b6..ca6d6449 100644 --- a/README.rst +++ b/README.rst @@ -10,6 +10,9 @@ Slycot .. image:: https://travis-ci.org/python-control/Slycot.svg?branch=master :target: https://travis-ci.org/python-control/Slycot +.. image:: https://github.com/python-control/Slycot/workflows/Build%20and%20Test%20Slycot/badge.svg + :target: https://github.com/python-control/Slycot/actions + .. image:: https://coveralls.io/repos/github/python-control/Slycot/badge.svg?branch=master :target: https://coveralls.io/github/python-control/Slycot?branch=master From d1c056a1a5353626aadcd4738cc6a72245201bc4 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 14 Jan 2021 00:53:01 +0100 Subject: [PATCH 244/405] Update README.rst and MANIFEST.in --- MANIFEST.in | 1 - README.rst | 10 +++++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/MANIFEST.in b/MANIFEST.in index d677f984..105f8d8b 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -5,7 +5,6 @@ include gpl-2.0.txt include README.rst include CMakeLists.txt include pyproject.toml -include .travis.yml include conda-recipe/* include slycot/CMakeLists.txt include slycot/tests/CMakeLists.txt diff --git a/README.rst b/README.rst index ca6d6449..6a1e8f09 100644 --- a/README.rst +++ b/README.rst @@ -170,9 +170,13 @@ Additional hints ~~~~~~~~~~~~~~~~ Additional hints for how to install Slycot from source can be found in the -``.travis.yml`` (commands used for Travis CI) and the ``conda-recipe`` -directory (conda pre-requisites, install and test commands) both which are -included in the source code repository. +`.github`_ directory , (commands used to build and test in the GitHub Actions +CI), the `logs from the GitHub Actions`_, and the ``conda-recipe`` directory +(conda pre-requisites, install and test commands) which is included +in the source code repository. + +.. _.github: https://github.com/python-control/Slycot/tree/master/.github +.. _`logs from the GitHub Actions`: https://github.com/python-control/Slycot/actions Testing ------- From 2a6a98fa9533ab2ec088db7a342538b22c67594f Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 14 Jan 2021 01:04:32 +0100 Subject: [PATCH 245/405] add fast sniff build --- .github/workflows/slycot-build-and-test.yml | 23 +++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 07b1a486..e72a48e4 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -12,9 +12,31 @@ on: jobs: + build-setup: + # Super fast sniff build. If this fails, don't start the other jobs + name: Build setup.py on Ubuntu + runs-on: ubuntu-latest + steps: + - name: Checkout Slycot + uses: actions/checkout@v2 + with: + fetch-depth: 0 + - name: Set up Python + uses: actions/setup-python@v2 + - name: Setup Ubuntu + run: | + sudo apt-get -y install gfortran cmake --fix-missing + sudo apt-get -y install libblas-dev liblapack-dev + pip install scikit-build numpy scipy pytest + - name: Install Slycot + run: python setup.py install + - name: Run tests + run: pytest + build-pip: name: Build pip Py${{ matrix.python }}, ${{ matrix.os }}, ${{ matrix.bla_vendor}} BLA_VENDOR runs-on: ${{ matrix.os }}-latest + needs: build-setup strategy: fail-fast: false matrix: @@ -100,6 +122,7 @@ jobs: build-conda: name: Build conda Py${{ matrix.python }}, ${{ matrix.os }} runs-on: ${{ matrix.os }}-latest + needs: build-setup strategy: fail-fast: false matrix: From c58c564b1b33eda6a6986f87a1584793566f3352 Mon Sep 17 00:00:00 2001 From: bnavigator Date: Thu, 14 Jan 2021 01:30:50 +0100 Subject: [PATCH 246/405] fix coveralls endpoint service --- .github/workflows/slycot-build-and-test.yml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index e72a48e4..ab9f907b 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -280,7 +280,8 @@ jobs: COVERALLS_FLAG_NAME: wheel-${{ matrix.packagekey }}-${{matrix.blas_lib}} COVERALLS_PARALLEL: true working-directory: slycot-src - run: coveralls + # https://github.com/TheKevJames/coveralls-python/issues/252 + run: coveralls --service=github test-conda: name: Test conda ${{ matrix.packagekey }}, ${{matrix.blas_lib}} BLAS lib ${{ matrix.failok }} @@ -354,7 +355,8 @@ jobs: COVERALLS_FLAG_NAME: conda-${{ matrix.packagekey }}-${{matrix.blas_lib}} COVERALLS_PARALLEL: true working-directory: slycot-src - run: coveralls + # https://github.com/TheKevJames/coveralls-python/issues/252 + run: coveralls --service=github coveralls-final: name: Finalize parallel coveralls From a4dd916471f7f0a956cb5fd8b592a5a76af02a01 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 30 Jan 2021 13:26:20 +0100 Subject: [PATCH 247/405] failok for all windows versions unless BLAS is unset or mkl --- .github/scripts/set-conda-test-matrix.py | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/.github/scripts/set-conda-test-matrix.py b/.github/scripts/set-conda-test-matrix.py index fcdb2134..f1d91c24 100644 --- a/.github/scripts/set-conda-test-matrix.py +++ b/.github/scripts/set-conda-test-matrix.py @@ -21,11 +21,9 @@ 'os': cos, 'python': cpy, 'blas_lib': cbl} - if (cos == 'windows' and - pyminor < 8 and - cbl not in ['unset', 'Intel10_64lp']): - # fatal windows error because numpy and matplotlib directly - # link to mkl on older versions + if (cos == 'windows' and cbl not in ['unset', 'Intel10_64lp']): + # sporadic fatal windows errors because numpy and matplotlib + # directly link to mkl on older versions cjob['failok'] = "FAILOK" conda_jobs.append(cjob) From 382f92fb7d8d4af5560cc884644c635b40b7d9a4 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 3 Feb 2021 12:32:44 +0100 Subject: [PATCH 248/405] Conda test only unset and mkl on windows --- .github/scripts/set-conda-test-matrix.py | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/.github/scripts/set-conda-test-matrix.py b/.github/scripts/set-conda-test-matrix.py index f1d91c24..954480cb 100644 --- a/.github/scripts/set-conda-test-matrix.py +++ b/.github/scripts/set-conda-test-matrix.py @@ -10,22 +10,25 @@ 'win': 'windows', } +blas_implementations = ['unset', 'Generic', 'OpenBLAS', 'Intel10_64lp'] + +combinations = {'ubuntu': blas_implementations, + 'macos': blas_implementations, + 'windows': ['unset', 'Intel10_64lp'], + } + conda_jobs = [] for conda_pkg_file in Path("slycot-conda-pkgs").glob("*/*.tar.bz2"): cos = osmap[conda_pkg_file.parent.name.split("-")[0]] m = re.search(r'py(\d)(\d+)_', conda_pkg_file.name) pymajor, pyminor = int(m[1]), int(m[2]) cpy = f'{pymajor}.{pyminor}' - for cbl in ['unset', 'Generic', 'OpenBLAS', 'Intel10_64lp']: + for cbl in combinations[cos]: cjob = {'packagekey': f'{cos}-{cpy}', 'os': cos, 'python': cpy, 'blas_lib': cbl} - if (cos == 'windows' and cbl not in ['unset', 'Intel10_64lp']): - # sporadic fatal windows errors because numpy and matplotlib - # directly link to mkl on older versions - cjob['failok'] = "FAILOK" conda_jobs.append(cjob) matrix = { 'include': conda_jobs } -print(json.dumps(matrix)) \ No newline at end of file +print(json.dumps(matrix)) From 6a7e28f7e22fc24ca15744e711d1af1ba9e7a126 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 3 Feb 2021 15:46:04 +0100 Subject: [PATCH 249/405] don't report travis coverage results to coveralls --- .travis.yml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 5e7ef02c..1a5b3007 100644 --- a/.travis.yml +++ b/.travis.yml @@ -119,8 +119,6 @@ install: echo "Wrong TEST_PKG '$TEST_PKG'" exit 1 fi - # coveralls not in ubuntu or conda repos - pip install coveralls script: # slycots own unit tests as installed, not those from source dir @@ -135,13 +133,12 @@ script: - cd python-control - pytest --disable-warnings --cov=$slycot_dir --cov-config=../Slycot/.coveragerc control/tests - after_success: - # go back to Slycot dir and merge the coverage to report correct repo data with coveralls + # go back to Slycot dir and merge the coverage for a total tally - cd ../Slycot - cp ../slycot-coverage/.coverage .coverage.slycot - cp ../python-control/.coverage .coverage.control - echo " $slycot_dir" >> .coveragerc - coverage combine - coverage report - - coveralls + # reporting to coveralls only happens from the github actions runs From 5c8410bd2fdb5017dc42cd0e7d4eeb1157032cb8 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 13:14:11 +0100 Subject: [PATCH 250/405] install conda-verify --- .github/workflows/slycot-build-and-test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index ab9f907b..02865455 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -152,7 +152,7 @@ jobs: shell: bash -l {0} run: | set -e - conda install conda-build numpy + conda install conda-build conda-verify numpy numpyversion=$(python -c 'import numpy; print(numpy.version.version)') conda-build --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe # preserve directory structure for custom conda channel From 76dcedc990587047b0ce111a3c099ec6cd4e40b5 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 14:31:55 +0100 Subject: [PATCH 251/405] bye bye travis-ci.org --- .travis.yml | 144 ---------------------------------------------------- README.rst | 3 -- setup.py | 2 +- 3 files changed, 1 insertion(+), 148 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 1a5b3007..00000000 --- a/.travis.yml +++ /dev/null @@ -1,144 +0,0 @@ -# Default entries for matrix jobs -os: linux -language: python -dist: bionic -services: xvfb # needed for the python-control tests - -# Start with a 2x4 matrix of Linux builds -python: - - "3.9" - - "3.8" - - "3.7" -env: - - TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - TEST_PKG="conda" BLA_VENDOR="Intel10_64lp" # MKL - - TEST_PKG="dist" BLA_VENDOR="OpenBLAS" - - TEST_PKG="dist" BLA_VENDOR="Generic" # force reference BLAS/LAPACK - -jobs: - # additional single Linux and OSX jobs - include: - - name: "Linux, Conda Python 3.6" - python: "3.6" - env: TEST_PKG="conda" BLA_VENDOR="OpenBLAS" - - name: "MacOSX, Conda Python 3" - os: osx - language: shell - env: TEST_PKG="conda" BLA_VENDOR="Apple" - - name: "MacOSX, System Python 3" - os: osx - language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" - - name: "MacOSX, pyenv 3.8.0" - os: osx - language: shell - env: TEST_PKG="dist" BLA_VENDOR="Apple" SLYCOT_PYTHON_VERSION=3.8.0 - -before_install: - - | - # Install Ubuntu packages - if [[ $TEST_PKG == "dist" && $TRAVIS_OS_NAME == linux ]]; then - sudo apt-get update - sudo apt-get -y install gfortran cmake - if [[ $BLA_VENDOR == "OpenBLAS" ]]; then - sudo apt-get -y install libopenblas-dev - elif [[ $BLA_VENDOR == "Generic" ]]; then - sudo apt-get -y install libblas-dev liblapack-dev - else - echo "Unsupported BLAS Vendor: '$BLA_VENDOR'" - exit 2 - fi - fi - - | - # Install MacOSX packages - if [[ $TEST_PKG == "dist" && $TRAVIS_OS_NAME == osx ]]; then - if [ -n "$SLYCOT_PYTHON_VERSION" ]; then - pyenv install $SLYCOT_PYTHON_VERSION - pyenv global $SLYCOT_PYTHON_VERSION - eval "$(pyenv init -)" - export MPLBACKEND="TkAgg" - else - mkdir -p ~/.local/bin - ln -s $(which python3) ~/.local/bin/python - ln -s $(which pip3) ~/.local/bin/pip - fi - fi - -install: - - | - # compile using conda environment or distribution libraries - echo "Python Version: ${SLYCOT_PYTHON_VERSION:=${TRAVIS_PYTHON_VERSION:-3.8}}" - if [[ $TEST_PKG == conda ]]; then - # - # Install miniconda to allow quicker installation of dependencies - # See https://conda.io/projects/conda/en/latest/user-guide/tasks/use-conda-with-travis-ci.html - # - if [[ $TRAVIS_OS_NAME == linux ]]; then - wget https://repo.continuum.io/miniconda/Miniconda3-latest-Linux-x86_64.sh -O miniconda.sh - elif [[ $TRAVIS_OS_NAME == osx ]]; then - wget https://repo.continuum.io/miniconda/Miniconda3-latest-MacOSX-x86_64.sh -O miniconda.sh - wget https://github.com/phracker/MacOSX-SDKs/releases/download/10.15/MacOSX10.9.sdk.tar.xz - sudo tar -C /opt -xJf MacOSX10.9.sdk.tar.xz - else - echo "Unsupported OS for conda builds: $TRAVIS_OS_NAME" - exit 4 - fi - bash miniconda.sh -b -p $HOME/miniconda - source "$HOME/miniconda/etc/profile.d/conda.sh" - hash -r - conda config --set always_yes yes --set changeps1 no - conda install conda-build - conda install conda-verify - conda config --add channels conda-forge; - conda update -q --all - conda info -a; - conda create -q -n test-environment \ - python="$SLYCOT_PYTHON_VERSION" \ - pip coverage pytest-cov \ - numpy scipy matplotlib - conda activate test-environment - export LIBRARY_PATH="$HOME/miniconda/envs/test-environment/lib" - numpyversion=$(python -c 'import numpy; print(numpy.version.version)') - conda build --python "$SLYCOT_PYTHON_VERSION" --numpy $numpyversion conda-recipe - conda install local::slycot - if [[ $BLA_VENDOR == "OpenBLAS" ]]; then - conda install 'libblas=*=*openblas' - elif [[ $BLA_VENDOR == "Intel10_64lp" ]]; then - conda install 'libblas=*=*mkl' - elif [[ $BLA_VENDOR == "Apple" ]]; then - export LD_LIBRARY_PATH="/opt/MacOSX10.9.sdk/usr/lib" - else - echo "Unsupported BLA_VENDOR for conda builds: $BLA_VENDOR" - exit 3 - fi - - elif [[ $TEST_PKG == dist ]]; then - pip install scikit-build pytest-cov matplotlib scipy; - CMAKE_GENERATOR="Unix Makefiles" python setup.py install; - else - echo "Wrong TEST_PKG '$TEST_PKG'" - exit 1 - fi - -script: - # slycots own unit tests as installed, not those from source dir - - mkdir ../slycot-coverage - - cd ../slycot-coverage - - slycot_dir=$(python -c "import slycot; print(slycot.__path__[0])") - - pytest --pyargs slycot --cov=$slycot_dir --cov-config=../Slycot/.coveragerc - # - # As a deeper set of tests, use the suite from python-control master branch as well - - cd .. - - git clone --depth 1 https://github.com/python-control/python-control.git - - cd python-control - - pytest --disable-warnings --cov=$slycot_dir --cov-config=../Slycot/.coveragerc control/tests - -after_success: - # go back to Slycot dir and merge the coverage for a total tally - - cd ../Slycot - - cp ../slycot-coverage/.coverage .coverage.slycot - - cp ../python-control/.coverage .coverage.control - - echo " $slycot_dir" >> .coveragerc - - coverage combine - - coverage report - # reporting to coveralls only happens from the github actions runs diff --git a/README.rst b/README.rst index 6a1e8f09..8a01cf52 100644 --- a/README.rst +++ b/README.rst @@ -7,9 +7,6 @@ Slycot .. image:: https://anaconda.org/conda-forge/slycot/badges/version.svg :target: https://anaconda.org/conda-forge/slycot -.. image:: https://travis-ci.org/python-control/Slycot.svg?branch=master - :target: https://travis-ci.org/python-control/Slycot - .. image:: https://github.com/python-control/Slycot/workflows/Build%20and%20Test%20Slycot/badge.svg :target: https://github.com/python-control/Slycot/actions diff --git a/setup.py b/setup.py index be412257..9bb03bb8 100644 --- a/setup.py +++ b/setup.py @@ -103,7 +103,7 @@ def _minimal_ext_cmd(cmd, srcdir): out = _minimal_ext_cmd(['git', 'describe', '--tags', '--long', '--always'], srcdir) try: - # don't get a good description with shallow clones, e.g., on Travis + # don't get a good description with shallow clones GIT_CYCLE = out.strip().decode('ascii').split('-')[1] except IndexError: pass From 2e542bdbdeee0ee182d2e5238b51a8fda67007f9 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 14:44:21 +0100 Subject: [PATCH 252/405] python-conntrol needs pytest-timeout for rlocus test --- .github/conda-env/test-env.yml | 2 ++ .github/workflows/slycot-build-and-test.yml | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml index ffcf4896..ac47f1ed 100644 --- a/.github/conda-env/test-env.yml +++ b/.github/conda-env/test-env.yml @@ -4,6 +4,8 @@ dependencies: - conda-build # for conda index - scipy - matplotlib + - pytest - pytest-cov + - pytest-timeout - coverage - coveralls diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index ab9f907b..d4bcc54d 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -269,7 +269,7 @@ jobs: - name: Install Wheel run: | python -m pip install --upgrade pip - pip install matplotlib scipy pytest pytest-cov coverage coveralls + pip install matplotlib scipy pytest pytest-cov pytest-timeout coverage coveralls pip install slycot-wheels/${{ matrix.packagekey }}/slycot*.whl pip show slycot - name: Slycot and python-control tests From 42e445e18158e5da26c02fc0ff1ba26db4b600f0 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 15:15:00 +0100 Subject: [PATCH 253/405] add SLICOT-reference module --- .gitmodules | 3 +++ slycot/src/SLICOT-reference | 1 + 2 files changed, 4 insertions(+) create mode 100644 .gitmodules create mode 160000 slycot/src/SLICOT-reference diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..9f8e0253 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "slycot/src/SLICOT-reference"] + path = slycot/src/SLICOT-reference + url = https://github.com/SLICOT/SLICOT-reference diff --git a/slycot/src/SLICOT-reference b/slycot/src/SLICOT-reference new file mode 160000 index 00000000..1fc31b7d --- /dev/null +++ b/slycot/src/SLICOT-reference @@ -0,0 +1 @@ +Subproject commit 1fc31b7db59f027ccf1c7fcd0164e77e5ff97107 From 426a3d8c26f005cef8bba83237ca8e1b1f6fc4f3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 15:22:58 +0100 Subject: [PATCH 254/405] Add license paragraph to README --- README.rst | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/README.rst b/README.rst index 6a1e8f09..2b80b0e4 100644 --- a/README.rst +++ b/README.rst @@ -194,3 +194,12 @@ Importing ``slycot`` or running ``pytest`` without ``--pyargs slycot`` from inside the source directory will fail, unless the compiled wrapper library has been installed into that directory. Note that the ``[tool:pytest]`` section in ``setup.cfg`` enforces the ``--pyargs slycot`` argument by default. + +License +------- +Up until version 0.4, Slycot used a version of SLICOT, which was released under +the GPLv2 license. This mandates to release Slycot under the same license. In +December 2020, SLICOT 5.7 was released under BSD-3-Clause. However, as the +existing Slycot wrappers have been submitted by many contributors, we cannot +move away from GPLv2 unless we get the permission to do so by all authors. +Thus, Slycot remains licensed under GPLv2 until further notice. \ No newline at end of file From 34ce1a4efe4baba8fbcddfecd6b87c1c85e216e6 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 17:53:01 +0100 Subject: [PATCH 255/405] Switch to SLICOT-reference sources --- slycot/CMakeLists.txt | 705 +++++++++-- slycot/src/AB01MD.f | 402 ------ slycot/src/AB01ND.f | 470 ------- slycot/src/AB01OD.f | 535 -------- slycot/src/AB04MD.f | 345 ------ slycot/src/AB05MD.f | 547 -------- slycot/src/AB05ND.f | 564 --------- slycot/src/AB05OD.f | 418 ------- slycot/src/AB05PD.f | 385 ------ slycot/src/AB05QD.f | 419 ------- slycot/src/AB05RD.f | 393 ------ slycot/src/AB05SD.f | 371 ------ slycot/src/AB07MD.f | 224 ---- slycot/src/AB07ND.f | 303 ----- slycot/src/AB08MD.f | 299 ----- slycot/src/AB08MZ.f | 303 ----- slycot/src/AB08ND.f | 568 --------- slycot/src/AB08NX.f | 447 ------- slycot/src/AB08NZ.f | 576 --------- slycot/src/AB09AD.f | 363 ------ slycot/src/AB09AX.f | 564 --------- slycot/src/AB09BD.f | 385 ------ slycot/src/AB09BX.f | 662 ---------- slycot/src/AB09CD.f | 375 ------ slycot/src/AB09CX.f | 558 --------- slycot/src/AB09DD.f | 278 ----- slycot/src/AB09ED.f | 493 -------- slycot/src/AB09FD.f | 649 ---------- slycot/src/AB09GD.f | 681 ---------- slycot/src/AB09HD.f | 671 ---------- slycot/src/AB09HX.f | 690 ----------- slycot/src/AB09HY.f | 396 ------ slycot/src/AB09ID.f | 1048 ---------------- slycot/src/AB09IX.f | 695 ----------- slycot/src/AB09IY.f | 859 ------------- slycot/src/AB09JD.f | 1482 ---------------------- slycot/src/AB09JV.f | 958 -------------- slycot/src/AB09JW.f | 972 --------------- slycot/src/AB09JX.f | 253 ---- slycot/src/AB09KD.f | 864 ------------- slycot/src/AB09KX.f | 869 ------------- slycot/src/AB09MD.f | 474 ------- slycot/src/AB09ND.f | 497 -------- slycot/src/AB13AD.f | 352 ------ slycot/src/AB13AX.f | 309 ----- slycot/src/AB13BD.f | 392 ------ slycot/src/AB13CD.f | 606 --------- slycot/src/AB13DD.f | 1870 ---------------------------- slycot/src/AB13DX.f | 549 -------- slycot/src/AB13ED.f | 347 ------ slycot/src/AB13FD.f | 403 ------ slycot/src/AB13MD.f | 1782 -------------------------- slycot/src/AB8NXZ.f | 458 ------- slycot/src/AG07BD.f | 273 ---- slycot/src/AG08BD.f | 628 ---------- slycot/src/AG08BY.f | 682 ---------- slycot/src/AG08BZ.f | 641 ---------- slycot/src/AG8BYZ.f | 694 ----------- slycot/src/BB01AD.f | 1286 ------------------- slycot/src/BB02AD.f | 1017 --------------- slycot/src/BB03AD.f | 490 -------- slycot/src/BB04AD.f | 476 ------- slycot/src/BD01AD.f | 1017 --------------- slycot/src/BD02AD.f | 601 --------- slycot/src/DE01OD.f | 203 --- slycot/src/DE01PD.f | 236 ---- slycot/src/DF01MD.f | 299 ----- slycot/src/DG01MD.f | 235 ---- slycot/src/DG01ND.f | 247 ---- slycot/src/DG01NY.f | 94 -- slycot/src/DG01OD.f | 357 ------ slycot/src/DK01MD.f | 183 --- slycot/src/FB01QD.f | 464 ------- slycot/src/FB01RD.f | 535 -------- slycot/src/FB01SD.f | 597 --------- slycot/src/FB01TD.f | 641 ---------- slycot/src/FB01VD.f | 391 ------ slycot/src/FD01AD.f | 367 ------ slycot/src/IB01AD.f | 686 ---------- slycot/src/IB01BD.f | 791 ------------ slycot/src/IB01CD.f | 823 ------------ slycot/src/IB01MD.f | 1433 --------------------- slycot/src/IB01MY.f | 1094 ---------------- slycot/src/IB01ND.f | 731 ----------- slycot/src/IB01OD.f | 214 ---- slycot/src/IB01OY.f | 175 --- slycot/src/IB01PD.f | 1232 ------------------ slycot/src/IB01PX.f | 474 ------- slycot/src/IB01PY.f | 768 ------------ slycot/src/IB01QD.f | 1081 ---------------- slycot/src/IB01RD.f | 762 ------------ slycot/src/IB03AD.f | 1076 ---------------- slycot/src/IB03BD.f | 1087 ---------------- slycot/src/MA01AD.f | 95 -- slycot/src/MA02AD.f | 108 -- slycot/src/MA02BD.f | 113 -- slycot/src/MA02BZ.f | 114 -- slycot/src/MA02CD.f | 113 -- slycot/src/MA02CZ.f | 113 -- slycot/src/MA02DD.f | 157 --- slycot/src/MA02ED.f | 99 -- slycot/src/MA02FD.f | 104 -- slycot/src/MA02GD.f | 158 --- slycot/src/MA02HD.f | 180 --- slycot/src/MA02ID.f | 293 ----- slycot/src/MA02JD.f | 164 --- slycot/src/MB01MD.f | 279 ----- slycot/src/MB01ND.f | 249 ---- slycot/src/MB01PD.f | 271 ---- slycot/src/MB01QD.f | 334 ----- slycot/src/MB01RD.f | 345 ------ slycot/src/MB01RU.f | 282 ----- slycot/src/MB01RW.f | 249 ---- slycot/src/MB01RX.f | 315 ----- slycot/src/MB01RY.f | 429 ------- slycot/src/MB01SD.f | 123 -- slycot/src/MB01TD.f | 173 --- slycot/src/MB01UD.f | 238 ---- slycot/src/MB01UW.f | 377 ------ slycot/src/MB01UX.f | 373 ------ slycot/src/MB01VD.f | 1693 ------------------------- slycot/src/MB01WD.f | 343 ----- slycot/src/MB01XD.f | 207 ---- slycot/src/MB01XY.f | 191 --- slycot/src/MB01YD.f | 352 ------ slycot/src/MB01ZD.f | 475 ------- slycot/src/MB02CD.f | 597 --------- slycot/src/MB02CU.f | 1015 --------------- slycot/src/MB02CV.f | 795 ------------ slycot/src/MB02CX.f | 318 ----- slycot/src/MB02CY.f | 372 ------ slycot/src/MB02DD.f | 564 --------- slycot/src/MB02ED.f | 445 ------- slycot/src/MB02FD.f | 383 ------ slycot/src/MB02GD.f | 558 --------- slycot/src/MB02HD.f | 545 -------- slycot/src/MB02ID.f | 508 -------- slycot/src/MB02JD.f | 486 -------- slycot/src/MB02JX.f | 737 ----------- slycot/src/MB02KD.f | 842 ------------- slycot/src/MB02MD.f | 577 --------- slycot/src/MB02ND.f | 889 ------------- slycot/src/MB02NY.f | 261 ---- slycot/src/MB02OD.f | 267 ---- slycot/src/MB02PD.f | 553 --------- slycot/src/MB02QD.f | 502 -------- slycot/src/MB02QY.f | 339 ----- slycot/src/MB02RD.f | 197 --- slycot/src/MB02RZ.f | 216 ---- slycot/src/MB02SD.f | 164 --- slycot/src/MB02SZ.f | 169 --- slycot/src/MB02TD.f | 236 ---- slycot/src/MB02TZ.f | 247 ---- slycot/src/MB02UD.f | 624 ---------- slycot/src/MB02UU.f | 162 --- slycot/src/MB02UV.f | 195 --- slycot/src/MB02VD.f | 187 --- slycot/src/MB02WD.f | 458 ------- slycot/src/MB02XD.f | 409 ------ slycot/src/MB02YD.f | 371 ------ slycot/src/MB03MD.f | 343 ----- slycot/src/MB03MY.f | 91 -- slycot/src/MB03ND.f | 218 ---- slycot/src/MB03NY.f | 211 ---- slycot/src/MB03OD.f | 306 ----- slycot/src/MB03OY.f | 388 ------ slycot/src/MB03PD.f | 339 ----- slycot/src/MB03PY.f | 392 ------ slycot/src/MB03QD.f | 316 ----- slycot/src/MB03QX.f | 122 -- slycot/src/MB03QY.f | 164 --- slycot/src/MB03RD.f | 613 --------- slycot/src/MB03RX.f | 226 ---- slycot/src/MB03RY.f | 261 ---- slycot/src/MB03SD.f | 348 ------ slycot/src/MB03TD.f | 641 ---------- slycot/src/MB03TS.f | 746 ----------- slycot/src/MB03UD.f | 318 ----- slycot/src/MB03VD.f | 306 ----- slycot/src/MB03VY.f | 216 ---- slycot/src/MB03WA.f | 538 -------- slycot/src/MB03WD.f | 966 --------------- slycot/src/MB03WX.f | 170 --- slycot/src/MB03XD.f | 826 ------------- slycot/src/MB03XP.f | 659 ---------- slycot/src/MB03XU.f | 2338 ----------------------------------- slycot/src/MB03YA.f | 297 ----- slycot/src/MB03YD.f | 540 -------- slycot/src/MB03YT.f | 331 ----- slycot/src/MB03ZA.f | 1371 -------------------- slycot/src/MB03ZD.f | 908 -------------- slycot/src/MB04DD.f | 440 ------- slycot/src/MB04DI.f | 216 ---- slycot/src/MB04DS.f | 450 ------- slycot/src/MB04DY.f | 329 ----- slycot/src/MB04GD.f | 258 ---- slycot/src/MB04ID.f | 278 ----- slycot/src/MB04IY.f | 327 ----- slycot/src/MB04IZ.f | 282 ----- slycot/src/MB04JD.f | 248 ---- slycot/src/MB04KD.f | 209 ---- slycot/src/MB04LD.f | 209 ---- slycot/src/MB04MD.f | 290 ----- slycot/src/MB04ND.f | 257 ---- slycot/src/MB04NY.f | 437 ------- slycot/src/MB04OD.f | 257 ---- slycot/src/MB04OW.f | 251 ---- slycot/src/MB04OX.f | 106 -- slycot/src/MB04OY.f | 370 ------ slycot/src/MB04PA.f | 1105 ----------------- slycot/src/MB04PB.f | 333 ----- slycot/src/MB04PU.f | 369 ------ slycot/src/MB04PY.f | 648 ---------- slycot/src/MB04QB.f | 454 ------- slycot/src/MB04QC.f | 1223 ------------------ slycot/src/MB04QF.f | 532 -------- slycot/src/MB04QU.f | 472 ------- slycot/src/MB04TB.f | 677 ---------- slycot/src/MB04TS.f | 519 -------- slycot/src/MB04TT.f | 413 ------- slycot/src/MB04TU.f | 96 -- slycot/src/MB04TV.f | 171 --- slycot/src/MB04TW.f | 180 --- slycot/src/MB04TX.f | 394 ------ slycot/src/MB04TY.f | 241 ---- slycot/src/MB04UD.f | 375 ------ slycot/src/MB04VD.f | 540 -------- slycot/src/MB04VX.f | 384 ------ slycot/src/MB04WD.f | 411 ------ slycot/src/MB04WP.f | 211 ---- slycot/src/MB04WR.f | 340 ----- slycot/src/MB04WU.f | 402 ------ slycot/src/MB04XD.f | 652 ---------- slycot/src/MB04XY.f | 274 ---- slycot/src/MB04YD.f | 623 ---------- slycot/src/MB04YW.f | 513 -------- slycot/src/MB04ZD.f | 486 -------- slycot/src/MB05MD.f | 356 ------ slycot/src/MB05MY.f | 327 ----- slycot/src/MB05ND.f | 377 ------ slycot/src/MB05OD.f | 574 --------- slycot/src/MB05OY.f | 179 --- slycot/src/MB3OYZ.f | 395 ------ slycot/src/MB3PYZ.f | 398 ------ slycot/src/MC01MD.f | 162 --- slycot/src/MC01ND.f | 146 --- slycot/src/MC01OD.f | 147 --- slycot/src/MC01PD.f | 159 --- slycot/src/MC01PY.f | 157 --- slycot/src/MC01QD.f | 207 ---- slycot/src/MC01RD.f | 299 ----- slycot/src/MC01SD.f | 281 ----- slycot/src/MC01SW.f | 104 -- slycot/src/MC01SX.f | 68 - slycot/src/MC01SY.f | 146 --- slycot/src/MC01TD.f | 305 ----- slycot/src/MC01VD.f | 304 ----- slycot/src/MC01WD.f | 156 --- slycot/src/MC03MD.f | 351 ------ slycot/src/MC03ND.f | 495 -------- slycot/src/MC03NX.f | 146 --- slycot/src/MC03NY.f | 412 ------ slycot/src/MD03AD.f | 973 --------------- slycot/src/MD03BA.f | 151 --- slycot/src/MD03BB.f | 203 --- slycot/src/MD03BD.f | 1206 ------------------ slycot/src/MD03BF.f | 122 -- slycot/src/MD03BX.f | 255 ---- slycot/src/MD03BY.f | 514 -------- slycot/src/NF01AD.f | 230 ---- slycot/src/NF01AY.f | 353 ------ slycot/src/NF01BA.f | 104 -- slycot/src/NF01BB.f | 138 --- slycot/src/NF01BD.f | 381 ------ slycot/src/NF01BE.f | 105 -- slycot/src/NF01BF.f | 157 --- slycot/src/NF01BP.f | 666 ---------- slycot/src/NF01BQ.f | 477 ------- slycot/src/NF01BR.f | 711 ----------- slycot/src/NF01BS.f | 610 --------- slycot/src/NF01BU.f | 398 ------ slycot/src/NF01BV.f | 249 ---- slycot/src/NF01BW.f | 242 ---- slycot/src/NF01BX.f | 174 --- slycot/src/NF01BY.f | 294 ----- slycot/src/Readme.md | 11 + slycot/src/SB01BD.f | 776 ------------ slycot/src/SB01BX.f | 150 --- slycot/src/SB01BY.f | 334 ----- slycot/src/SB01DD.f | 643 ---------- slycot/src/SB01FY.f | 315 ----- slycot/src/SB01MD.f | 397 ------ slycot/src/SB02CX.f | 94 -- slycot/src/SB02MD.f | 559 --------- slycot/src/SB02MR.f | 75 -- slycot/src/SB02MS.f | 79 -- slycot/src/SB02MT.f | 581 --------- slycot/src/SB02MU.f | 486 -------- slycot/src/SB02MV.f | 75 -- slycot/src/SB02MW.f | 79 -- slycot/src/SB02ND.f | 755 ----------- slycot/src/SB02OD.f | 856 ------------- slycot/src/SB02OU.f | 83 -- slycot/src/SB02OV.f | 88 -- slycot/src/SB02OW.f | 83 -- slycot/src/SB02OX.f | 87 -- slycot/src/SB02OY.f | 791 ------------ slycot/src/SB02PD.f | 756 ----------- slycot/src/SB02QD.f | 804 ------------ slycot/src/SB02RD.f | 1133 ----------------- slycot/src/SB02RU.f | 508 -------- slycot/src/SB02SD.f | 859 ------------- slycot/src/SB03MD.f | 556 --------- slycot/src/SB03MU.f | 467 ------- slycot/src/SB03MV.f | 295 ----- slycot/src/SB03MW.f | 293 ----- slycot/src/SB03MX.f | 711 ----------- slycot/src/SB03MY.f | 613 --------- slycot/src/SB03OD.f | 662 ---------- slycot/src/SB03OR.f | 429 ------- slycot/src/SB03OT.f | 984 --------------- slycot/src/SB03OU.f | 410 ------ slycot/src/SB03OV.f | 105 -- slycot/src/SB03OY.f | 693 ----------- slycot/src/SB03PD.f | 410 ------ slycot/src/SB03QD.f | 676 ---------- slycot/src/SB03QX.f | 394 ------ slycot/src/SB03QY.f | 443 ------- slycot/src/SB03RD.f | 404 ------ slycot/src/SB03SD.f | 674 ---------- slycot/src/SB03SX.f | 398 ------ slycot/src/SB03SY.f | 451 ------- slycot/src/SB03TD.f | 545 -------- slycot/src/SB03UD.f | 554 --------- slycot/src/SB04MD.f | 347 ------ slycot/src/SB04MR.f | 222 ---- slycot/src/SB04MU.f | 190 --- slycot/src/SB04MW.f | 194 --- slycot/src/SB04MY.f | 168 --- slycot/src/SB04ND.f | 405 ------ slycot/src/SB04NV.f | 165 --- slycot/src/SB04NW.f | 155 --- slycot/src/SB04NX.f | 320 ----- slycot/src/SB04NY.f | 260 ---- slycot/src/SB04OD.f | 1038 ---------------- slycot/src/SB04OW.f | 568 --------- slycot/src/SB04PD.f | 672 ---------- slycot/src/SB04PX.f | 468 ------- slycot/src/SB04PY.f | 1111 ----------------- slycot/src/SB04QD.f | 376 ------ slycot/src/SB04QR.f | 224 ---- slycot/src/SB04QU.f | 218 ---- slycot/src/SB04QY.f | 185 --- slycot/src/SB04RD.f | 406 ------ slycot/src/SB04RV.f | 198 --- slycot/src/SB04RW.f | 178 --- slycot/src/SB04RX.f | 375 ------ slycot/src/SB04RY.f | 261 ---- slycot/src/SB06ND.f | 326 ----- slycot/src/SB08CD.f | 355 ------ slycot/src/SB08DD.f | 583 --------- slycot/src/SB08ED.f | 359 ------ slycot/src/SB08FD.f | 630 ---------- slycot/src/SB08GD.f | 256 ---- slycot/src/SB08HD.f | 267 ---- slycot/src/SB08MD.f | 471 ------- slycot/src/SB08MY.f | 102 -- slycot/src/SB08ND.f | 382 ------ slycot/src/SB08NY.f | 83 -- slycot/src/SB09MD.f | 251 ---- slycot/src/SB10AD.f | 827 ------------- slycot/src/SB10DD.f | 1007 --------------- slycot/src/SB10ED.f | 468 ------- slycot/src/SB10FD.f | 469 ------- slycot/src/SB10HD.f | 390 ------ slycot/src/SB10ID.f | 584 --------- slycot/src/SB10JD.f | 355 ------ slycot/src/SB10KD.f | 650 ---------- slycot/src/SB10LD.f | 438 ------- slycot/src/SB10MD.f | 670 ---------- slycot/src/SB10PD.f | 505 -------- slycot/src/SB10QD.f | 602 --------- slycot/src/SB10RD.f | 706 ----------- slycot/src/SB10SD.f | 629 ---------- slycot/src/SB10TD.f | 350 ------ slycot/src/SB10UD.f | 419 ------- slycot/src/SB10VD.f | 393 ------ slycot/src/SB10WD.f | 299 ----- slycot/src/SB10YD.f | 689 ----------- slycot/src/SB10ZD.f | 914 -------------- slycot/src/SB10ZP.f | 339 ----- slycot/src/SB16AD.f | 719 ----------- slycot/src/SB16AY.f | 909 -------------- slycot/src/SB16BD.f | 652 ---------- slycot/src/SB16CD.f | 526 -------- slycot/src/SB16CY.f | 409 ------ slycot/src/SG02AD.f | 939 -------------- slycot/src/SG03AD.f | 640 ---------- slycot/src/SG03AX.f | 687 ---------- slycot/src/SG03AY.f | 686 ---------- slycot/src/SG03BD.f | 818 ------------ slycot/src/SG03BU.f | 696 ----------- slycot/src/SG03BV.f | 645 ---------- slycot/src/SG03BW.f | 459 ------- slycot/src/SG03BX.f | 764 ------------ slycot/src/SG03BY.f | 93 -- slycot/src/SLCT_DLATZM.f | 223 ---- slycot/src/SLCT_ZLATZM.f | 226 ---- slycot/src/SLICOT-reference | 2 +- slycot/src/TB01ID.f | 402 ------ slycot/src/TB01IZ.f | 409 ------ slycot/src/TB01KD.f | 334 ----- slycot/src/TB01LD.f | 348 ------ slycot/src/TB01MD.f | 340 ----- slycot/src/TB01ND.f | 352 ------ slycot/src/TB01PD.f | 352 ------ slycot/src/TB01TD.f | 308 ----- slycot/src/TB01TY.f | 136 -- slycot/src/TB01UD.f | 491 -------- slycot/src/TB01VD.f | 503 -------- slycot/src/TB01VY.f | 317 ----- slycot/src/TB01WD.f | 259 ---- slycot/src/TB01XD.f | 284 ----- slycot/src/TB01XZ.f | 280 ----- slycot/src/TB01YD.f | 188 --- slycot/src/TB01ZD.f | 440 ------- slycot/src/TB03AD.f | 746 ----------- slycot/src/TB03AY.f | 159 --- slycot/src/TB04AD.f | 395 ------ slycot/src/TB04AY.f | 246 ---- slycot/src/TB04BD.f | 600 --------- slycot/src/TB04BV.f | 343 ----- slycot/src/TB04BW.f | 280 ----- slycot/src/TB04BX.f | 246 ---- slycot/src/TB04CD.f | 568 --------- slycot/src/TB05AD.f | 545 -------- slycot/src/TC01OD.f | 236 ---- slycot/src/TC04AD.f | 483 -------- slycot/src/TC05AD.f | 403 ------ slycot/src/TD03AD.f | 581 --------- slycot/src/TD03AY.f | 171 --- slycot/src/TD04AD.f | 436 ------- slycot/src/TD05AD.f | 314 ----- slycot/src/TF01MD.f | 233 ---- slycot/src/TF01MX.f | 457 ------- slycot/src/TF01MY.f | 358 ------ slycot/src/TF01ND.f | 278 ----- slycot/src/TF01OD.f | 179 --- slycot/src/TF01PD.f | 178 --- slycot/src/TF01QD.f | 234 ---- slycot/src/TF01RD.f | 230 ---- slycot/src/TG01AD.f | 513 -------- slycot/src/TG01AZ.f | 523 -------- slycot/src/TG01BD.f | 434 ------- slycot/src/TG01CD.f | 292 ----- slycot/src/TG01DD.f | 295 ----- slycot/src/TG01ED.f | 793 ------------ slycot/src/TG01FD.f | 725 ----------- slycot/src/TG01FZ.f | 733 ----------- slycot/src/TG01HD.f | 545 -------- slycot/src/TG01HX.f | 694 ----------- slycot/src/TG01ID.f | 587 --------- slycot/src/TG01JD.f | 613 --------- slycot/src/TG01WD.f | 319 ----- slycot/src/UD01BD.f | 149 --- slycot/src/UD01CD.f | 174 --- slycot/src/UD01DD.f | 138 --- slycot/src/UD01MD.f | 175 --- slycot/src/UD01MZ.f | 175 --- slycot/src/UD01ND.f | 203 --- slycot/src/UE01MD.f | 266 ---- slycot/src/delctg.f | 27 - slycot/src/makefile | 120 -- slycot/src/readme | 8 - slycot/src/select.f | 27 - 475 files changed, 614 insertions(+), 209326 deletions(-) delete mode 100644 slycot/src/AB01MD.f delete mode 100644 slycot/src/AB01ND.f delete mode 100644 slycot/src/AB01OD.f delete mode 100644 slycot/src/AB04MD.f delete mode 100644 slycot/src/AB05MD.f delete mode 100644 slycot/src/AB05ND.f delete mode 100644 slycot/src/AB05OD.f delete mode 100644 slycot/src/AB05PD.f delete mode 100644 slycot/src/AB05QD.f delete mode 100644 slycot/src/AB05RD.f delete mode 100644 slycot/src/AB05SD.f delete mode 100644 slycot/src/AB07MD.f delete mode 100644 slycot/src/AB07ND.f delete mode 100644 slycot/src/AB08MD.f delete mode 100644 slycot/src/AB08MZ.f delete mode 100644 slycot/src/AB08ND.f delete mode 100644 slycot/src/AB08NX.f delete mode 100644 slycot/src/AB08NZ.f delete mode 100644 slycot/src/AB09AD.f delete mode 100644 slycot/src/AB09AX.f delete mode 100644 slycot/src/AB09BD.f delete mode 100644 slycot/src/AB09BX.f delete mode 100644 slycot/src/AB09CD.f delete mode 100644 slycot/src/AB09CX.f delete mode 100644 slycot/src/AB09DD.f delete mode 100644 slycot/src/AB09ED.f delete mode 100644 slycot/src/AB09FD.f delete mode 100644 slycot/src/AB09GD.f delete mode 100644 slycot/src/AB09HD.f delete mode 100644 slycot/src/AB09HX.f delete mode 100644 slycot/src/AB09HY.f delete mode 100644 slycot/src/AB09ID.f delete mode 100644 slycot/src/AB09IX.f delete mode 100644 slycot/src/AB09IY.f delete mode 100644 slycot/src/AB09JD.f delete mode 100644 slycot/src/AB09JV.f delete mode 100644 slycot/src/AB09JW.f delete mode 100644 slycot/src/AB09JX.f delete mode 100644 slycot/src/AB09KD.f delete mode 100644 slycot/src/AB09KX.f delete mode 100644 slycot/src/AB09MD.f delete mode 100644 slycot/src/AB09ND.f delete mode 100644 slycot/src/AB13AD.f delete mode 100644 slycot/src/AB13AX.f delete mode 100644 slycot/src/AB13BD.f delete mode 100644 slycot/src/AB13CD.f delete mode 100644 slycot/src/AB13DD.f delete mode 100644 slycot/src/AB13DX.f delete mode 100644 slycot/src/AB13ED.f delete mode 100644 slycot/src/AB13FD.f delete mode 100644 slycot/src/AB13MD.f delete mode 100644 slycot/src/AB8NXZ.f delete mode 100644 slycot/src/AG07BD.f delete mode 100644 slycot/src/AG08BD.f delete mode 100644 slycot/src/AG08BY.f delete mode 100644 slycot/src/AG08BZ.f delete mode 100644 slycot/src/AG8BYZ.f delete mode 100644 slycot/src/BB01AD.f delete mode 100644 slycot/src/BB02AD.f delete mode 100644 slycot/src/BB03AD.f delete mode 100644 slycot/src/BB04AD.f delete mode 100644 slycot/src/BD01AD.f delete mode 100644 slycot/src/BD02AD.f delete mode 100644 slycot/src/DE01OD.f delete mode 100644 slycot/src/DE01PD.f delete mode 100644 slycot/src/DF01MD.f delete mode 100644 slycot/src/DG01MD.f delete mode 100644 slycot/src/DG01ND.f delete mode 100644 slycot/src/DG01NY.f delete mode 100644 slycot/src/DG01OD.f delete mode 100644 slycot/src/DK01MD.f delete mode 100644 slycot/src/FB01QD.f delete mode 100644 slycot/src/FB01RD.f delete mode 100644 slycot/src/FB01SD.f delete mode 100644 slycot/src/FB01TD.f delete mode 100644 slycot/src/FB01VD.f delete mode 100644 slycot/src/FD01AD.f delete mode 100644 slycot/src/IB01AD.f delete mode 100644 slycot/src/IB01BD.f delete mode 100644 slycot/src/IB01CD.f delete mode 100644 slycot/src/IB01MD.f delete mode 100644 slycot/src/IB01MY.f delete mode 100644 slycot/src/IB01ND.f delete mode 100644 slycot/src/IB01OD.f delete mode 100644 slycot/src/IB01OY.f delete mode 100644 slycot/src/IB01PD.f delete mode 100644 slycot/src/IB01PX.f delete mode 100644 slycot/src/IB01PY.f delete mode 100644 slycot/src/IB01QD.f delete mode 100644 slycot/src/IB01RD.f delete mode 100644 slycot/src/IB03AD.f delete mode 100644 slycot/src/IB03BD.f delete mode 100644 slycot/src/MA01AD.f delete mode 100644 slycot/src/MA02AD.f delete mode 100644 slycot/src/MA02BD.f delete mode 100644 slycot/src/MA02BZ.f delete mode 100644 slycot/src/MA02CD.f delete mode 100644 slycot/src/MA02CZ.f delete mode 100644 slycot/src/MA02DD.f delete mode 100644 slycot/src/MA02ED.f delete mode 100644 slycot/src/MA02FD.f delete mode 100644 slycot/src/MA02GD.f delete mode 100644 slycot/src/MA02HD.f delete mode 100644 slycot/src/MA02ID.f delete mode 100644 slycot/src/MA02JD.f delete mode 100644 slycot/src/MB01MD.f delete mode 100644 slycot/src/MB01ND.f delete mode 100644 slycot/src/MB01PD.f delete mode 100644 slycot/src/MB01QD.f delete mode 100644 slycot/src/MB01RD.f delete mode 100644 slycot/src/MB01RU.f delete mode 100644 slycot/src/MB01RW.f delete mode 100644 slycot/src/MB01RX.f delete mode 100644 slycot/src/MB01RY.f delete mode 100644 slycot/src/MB01SD.f delete mode 100644 slycot/src/MB01TD.f delete mode 100644 slycot/src/MB01UD.f delete mode 100644 slycot/src/MB01UW.f delete mode 100644 slycot/src/MB01UX.f delete mode 100644 slycot/src/MB01VD.f delete mode 100644 slycot/src/MB01WD.f delete mode 100644 slycot/src/MB01XD.f delete mode 100644 slycot/src/MB01XY.f delete mode 100644 slycot/src/MB01YD.f delete mode 100644 slycot/src/MB01ZD.f delete mode 100644 slycot/src/MB02CD.f delete mode 100644 slycot/src/MB02CU.f delete mode 100644 slycot/src/MB02CV.f delete mode 100644 slycot/src/MB02CX.f delete mode 100644 slycot/src/MB02CY.f delete mode 100644 slycot/src/MB02DD.f delete mode 100644 slycot/src/MB02ED.f delete mode 100644 slycot/src/MB02FD.f delete mode 100644 slycot/src/MB02GD.f delete mode 100644 slycot/src/MB02HD.f delete mode 100644 slycot/src/MB02ID.f delete mode 100644 slycot/src/MB02JD.f delete mode 100644 slycot/src/MB02JX.f delete mode 100644 slycot/src/MB02KD.f delete mode 100644 slycot/src/MB02MD.f delete mode 100644 slycot/src/MB02ND.f delete mode 100644 slycot/src/MB02NY.f delete mode 100644 slycot/src/MB02OD.f delete mode 100644 slycot/src/MB02PD.f delete mode 100644 slycot/src/MB02QD.f delete mode 100644 slycot/src/MB02QY.f delete mode 100644 slycot/src/MB02RD.f delete mode 100644 slycot/src/MB02RZ.f delete mode 100644 slycot/src/MB02SD.f delete mode 100644 slycot/src/MB02SZ.f delete mode 100644 slycot/src/MB02TD.f delete mode 100644 slycot/src/MB02TZ.f delete mode 100644 slycot/src/MB02UD.f delete mode 100644 slycot/src/MB02UU.f delete mode 100644 slycot/src/MB02UV.f delete mode 100644 slycot/src/MB02VD.f delete mode 100644 slycot/src/MB02WD.f delete mode 100644 slycot/src/MB02XD.f delete mode 100644 slycot/src/MB02YD.f delete mode 100644 slycot/src/MB03MD.f delete mode 100644 slycot/src/MB03MY.f delete mode 100644 slycot/src/MB03ND.f delete mode 100644 slycot/src/MB03NY.f delete mode 100644 slycot/src/MB03OD.f delete mode 100644 slycot/src/MB03OY.f delete mode 100644 slycot/src/MB03PD.f delete mode 100644 slycot/src/MB03PY.f delete mode 100644 slycot/src/MB03QD.f delete mode 100644 slycot/src/MB03QX.f delete mode 100644 slycot/src/MB03QY.f delete mode 100644 slycot/src/MB03RD.f delete mode 100644 slycot/src/MB03RX.f delete mode 100644 slycot/src/MB03RY.f delete mode 100644 slycot/src/MB03SD.f delete mode 100644 slycot/src/MB03TD.f delete mode 100644 slycot/src/MB03TS.f delete mode 100644 slycot/src/MB03UD.f delete mode 100644 slycot/src/MB03VD.f delete mode 100644 slycot/src/MB03VY.f delete mode 100644 slycot/src/MB03WA.f delete mode 100644 slycot/src/MB03WD.f delete mode 100644 slycot/src/MB03WX.f delete mode 100644 slycot/src/MB03XD.f delete mode 100644 slycot/src/MB03XP.f delete mode 100644 slycot/src/MB03XU.f delete mode 100644 slycot/src/MB03YA.f delete mode 100644 slycot/src/MB03YD.f delete mode 100644 slycot/src/MB03YT.f delete mode 100644 slycot/src/MB03ZA.f delete mode 100644 slycot/src/MB03ZD.f delete mode 100644 slycot/src/MB04DD.f delete mode 100644 slycot/src/MB04DI.f delete mode 100644 slycot/src/MB04DS.f delete mode 100644 slycot/src/MB04DY.f delete mode 100644 slycot/src/MB04GD.f delete mode 100644 slycot/src/MB04ID.f delete mode 100644 slycot/src/MB04IY.f delete mode 100644 slycot/src/MB04IZ.f delete mode 100644 slycot/src/MB04JD.f delete mode 100644 slycot/src/MB04KD.f delete mode 100644 slycot/src/MB04LD.f delete mode 100644 slycot/src/MB04MD.f delete mode 100644 slycot/src/MB04ND.f delete mode 100644 slycot/src/MB04NY.f delete mode 100644 slycot/src/MB04OD.f delete mode 100644 slycot/src/MB04OW.f delete mode 100644 slycot/src/MB04OX.f delete mode 100644 slycot/src/MB04OY.f delete mode 100644 slycot/src/MB04PA.f delete mode 100644 slycot/src/MB04PB.f delete mode 100644 slycot/src/MB04PU.f delete mode 100644 slycot/src/MB04PY.f delete mode 100644 slycot/src/MB04QB.f delete mode 100644 slycot/src/MB04QC.f delete mode 100644 slycot/src/MB04QF.f delete mode 100644 slycot/src/MB04QU.f delete mode 100644 slycot/src/MB04TB.f delete mode 100644 slycot/src/MB04TS.f delete mode 100644 slycot/src/MB04TT.f delete mode 100644 slycot/src/MB04TU.f delete mode 100644 slycot/src/MB04TV.f delete mode 100644 slycot/src/MB04TW.f delete mode 100644 slycot/src/MB04TX.f delete mode 100644 slycot/src/MB04TY.f delete mode 100644 slycot/src/MB04UD.f delete mode 100644 slycot/src/MB04VD.f delete mode 100644 slycot/src/MB04VX.f delete mode 100644 slycot/src/MB04WD.f delete mode 100644 slycot/src/MB04WP.f delete mode 100644 slycot/src/MB04WR.f delete mode 100644 slycot/src/MB04WU.f delete mode 100644 slycot/src/MB04XD.f delete mode 100644 slycot/src/MB04XY.f delete mode 100644 slycot/src/MB04YD.f delete mode 100644 slycot/src/MB04YW.f delete mode 100644 slycot/src/MB04ZD.f delete mode 100644 slycot/src/MB05MD.f delete mode 100644 slycot/src/MB05MY.f delete mode 100644 slycot/src/MB05ND.f delete mode 100644 slycot/src/MB05OD.f delete mode 100644 slycot/src/MB05OY.f delete mode 100644 slycot/src/MB3OYZ.f delete mode 100644 slycot/src/MB3PYZ.f delete mode 100644 slycot/src/MC01MD.f delete mode 100644 slycot/src/MC01ND.f delete mode 100644 slycot/src/MC01OD.f delete mode 100644 slycot/src/MC01PD.f delete mode 100644 slycot/src/MC01PY.f delete mode 100644 slycot/src/MC01QD.f delete mode 100644 slycot/src/MC01RD.f delete mode 100644 slycot/src/MC01SD.f delete mode 100644 slycot/src/MC01SW.f delete mode 100644 slycot/src/MC01SX.f delete mode 100644 slycot/src/MC01SY.f delete mode 100644 slycot/src/MC01TD.f delete mode 100644 slycot/src/MC01VD.f delete mode 100644 slycot/src/MC01WD.f delete mode 100644 slycot/src/MC03MD.f delete mode 100644 slycot/src/MC03ND.f delete mode 100644 slycot/src/MC03NX.f delete mode 100644 slycot/src/MC03NY.f delete mode 100644 slycot/src/MD03AD.f delete mode 100644 slycot/src/MD03BA.f delete mode 100644 slycot/src/MD03BB.f delete mode 100644 slycot/src/MD03BD.f delete mode 100644 slycot/src/MD03BF.f delete mode 100644 slycot/src/MD03BX.f delete mode 100644 slycot/src/MD03BY.f delete mode 100644 slycot/src/NF01AD.f delete mode 100644 slycot/src/NF01AY.f delete mode 100644 slycot/src/NF01BA.f delete mode 100644 slycot/src/NF01BB.f delete mode 100644 slycot/src/NF01BD.f delete mode 100644 slycot/src/NF01BE.f delete mode 100644 slycot/src/NF01BF.f delete mode 100644 slycot/src/NF01BP.f delete mode 100644 slycot/src/NF01BQ.f delete mode 100644 slycot/src/NF01BR.f delete mode 100644 slycot/src/NF01BS.f delete mode 100644 slycot/src/NF01BU.f delete mode 100644 slycot/src/NF01BV.f delete mode 100644 slycot/src/NF01BW.f delete mode 100644 slycot/src/NF01BX.f delete mode 100644 slycot/src/NF01BY.f create mode 100644 slycot/src/Readme.md delete mode 100644 slycot/src/SB01BD.f delete mode 100644 slycot/src/SB01BX.f delete mode 100644 slycot/src/SB01BY.f delete mode 100644 slycot/src/SB01DD.f delete mode 100644 slycot/src/SB01FY.f delete mode 100644 slycot/src/SB01MD.f delete mode 100644 slycot/src/SB02CX.f delete mode 100644 slycot/src/SB02MD.f delete mode 100644 slycot/src/SB02MR.f delete mode 100644 slycot/src/SB02MS.f delete mode 100644 slycot/src/SB02MT.f delete mode 100644 slycot/src/SB02MU.f delete mode 100644 slycot/src/SB02MV.f delete mode 100644 slycot/src/SB02MW.f delete mode 100644 slycot/src/SB02ND.f delete mode 100644 slycot/src/SB02OD.f delete mode 100644 slycot/src/SB02OU.f delete mode 100644 slycot/src/SB02OV.f delete mode 100644 slycot/src/SB02OW.f delete mode 100644 slycot/src/SB02OX.f delete mode 100644 slycot/src/SB02OY.f delete mode 100644 slycot/src/SB02PD.f delete mode 100644 slycot/src/SB02QD.f delete mode 100644 slycot/src/SB02RD.f delete mode 100644 slycot/src/SB02RU.f delete mode 100644 slycot/src/SB02SD.f delete mode 100644 slycot/src/SB03MD.f delete mode 100644 slycot/src/SB03MU.f delete mode 100644 slycot/src/SB03MV.f delete mode 100644 slycot/src/SB03MW.f delete mode 100644 slycot/src/SB03MX.f delete mode 100644 slycot/src/SB03MY.f delete mode 100644 slycot/src/SB03OD.f delete mode 100644 slycot/src/SB03OR.f delete mode 100644 slycot/src/SB03OT.f delete mode 100644 slycot/src/SB03OU.f delete mode 100644 slycot/src/SB03OV.f delete mode 100644 slycot/src/SB03OY.f delete mode 100644 slycot/src/SB03PD.f delete mode 100644 slycot/src/SB03QD.f delete mode 100644 slycot/src/SB03QX.f delete mode 100644 slycot/src/SB03QY.f delete mode 100644 slycot/src/SB03RD.f delete mode 100644 slycot/src/SB03SD.f delete mode 100644 slycot/src/SB03SX.f delete mode 100644 slycot/src/SB03SY.f delete mode 100644 slycot/src/SB03TD.f delete mode 100644 slycot/src/SB03UD.f delete mode 100644 slycot/src/SB04MD.f delete mode 100644 slycot/src/SB04MR.f delete mode 100644 slycot/src/SB04MU.f delete mode 100644 slycot/src/SB04MW.f delete mode 100644 slycot/src/SB04MY.f delete mode 100644 slycot/src/SB04ND.f delete mode 100644 slycot/src/SB04NV.f delete mode 100644 slycot/src/SB04NW.f delete mode 100644 slycot/src/SB04NX.f delete mode 100644 slycot/src/SB04NY.f delete mode 100644 slycot/src/SB04OD.f delete mode 100644 slycot/src/SB04OW.f delete mode 100644 slycot/src/SB04PD.f delete mode 100644 slycot/src/SB04PX.f delete mode 100644 slycot/src/SB04PY.f delete mode 100644 slycot/src/SB04QD.f delete mode 100644 slycot/src/SB04QR.f delete mode 100644 slycot/src/SB04QU.f delete mode 100644 slycot/src/SB04QY.f delete mode 100644 slycot/src/SB04RD.f delete mode 100644 slycot/src/SB04RV.f delete mode 100644 slycot/src/SB04RW.f delete mode 100644 slycot/src/SB04RX.f delete mode 100644 slycot/src/SB04RY.f delete mode 100644 slycot/src/SB06ND.f delete mode 100644 slycot/src/SB08CD.f delete mode 100644 slycot/src/SB08DD.f delete mode 100644 slycot/src/SB08ED.f delete mode 100644 slycot/src/SB08FD.f delete mode 100644 slycot/src/SB08GD.f delete mode 100644 slycot/src/SB08HD.f delete mode 100644 slycot/src/SB08MD.f delete mode 100644 slycot/src/SB08MY.f delete mode 100644 slycot/src/SB08ND.f delete mode 100644 slycot/src/SB08NY.f delete mode 100644 slycot/src/SB09MD.f delete mode 100644 slycot/src/SB10AD.f delete mode 100644 slycot/src/SB10DD.f delete mode 100644 slycot/src/SB10ED.f delete mode 100644 slycot/src/SB10FD.f delete mode 100644 slycot/src/SB10HD.f delete mode 100644 slycot/src/SB10ID.f delete mode 100644 slycot/src/SB10JD.f delete mode 100644 slycot/src/SB10KD.f delete mode 100644 slycot/src/SB10LD.f delete mode 100644 slycot/src/SB10MD.f delete mode 100644 slycot/src/SB10PD.f delete mode 100644 slycot/src/SB10QD.f delete mode 100644 slycot/src/SB10RD.f delete mode 100644 slycot/src/SB10SD.f delete mode 100644 slycot/src/SB10TD.f delete mode 100644 slycot/src/SB10UD.f delete mode 100644 slycot/src/SB10VD.f delete mode 100644 slycot/src/SB10WD.f delete mode 100644 slycot/src/SB10YD.f delete mode 100644 slycot/src/SB10ZD.f delete mode 100644 slycot/src/SB10ZP.f delete mode 100644 slycot/src/SB16AD.f delete mode 100644 slycot/src/SB16AY.f delete mode 100644 slycot/src/SB16BD.f delete mode 100644 slycot/src/SB16CD.f delete mode 100644 slycot/src/SB16CY.f delete mode 100644 slycot/src/SG02AD.f delete mode 100644 slycot/src/SG03AD.f delete mode 100644 slycot/src/SG03AX.f delete mode 100644 slycot/src/SG03AY.f delete mode 100644 slycot/src/SG03BD.f delete mode 100644 slycot/src/SG03BU.f delete mode 100644 slycot/src/SG03BV.f delete mode 100644 slycot/src/SG03BW.f delete mode 100644 slycot/src/SG03BX.f delete mode 100644 slycot/src/SG03BY.f delete mode 100644 slycot/src/SLCT_DLATZM.f delete mode 100644 slycot/src/SLCT_ZLATZM.f delete mode 100644 slycot/src/TB01ID.f delete mode 100644 slycot/src/TB01IZ.f delete mode 100644 slycot/src/TB01KD.f delete mode 100644 slycot/src/TB01LD.f delete mode 100644 slycot/src/TB01MD.f delete mode 100644 slycot/src/TB01ND.f delete mode 100644 slycot/src/TB01PD.f delete mode 100644 slycot/src/TB01TD.f delete mode 100644 slycot/src/TB01TY.f delete mode 100644 slycot/src/TB01UD.f delete mode 100644 slycot/src/TB01VD.f delete mode 100644 slycot/src/TB01VY.f delete mode 100644 slycot/src/TB01WD.f delete mode 100644 slycot/src/TB01XD.f delete mode 100644 slycot/src/TB01XZ.f delete mode 100644 slycot/src/TB01YD.f delete mode 100644 slycot/src/TB01ZD.f delete mode 100644 slycot/src/TB03AD.f delete mode 100644 slycot/src/TB03AY.f delete mode 100644 slycot/src/TB04AD.f delete mode 100644 slycot/src/TB04AY.f delete mode 100644 slycot/src/TB04BD.f delete mode 100644 slycot/src/TB04BV.f delete mode 100644 slycot/src/TB04BW.f delete mode 100644 slycot/src/TB04BX.f delete mode 100644 slycot/src/TB04CD.f delete mode 100644 slycot/src/TB05AD.f delete mode 100644 slycot/src/TC01OD.f delete mode 100644 slycot/src/TC04AD.f delete mode 100644 slycot/src/TC05AD.f delete mode 100644 slycot/src/TD03AD.f delete mode 100644 slycot/src/TD03AY.f delete mode 100644 slycot/src/TD04AD.f delete mode 100644 slycot/src/TD05AD.f delete mode 100644 slycot/src/TF01MD.f delete mode 100644 slycot/src/TF01MX.f delete mode 100644 slycot/src/TF01MY.f delete mode 100644 slycot/src/TF01ND.f delete mode 100644 slycot/src/TF01OD.f delete mode 100644 slycot/src/TF01PD.f delete mode 100644 slycot/src/TF01QD.f delete mode 100644 slycot/src/TF01RD.f delete mode 100644 slycot/src/TG01AD.f delete mode 100644 slycot/src/TG01AZ.f delete mode 100644 slycot/src/TG01BD.f delete mode 100644 slycot/src/TG01CD.f delete mode 100644 slycot/src/TG01DD.f delete mode 100644 slycot/src/TG01ED.f delete mode 100644 slycot/src/TG01FD.f delete mode 100644 slycot/src/TG01FZ.f delete mode 100644 slycot/src/TG01HD.f delete mode 100644 slycot/src/TG01HX.f delete mode 100644 slycot/src/TG01ID.f delete mode 100644 slycot/src/TG01JD.f delete mode 100644 slycot/src/TG01WD.f delete mode 100644 slycot/src/UD01BD.f delete mode 100644 slycot/src/UD01CD.f delete mode 100644 slycot/src/UD01DD.f delete mode 100644 slycot/src/UD01MD.f delete mode 100644 slycot/src/UD01MZ.f delete mode 100644 slycot/src/UD01ND.f delete mode 100644 slycot/src/UE01MD.f delete mode 100644 slycot/src/delctg.f delete mode 100644 slycot/src/makefile delete mode 100644 slycot/src/readme delete mode 100644 slycot/src/select.f diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 8687d0eb..91ce0876 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -3,110 +3,609 @@ # # RvP, 180710 +# +set(SLICOT_FSOURCE + +src/SLICOT-reference/src/AB01MD.f +src/SLICOT-reference/src/AB01ND.f +src/SLICOT-reference/src/AB01OD.f +src/SLICOT-reference/src/AB04MD.f +src/SLICOT-reference/src/AB05MD.f +src/SLICOT-reference/src/AB05ND.f +src/SLICOT-reference/src/AB05OD.f +src/SLICOT-reference/src/AB05PD.f +src/SLICOT-reference/src/AB05QD.f +src/SLICOT-reference/src/AB05RD.f +src/SLICOT-reference/src/AB05SD.f +src/SLICOT-reference/src/AB07MD.f +src/SLICOT-reference/src/AB07ND.f +src/SLICOT-reference/src/AB08MD.f +src/SLICOT-reference/src/AB08MZ.f +src/SLICOT-reference/src/AB08ND.f +src/SLICOT-reference/src/AB08NW.f +src/SLICOT-reference/src/AB08NX.f +src/SLICOT-reference/src/AB08NY.f +src/SLICOT-reference/src/AB08NZ.f +src/SLICOT-reference/src/AB09AD.f +src/SLICOT-reference/src/AB09AX.f +src/SLICOT-reference/src/AB09BD.f +src/SLICOT-reference/src/AB09BX.f +src/SLICOT-reference/src/AB09CD.f +src/SLICOT-reference/src/AB09CX.f +src/SLICOT-reference/src/AB09DD.f +src/SLICOT-reference/src/AB09ED.f +src/SLICOT-reference/src/AB09FD.f +src/SLICOT-reference/src/AB09GD.f +src/SLICOT-reference/src/AB09HD.f +src/SLICOT-reference/src/AB09HX.f +src/SLICOT-reference/src/AB09HY.f +src/SLICOT-reference/src/AB09ID.f +src/SLICOT-reference/src/AB09IX.f +src/SLICOT-reference/src/AB09IY.f +src/SLICOT-reference/src/AB09JD.f +src/SLICOT-reference/src/AB09JV.f +src/SLICOT-reference/src/AB09JW.f +src/SLICOT-reference/src/AB09JX.f +src/SLICOT-reference/src/AB09KD.f +src/SLICOT-reference/src/AB09KX.f +src/SLICOT-reference/src/AB09MD.f +src/SLICOT-reference/src/AB09ND.f +src/SLICOT-reference/src/AB13AD.f +src/SLICOT-reference/src/AB13AX.f +src/SLICOT-reference/src/AB13BD.f +src/SLICOT-reference/src/AB13CD.f +src/SLICOT-reference/src/AB13DD.f +src/SLICOT-reference/src/AB13DX.f +src/SLICOT-reference/src/AB13ED.f +src/SLICOT-reference/src/AB13FD.f +src/SLICOT-reference/src/AB13ID.f +src/SLICOT-reference/src/AB13MD.f +src/SLICOT-reference/src/AB8NXZ.f +src/SLICOT-reference/src/AG07BD.f +src/SLICOT-reference/src/AG08BD.f +src/SLICOT-reference/src/AG08BY.f +src/SLICOT-reference/src/AG08BZ.f +src/SLICOT-reference/src/AG8BYZ.f +src/SLICOT-reference/src/BB01AD.f +src/SLICOT-reference/src/BB02AD.f +src/SLICOT-reference/src/BB03AD.f +src/SLICOT-reference/src/BB04AD.f +src/SLICOT-reference/src/BD01AD.f +src/SLICOT-reference/src/BD02AD.f +src/SLICOT-reference/src/DE01OD.f +src/SLICOT-reference/src/DE01PD.f +src/SLICOT-reference/src/DF01MD.f +src/SLICOT-reference/src/DG01MD.f +src/SLICOT-reference/src/DG01ND.f +src/SLICOT-reference/src/DG01NY.f +src/SLICOT-reference/src/DG01OD.f +src/SLICOT-reference/src/DK01MD.f +src/SLICOT-reference/src/FB01QD.f +src/SLICOT-reference/src/FB01RD.f +src/SLICOT-reference/src/FB01SD.f +src/SLICOT-reference/src/FB01TD.f +src/SLICOT-reference/src/FB01VD.f +src/SLICOT-reference/src/FD01AD.f +src/SLICOT-reference/src/IB01AD.f +src/SLICOT-reference/src/IB01BD.f +src/SLICOT-reference/src/IB01CD.f +src/SLICOT-reference/src/IB01MD.f +src/SLICOT-reference/src/IB01MY.f +src/SLICOT-reference/src/IB01ND.f +src/SLICOT-reference/src/IB01OD.f +src/SLICOT-reference/src/IB01OY.f +src/SLICOT-reference/src/IB01PD.f +src/SLICOT-reference/src/IB01PX.f +src/SLICOT-reference/src/IB01PY.f +src/SLICOT-reference/src/IB01QD.f +src/SLICOT-reference/src/IB01RD.f +src/SLICOT-reference/src/IB03AD.f +src/SLICOT-reference/src/IB03BD.f +src/SLICOT-reference/src/MA01AD.f +src/SLICOT-reference/src/MA01BD.f +src/SLICOT-reference/src/MA01BZ.f +src/SLICOT-reference/src/MA01CD.f +src/SLICOT-reference/src/MA02AD.f +src/SLICOT-reference/src/MA02BD.f +src/SLICOT-reference/src/MA02BZ.f +src/SLICOT-reference/src/MA02CD.f +src/SLICOT-reference/src/MA02CZ.f +src/SLICOT-reference/src/MA02DD.f +src/SLICOT-reference/src/MA02ED.f +src/SLICOT-reference/src/MA02ES.f +src/SLICOT-reference/src/MA02EZ.f +src/SLICOT-reference/src/MA02FD.f +src/SLICOT-reference/src/MA02GD.f +src/SLICOT-reference/src/MA02GZ.f +src/SLICOT-reference/src/MA02HD.f +src/SLICOT-reference/src/MA02HZ.f +src/SLICOT-reference/src/MA02ID.f +src/SLICOT-reference/src/MA02IZ.f +src/SLICOT-reference/src/MA02JD.f +src/SLICOT-reference/src/MA02JZ.f +src/SLICOT-reference/src/MA02MD.f +src/SLICOT-reference/src/MA02MZ.f +src/SLICOT-reference/src/MA02NZ.f +src/SLICOT-reference/src/MA02OD.f +src/SLICOT-reference/src/MA02OZ.f +src/SLICOT-reference/src/MA02PD.f +src/SLICOT-reference/src/MA02PZ.f +src/SLICOT-reference/src/MB01KD.f +src/SLICOT-reference/src/MB01LD.f +src/SLICOT-reference/src/MB01MD.f +src/SLICOT-reference/src/MB01ND.f +src/SLICOT-reference/src/MB01OC.f +src/SLICOT-reference/src/MB01OD.f +src/SLICOT-reference/src/MB01OE.f +src/SLICOT-reference/src/MB01OH.f +src/SLICOT-reference/src/MB01OO.f +src/SLICOT-reference/src/MB01OS.f +src/SLICOT-reference/src/MB01OT.f +src/SLICOT-reference/src/MB01PD.f +src/SLICOT-reference/src/MB01QD.f +src/SLICOT-reference/src/MB01RB.f +src/SLICOT-reference/src/MB01RD.f +src/SLICOT-reference/src/MB01RH.f +src/SLICOT-reference/src/MB01RT.f +src/SLICOT-reference/src/MB01RU.f +src/SLICOT-reference/src/MB01RW.f +src/SLICOT-reference/src/MB01RX.f +src/SLICOT-reference/src/MB01RY.f +src/SLICOT-reference/src/MB01SD.f +src/SLICOT-reference/src/MB01SS.f +src/SLICOT-reference/src/MB01TD.f +src/SLICOT-reference/src/MB01UD.f +src/SLICOT-reference/src/MB01UW.f +src/SLICOT-reference/src/MB01UX.f +src/SLICOT-reference/src/MB01VD.f +src/SLICOT-reference/src/MB01WD.f +src/SLICOT-reference/src/MB01XD.f +src/SLICOT-reference/src/MB01XY.f +src/SLICOT-reference/src/MB01YD.f +src/SLICOT-reference/src/MB01ZD.f +src/SLICOT-reference/src/MB02CD.f +src/SLICOT-reference/src/MB02CU.f +src/SLICOT-reference/src/MB02CV.f +src/SLICOT-reference/src/MB02CX.f +src/SLICOT-reference/src/MB02CY.f +src/SLICOT-reference/src/MB02DD.f +src/SLICOT-reference/src/MB02ED.f +src/SLICOT-reference/src/MB02FD.f +src/SLICOT-reference/src/MB02GD.f +src/SLICOT-reference/src/MB02HD.f +src/SLICOT-reference/src/MB02ID.f +src/SLICOT-reference/src/MB02JD.f +src/SLICOT-reference/src/MB02JX.f +src/SLICOT-reference/src/MB02KD.f +src/SLICOT-reference/src/MB02MD.f +src/SLICOT-reference/src/MB02ND.f +src/SLICOT-reference/src/MB02NY.f +src/SLICOT-reference/src/MB02OD.f +src/SLICOT-reference/src/MB02PD.f +src/SLICOT-reference/src/MB02QD.f +src/SLICOT-reference/src/MB02QY.f +src/SLICOT-reference/src/MB02RD.f +src/SLICOT-reference/src/MB02RZ.f +src/SLICOT-reference/src/MB02SD.f +src/SLICOT-reference/src/MB02SZ.f +src/SLICOT-reference/src/MB02TD.f +src/SLICOT-reference/src/MB02TZ.f +src/SLICOT-reference/src/MB02UD.f +src/SLICOT-reference/src/MB02UU.f +src/SLICOT-reference/src/MB02UV.f +src/SLICOT-reference/src/MB02UW.f +src/SLICOT-reference/src/MB02VD.f +src/SLICOT-reference/src/MB02WD.f +src/SLICOT-reference/src/MB02XD.f +src/SLICOT-reference/src/MB02YD.f +src/SLICOT-reference/src/MB03AB.f +src/SLICOT-reference/src/MB03AD.f +src/SLICOT-reference/src/MB03AE.f +src/SLICOT-reference/src/MB03AF.f +src/SLICOT-reference/src/MB03AG.f +src/SLICOT-reference/src/MB03AH.f +src/SLICOT-reference/src/MB03AI.f +src/SLICOT-reference/src/MB03BA.f +src/SLICOT-reference/src/MB03BB.f +src/SLICOT-reference/src/MB03BC.f +src/SLICOT-reference/src/MB03BD.f +src/SLICOT-reference/src/MB03BE.f +src/SLICOT-reference/src/MB03BF.f +src/SLICOT-reference/src/MB03BG.f +src/SLICOT-reference/src/MB03BZ.f +src/SLICOT-reference/src/MB03CD.f +src/SLICOT-reference/src/MB03CZ.f +src/SLICOT-reference/src/MB03DD.f +src/SLICOT-reference/src/MB03DZ.f +src/SLICOT-reference/src/MB03ED.f +src/SLICOT-reference/src/MB03FD.f +src/SLICOT-reference/src/MB03FZ.f +src/SLICOT-reference/src/MB03GD.f +src/SLICOT-reference/src/MB03GZ.f +src/SLICOT-reference/src/MB03HD.f +src/SLICOT-reference/src/MB03HZ.f +src/SLICOT-reference/src/MB03ID.f +src/SLICOT-reference/src/MB03IZ.f +src/SLICOT-reference/src/MB03JD.f +src/SLICOT-reference/src/MB03JP.f +src/SLICOT-reference/src/MB03JZ.f +src/SLICOT-reference/src/MB03KA.f +src/SLICOT-reference/src/MB03KB.f +src/SLICOT-reference/src/MB03KC.f +src/SLICOT-reference/src/MB03KD.f +src/SLICOT-reference/src/MB03KE.f +src/SLICOT-reference/src/MB03LD.f +src/SLICOT-reference/src/MB03LF.f +src/SLICOT-reference/src/MB03LP.f +src/SLICOT-reference/src/MB03LZ.f +src/SLICOT-reference/src/MB03MD.f +src/SLICOT-reference/src/MB03MY.f +src/SLICOT-reference/src/MB03ND.f +src/SLICOT-reference/src/MB03NY.f +src/SLICOT-reference/src/MB03OD.f +src/SLICOT-reference/src/MB03OY.f +src/SLICOT-reference/src/MB03PD.f +src/SLICOT-reference/src/MB03PY.f +src/SLICOT-reference/src/MB03QD.f +src/SLICOT-reference/src/MB03QG.f +src/SLICOT-reference/src/MB03QV.f +src/SLICOT-reference/src/MB03QW.f +src/SLICOT-reference/src/MB03QX.f +src/SLICOT-reference/src/MB03QY.f +src/SLICOT-reference/src/MB03RD.f +src/SLICOT-reference/src/MB03RX.f +src/SLICOT-reference/src/MB03RY.f +src/SLICOT-reference/src/MB03SD.f +src/SLICOT-reference/src/MB03TD.f +src/SLICOT-reference/src/MB03TS.f +src/SLICOT-reference/src/MB03UD.f +src/SLICOT-reference/src/MB03VD.f +src/SLICOT-reference/src/MB03VY.f +src/SLICOT-reference/src/MB03WA.f +src/SLICOT-reference/src/MB03WD.f +src/SLICOT-reference/src/MB03WX.f +src/SLICOT-reference/src/MB03XD.f +src/SLICOT-reference/src/MB03XP.f +src/SLICOT-reference/src/MB03XS.f +src/SLICOT-reference/src/MB03XU.f +src/SLICOT-reference/src/MB03XZ.f +src/SLICOT-reference/src/MB03YA.f +src/SLICOT-reference/src/MB03YD.f +src/SLICOT-reference/src/MB03YT.f +src/SLICOT-reference/src/MB03ZA.f +src/SLICOT-reference/src/MB03ZD.f +src/SLICOT-reference/src/MB04AD.f +src/SLICOT-reference/src/MB04AZ.f +src/SLICOT-reference/src/MB04BD.f +src/SLICOT-reference/src/MB04BP.f +src/SLICOT-reference/src/MB04BZ.f +src/SLICOT-reference/src/MB04CD.f +src/SLICOT-reference/src/MB04DB.f +src/SLICOT-reference/src/MB04DD.f +src/SLICOT-reference/src/MB04DI.f +src/SLICOT-reference/src/MB04DL.f +src/SLICOT-reference/src/MB04DP.f +src/SLICOT-reference/src/MB04DS.f +src/SLICOT-reference/src/MB04DY.f +src/SLICOT-reference/src/MB04DZ.f +src/SLICOT-reference/src/MB04ED.f +src/SLICOT-reference/src/MB04FD.f +src/SLICOT-reference/src/MB04FP.f +src/SLICOT-reference/src/MB04GD.f +src/SLICOT-reference/src/MB04HD.f +src/SLICOT-reference/src/MB04ID.f +src/SLICOT-reference/src/MB04IY.f +src/SLICOT-reference/src/MB04IZ.f +src/SLICOT-reference/src/MB04JD.f +src/SLICOT-reference/src/MB04KD.f +src/SLICOT-reference/src/MB04LD.f +src/SLICOT-reference/src/MB04MD.f +src/SLICOT-reference/src/MB04ND.f +src/SLICOT-reference/src/MB04NY.f +src/SLICOT-reference/src/MB04OD.f +src/SLICOT-reference/src/MB04OW.f +src/SLICOT-reference/src/MB04OX.f +src/SLICOT-reference/src/MB04OY.f +src/SLICOT-reference/src/MB04PA.f +src/SLICOT-reference/src/MB04PB.f +src/SLICOT-reference/src/MB04PU.f +src/SLICOT-reference/src/MB04PY.f +src/SLICOT-reference/src/MB04QB.f +src/SLICOT-reference/src/MB04QC.f +src/SLICOT-reference/src/MB04QF.f +src/SLICOT-reference/src/MB04QS.f +src/SLICOT-reference/src/MB04QU.f +src/SLICOT-reference/src/MB04RB.f +src/SLICOT-reference/src/MB04RU.f +src/SLICOT-reference/src/MB04SU.f +src/SLICOT-reference/src/MB04TB.f +src/SLICOT-reference/src/MB04TS.f +src/SLICOT-reference/src/MB04TT.f +src/SLICOT-reference/src/MB04TU.f +src/SLICOT-reference/src/MB04TV.f +src/SLICOT-reference/src/MB04TW.f +src/SLICOT-reference/src/MB04TX.f +src/SLICOT-reference/src/MB04TY.f +src/SLICOT-reference/src/MB04UD.f +src/SLICOT-reference/src/MB04VD.f +src/SLICOT-reference/src/MB04VX.f +src/SLICOT-reference/src/MB04WD.f +src/SLICOT-reference/src/MB04WP.f +src/SLICOT-reference/src/MB04WR.f +src/SLICOT-reference/src/MB04WU.f +src/SLICOT-reference/src/MB04XD.f +src/SLICOT-reference/src/MB04XY.f +src/SLICOT-reference/src/MB04YD.f +src/SLICOT-reference/src/MB04YW.f +src/SLICOT-reference/src/MB04ZD.f +src/SLICOT-reference/src/MB05MD.f +src/SLICOT-reference/src/MB05MY.f +src/SLICOT-reference/src/MB05ND.f +src/SLICOT-reference/src/MB05OD.f +src/SLICOT-reference/src/MB05OY.f +src/SLICOT-reference/src/MB3JZP.f +src/SLICOT-reference/src/MB3LZP.f +src/SLICOT-reference/src/MB3OYZ.f +src/SLICOT-reference/src/MB3PYZ.f +src/SLICOT-reference/src/MB4DBZ.f +src/SLICOT-reference/src/MB4DLZ.f +src/SLICOT-reference/src/MB4DPZ.f +src/SLICOT-reference/src/MC01MD.f +src/SLICOT-reference/src/MC01ND.f +src/SLICOT-reference/src/MC01OD.f +src/SLICOT-reference/src/MC01PD.f +src/SLICOT-reference/src/MC01PY.f +src/SLICOT-reference/src/MC01QD.f +src/SLICOT-reference/src/MC01RD.f +src/SLICOT-reference/src/MC01SD.f +src/SLICOT-reference/src/MC01SW.f +src/SLICOT-reference/src/MC01SX.f +src/SLICOT-reference/src/MC01SY.f +src/SLICOT-reference/src/MC01TD.f +src/SLICOT-reference/src/MC01VD.f +src/SLICOT-reference/src/MC01WD.f +src/SLICOT-reference/src/MC01XD.f +src/SLICOT-reference/src/MC03MD.f +src/SLICOT-reference/src/MC03ND.f +src/SLICOT-reference/src/MC03NX.f +src/SLICOT-reference/src/MC03NY.f +src/SLICOT-reference/src/MD03AD.f +src/SLICOT-reference/src/MD03BA.f +src/SLICOT-reference/src/MD03BB.f +src/SLICOT-reference/src/MD03BD.f +src/SLICOT-reference/src/MD03BF.f +src/SLICOT-reference/src/MD03BX.f +src/SLICOT-reference/src/MD03BY.f +src/SLICOT-reference/src/NF01AD.f +src/SLICOT-reference/src/NF01AY.f +src/SLICOT-reference/src/NF01BA.f +src/SLICOT-reference/src/NF01BB.f +src/SLICOT-reference/src/NF01BD.f +src/SLICOT-reference/src/NF01BE.f +src/SLICOT-reference/src/NF01BF.f +src/SLICOT-reference/src/NF01BP.f +src/SLICOT-reference/src/NF01BQ.f +src/SLICOT-reference/src/NF01BR.f +src/SLICOT-reference/src/NF01BS.f +src/SLICOT-reference/src/NF01BU.f +src/SLICOT-reference/src/NF01BV.f +src/SLICOT-reference/src/NF01BW.f +src/SLICOT-reference/src/NF01BX.f +src/SLICOT-reference/src/NF01BY.f +src/SLICOT-reference/src/SB01BD.f +src/SLICOT-reference/src/SB01BX.f +src/SLICOT-reference/src/SB01BY.f +src/SLICOT-reference/src/SB01DD.f +src/SLICOT-reference/src/SB01FY.f +src/SLICOT-reference/src/SB01MD.f +src/SLICOT-reference/src/SB02CX.f +src/SLICOT-reference/src/SB02MD.f +src/SLICOT-reference/src/SB02MR.f +src/SLICOT-reference/src/SB02MS.f +src/SLICOT-reference/src/SB02MT.f +src/SLICOT-reference/src/SB02MU.f +src/SLICOT-reference/src/SB02MV.f +src/SLICOT-reference/src/SB02MW.f +src/SLICOT-reference/src/SB02MX.f +src/SLICOT-reference/src/SB02ND.f +src/SLICOT-reference/src/SB02OD.f +src/SLICOT-reference/src/SB02OU.f +src/SLICOT-reference/src/SB02OV.f +src/SLICOT-reference/src/SB02OW.f +src/SLICOT-reference/src/SB02OX.f +src/SLICOT-reference/src/SB02OY.f +src/SLICOT-reference/src/SB02PD.f +src/SLICOT-reference/src/SB02QD.f +src/SLICOT-reference/src/SB02RD.f +src/SLICOT-reference/src/SB02RU.f +src/SLICOT-reference/src/SB02SD.f +src/SLICOT-reference/src/SB03MD.f +src/SLICOT-reference/src/SB03MU.f +src/SLICOT-reference/src/SB03MV.f +src/SLICOT-reference/src/SB03MW.f +src/SLICOT-reference/src/SB03MX.f +src/SLICOT-reference/src/SB03MY.f +src/SLICOT-reference/src/SB03OD.f +src/SLICOT-reference/src/SB03OR.f +src/SLICOT-reference/src/SB03OT.f +src/SLICOT-reference/src/SB03OU.f +src/SLICOT-reference/src/SB03OV.f +src/SLICOT-reference/src/SB03OY.f +src/SLICOT-reference/src/SB03PD.f +src/SLICOT-reference/src/SB03QD.f +src/SLICOT-reference/src/SB03QX.f +src/SLICOT-reference/src/SB03QY.f +src/SLICOT-reference/src/SB03RD.f +src/SLICOT-reference/src/SB03SD.f +src/SLICOT-reference/src/SB03SX.f +src/SLICOT-reference/src/SB03SY.f +src/SLICOT-reference/src/SB03TD.f +src/SLICOT-reference/src/SB03UD.f +src/SLICOT-reference/src/SB04MD.f +src/SLICOT-reference/src/SB04MR.f +src/SLICOT-reference/src/SB04MU.f +src/SLICOT-reference/src/SB04MW.f +src/SLICOT-reference/src/SB04MY.f +src/SLICOT-reference/src/SB04ND.f +src/SLICOT-reference/src/SB04NV.f +src/SLICOT-reference/src/SB04NW.f +src/SLICOT-reference/src/SB04NX.f +src/SLICOT-reference/src/SB04NY.f +src/SLICOT-reference/src/SB04OD.f +src/SLICOT-reference/src/SB04OW.f +src/SLICOT-reference/src/SB04PD.f +src/SLICOT-reference/src/SB04PX.f +src/SLICOT-reference/src/SB04PY.f +src/SLICOT-reference/src/SB04QD.f +src/SLICOT-reference/src/SB04QR.f +src/SLICOT-reference/src/SB04QU.f +src/SLICOT-reference/src/SB04QY.f +src/SLICOT-reference/src/SB04RD.f +src/SLICOT-reference/src/SB04RV.f +src/SLICOT-reference/src/SB04RW.f +src/SLICOT-reference/src/SB04RX.f +src/SLICOT-reference/src/SB04RY.f +src/SLICOT-reference/src/SB06ND.f +src/SLICOT-reference/src/SB08CD.f +src/SLICOT-reference/src/SB08DD.f +src/SLICOT-reference/src/SB08ED.f +src/SLICOT-reference/src/SB08FD.f +src/SLICOT-reference/src/SB08GD.f +src/SLICOT-reference/src/SB08HD.f +src/SLICOT-reference/src/SB08MD.f +src/SLICOT-reference/src/SB08MY.f +src/SLICOT-reference/src/SB08ND.f +src/SLICOT-reference/src/SB08NY.f +src/SLICOT-reference/src/SB09MD.f +src/SLICOT-reference/src/SB10AD.f +src/SLICOT-reference/src/SB10DD.f +src/SLICOT-reference/src/SB10ED.f +src/SLICOT-reference/src/SB10FD.f +src/SLICOT-reference/src/SB10HD.f +src/SLICOT-reference/src/SB10ID.f +src/SLICOT-reference/src/SB10JD.f +src/SLICOT-reference/src/SB10KD.f +src/SLICOT-reference/src/SB10LD.f +src/SLICOT-reference/src/SB10MD.f +src/SLICOT-reference/src/SB10PD.f +src/SLICOT-reference/src/SB10QD.f +src/SLICOT-reference/src/SB10RD.f +src/SLICOT-reference/src/SB10SD.f +src/SLICOT-reference/src/SB10TD.f +src/SLICOT-reference/src/SB10UD.f +src/SLICOT-reference/src/SB10VD.f +src/SLICOT-reference/src/SB10WD.f +src/SLICOT-reference/src/SB10YD.f +src/SLICOT-reference/src/SB10ZD.f +src/SLICOT-reference/src/SB10ZP.f +src/SLICOT-reference/src/SB16AD.f +src/SLICOT-reference/src/SB16AY.f +src/SLICOT-reference/src/SB16BD.f +src/SLICOT-reference/src/SB16CD.f +src/SLICOT-reference/src/SB16CY.f +src/SLICOT-reference/src/SG02AD.f +src/SLICOT-reference/src/SG02CV.f +src/SLICOT-reference/src/SG02CW.f +src/SLICOT-reference/src/SG02CX.f +src/SLICOT-reference/src/SG02ND.f +src/SLICOT-reference/src/SG03AD.f +src/SLICOT-reference/src/SG03AX.f +src/SLICOT-reference/src/SG03AY.f +src/SLICOT-reference/src/SG03BD.f +src/SLICOT-reference/src/SG03BU.f +src/SLICOT-reference/src/SG03BV.f +src/SLICOT-reference/src/SG03BW.f +src/SLICOT-reference/src/SG03BX.f +src/SLICOT-reference/src/SG03BY.f +src/SLICOT-reference/src/TB01ID.f +src/SLICOT-reference/src/TB01IZ.f +src/SLICOT-reference/src/TB01KD.f +src/SLICOT-reference/src/TB01KX.f +src/SLICOT-reference/src/TB01LD.f +src/SLICOT-reference/src/TB01MD.f +src/SLICOT-reference/src/TB01ND.f +src/SLICOT-reference/src/TB01PD.f +src/SLICOT-reference/src/TB01PX.f +src/SLICOT-reference/src/TB01TD.f +src/SLICOT-reference/src/TB01TY.f +src/SLICOT-reference/src/TB01UD.f +src/SLICOT-reference/src/TB01UX.f +src/SLICOT-reference/src/TB01UY.f +src/SLICOT-reference/src/TB01VD.f +src/SLICOT-reference/src/TB01VY.f +src/SLICOT-reference/src/TB01WD.f +src/SLICOT-reference/src/TB01WX.f +src/SLICOT-reference/src/TB01XD.f +src/SLICOT-reference/src/TB01XZ.f +src/SLICOT-reference/src/TB01YD.f +src/SLICOT-reference/src/TB01ZD.f +src/SLICOT-reference/src/TB03AD.f +src/SLICOT-reference/src/TB03AY.f +src/SLICOT-reference/src/TB04AD.f +src/SLICOT-reference/src/TB04AY.f +src/SLICOT-reference/src/TB04BD.f +src/SLICOT-reference/src/TB04BV.f +src/SLICOT-reference/src/TB04BW.f +src/SLICOT-reference/src/TB04BX.f +src/SLICOT-reference/src/TB04CD.f +src/SLICOT-reference/src/TB05AD.f +src/SLICOT-reference/src/TC01OD.f +src/SLICOT-reference/src/TC04AD.f +src/SLICOT-reference/src/TC05AD.f +src/SLICOT-reference/src/TD03AD.f +src/SLICOT-reference/src/TD03AY.f +src/SLICOT-reference/src/TD04AD.f +src/SLICOT-reference/src/TD05AD.f +src/SLICOT-reference/src/TF01MD.f +src/SLICOT-reference/src/TF01MX.f +src/SLICOT-reference/src/TF01MY.f +src/SLICOT-reference/src/TF01ND.f +src/SLICOT-reference/src/TF01OD.f +src/SLICOT-reference/src/TF01PD.f +src/SLICOT-reference/src/TF01QD.f +src/SLICOT-reference/src/TF01RD.f +src/SLICOT-reference/src/TG01AD.f +src/SLICOT-reference/src/TG01AZ.f +src/SLICOT-reference/src/TG01BD.f +src/SLICOT-reference/src/TG01CD.f +src/SLICOT-reference/src/TG01DD.f +src/SLICOT-reference/src/TG01ED.f +src/SLICOT-reference/src/TG01FD.f +src/SLICOT-reference/src/TG01FZ.f +src/SLICOT-reference/src/TG01GD.f +src/SLICOT-reference/src/TG01HD.f +src/SLICOT-reference/src/TG01HU.f +src/SLICOT-reference/src/TG01HX.f +src/SLICOT-reference/src/TG01HY.f +src/SLICOT-reference/src/TG01ID.f +src/SLICOT-reference/src/TG01JD.f +src/SLICOT-reference/src/TG01JY.f +src/SLICOT-reference/src/TG01LD.f +src/SLICOT-reference/src/TG01LY.f +src/SLICOT-reference/src/TG01MD.f +src/SLICOT-reference/src/TG01ND.f +src/SLICOT-reference/src/TG01NX.f +src/SLICOT-reference/src/TG01PD.f +src/SLICOT-reference/src/TG01QD.f +src/SLICOT-reference/src/TG01WD.f +src/SLICOT-reference/src/UD01BD.f +src/SLICOT-reference/src/UD01CD.f +src/SLICOT-reference/src/UD01DD.f +src/SLICOT-reference/src/UD01MD.f +src/SLICOT-reference/src/UD01MZ.f +src/SLICOT-reference/src/UD01ND.f +src/SLICOT-reference/src/UE01MD.f + +src/SLICOT-reference/src/delctg.f +src/SLICOT-reference/src/select.f + +src/SLICOT-reference/src/SLCT_DLATZM.f +src/SLICOT-reference/src/SLCT_ZLATZM.f -set(FSOURCES - - src/AB01MD.f src/AB01ND.f src/AB01OD.f src/AB04MD.f src/AB05MD.f - src/AB05ND.f src/AB05OD.f src/AB05PD.f src/AB05QD.f src/AB05RD.f - src/AB05SD.f src/AB07MD.f src/AB07ND.f src/AB08MD.f src/AB08MZ.f - src/AB08ND.f src/AB08NX.f src/AB08NZ.f src/AB09AD.f src/AB09AX.f - src/AB09BD.f src/AB09BX.f src/AB09CD.f src/AB09CX.f src/AB09DD.f - src/AB09ED.f src/AB09FD.f src/AB09GD.f src/AB09HD.f src/AB09HX.f - src/AB09HY.f src/AB09ID.f src/AB09IX.f src/AB09IY.f src/AB09JD.f - src/AB09JV.f src/AB09JW.f src/AB09JX.f src/AB09KD.f src/AB09KX.f - src/AB09MD.f src/AB09ND.f src/AB13AD.f src/AB13AX.f src/AB13BD.f - src/AB13CD.f src/AB13DD.f src/AB13DX.f src/AB13ED.f src/AB13FD.f - src/AB13MD.f src/AB8NXZ.f src/AG07BD.f src/AG08BD.f src/AG08BY.f - src/AG08BZ.f src/AG8BYZ.f src/BB01AD.f src/BB02AD.f src/BB03AD.f - src/BB04AD.f src/BD01AD.f src/BD02AD.f src/DE01OD.f src/DE01PD.f - src/DF01MD.f src/DG01MD.f src/DG01ND.f src/DG01NY.f src/DG01OD.f - src/DK01MD.f src/FB01QD.f src/FB01RD.f src/FB01SD.f src/FB01TD.f - src/FB01VD.f src/FD01AD.f src/IB01AD.f src/IB01BD.f src/IB01CD.f - src/IB01MD.f src/IB01MY.f src/IB01ND.f src/IB01OD.f src/IB01OY.f - src/IB01PD.f src/IB01PX.f src/IB01PY.f src/IB01QD.f src/IB01RD.f - src/IB03AD.f src/IB03BD.f src/MA01AD.f src/MA02AD.f src/MA02BD.f - src/MA02BZ.f src/MA02CD.f src/MA02CZ.f src/MA02DD.f src/MA02ED.f - src/MA02FD.f src/MA02GD.f src/MA02HD.f src/MA02ID.f src/MA02JD.f - src/MB01MD.f src/MB01ND.f src/MB01PD.f src/MB01QD.f src/MB01RD.f - src/MB01RU.f src/MB01RW.f src/MB01RX.f src/MB01RY.f src/MB01SD.f - src/MB01TD.f src/MB01UD.f src/MB01UW.f src/MB01UX.f src/MB01VD.f - src/MB01WD.f src/MB01XD.f src/MB01XY.f src/MB01YD.f src/MB01ZD.f - src/MB02CD.f src/MB02CU.f src/MB02CV.f src/MB02CX.f src/MB02CY.f - src/MB02DD.f src/MB02ED.f src/MB02FD.f src/MB02GD.f src/MB02HD.f - src/MB02ID.f src/MB02JD.f src/MB02JX.f src/MB02KD.f src/MB02MD.f - src/MB02ND.f src/MB02NY.f src/MB02OD.f src/MB02PD.f src/MB02QD.f - src/MB02QY.f src/MB02RD.f src/MB02RZ.f src/MB02SD.f src/MB02SZ.f - src/MB02TD.f src/MB02TZ.f src/MB02UD.f src/MB02UU.f src/MB02UV.f - src/MB02VD.f src/MB02WD.f src/MB02XD.f src/MB02YD.f src/MB03MD.f - src/MB03MY.f src/MB03ND.f src/MB03NY.f src/MB03OD.f src/MB03OY.f - src/MB03PD.f src/MB03PY.f src/MB03QD.f src/MB03QX.f src/MB03QY.f - src/MB03RD.f src/MB03RX.f src/MB03RY.f src/MB03SD.f src/MB03TD.f - src/MB03TS.f src/MB03UD.f src/MB03VD.f src/MB03VY.f src/MB03WA.f - src/MB03WD.f src/MB03WX.f src/MB03XD.f src/MB03XP.f src/MB03XU.f - src/MB03YA.f src/MB03YD.f src/MB03YT.f src/MB03ZA.f src/MB03ZD.f - src/MB04DD.f src/MB04DI.f src/MB04DS.f src/MB04DY.f src/MB04GD.f - src/MB04ID.f src/MB04IY.f src/MB04IZ.f src/MB04JD.f src/MB04KD.f - src/MB04LD.f src/MB04MD.f src/MB04ND.f src/MB04NY.f src/MB04OD.f - src/MB04OW.f src/MB04OX.f src/MB04OY.f src/MB04PA.f src/MB04PB.f - src/MB04PU.f src/MB04PY.f src/MB04QB.f src/MB04QC.f src/MB04QF.f - src/MB04QU.f src/MB04TB.f src/MB04TS.f src/MB04TT.f src/MB04TU.f - src/MB04TV.f src/MB04TW.f src/MB04TX.f src/MB04TY.f src/MB04UD.f - src/MB04VD.f src/MB04VX.f src/MB04WD.f src/MB04WP.f src/MB04WR.f - src/MB04WU.f src/MB04XD.f src/MB04XY.f src/MB04YD.f src/MB04YW.f - src/MB04ZD.f src/MB05MD.f src/MB05MY.f src/MB05ND.f src/MB05OD.f - src/MB05OY.f src/MB3OYZ.f src/MB3PYZ.f src/MC01MD.f src/MC01ND.f - src/MC01OD.f src/MC01PD.f src/MC01PY.f src/MC01QD.f src/MC01RD.f - src/MC01SD.f src/MC01SW.f src/MC01SX.f src/MC01SY.f src/MC01TD.f - src/MC01VD.f src/MC01WD.f src/MC03MD.f src/MC03ND.f src/MC03NX.f - src/MC03NY.f src/MD03AD.f src/MD03BA.f src/MD03BB.f src/MD03BD.f - src/MD03BF.f src/MD03BX.f src/MD03BY.f src/NF01AD.f src/NF01AY.f - src/NF01BA.f src/NF01BB.f src/NF01BD.f src/NF01BE.f src/NF01BF.f - src/NF01BP.f src/NF01BQ.f src/NF01BR.f src/NF01BS.f src/NF01BU.f - src/NF01BV.f src/NF01BW.f src/NF01BX.f src/NF01BY.f src/SB01BD.f - src/SB01BX.f src/SB01BY.f src/SB01DD.f src/SB01FY.f src/SB01MD.f - src/SB02CX.f src/SB02MD.f src/SB02MR.f src/SB02MS.f src/SB02MT.f - src/SB02MU.f src/SB02MV.f src/SB02MW.f src/SB02ND.f src/SB02OD.f - src/SB02OU.f src/SB02OV.f src/SB02OW.f src/SB02OX.f src/SB02OY.f - src/SB02PD.f src/SB02QD.f src/SB02RD.f src/SB02RU.f src/SB02SD.f - src/SB03MD.f src/SB03MU.f src/SB03MV.f src/SB03MW.f src/SB03MX.f - src/SB03MY.f src/SB03OD.f src/SB03OR.f src/SB03OT.f src/SB03OU.f - src/SB03OV.f src/SB03OY.f src/SB03PD.f src/SB03QD.f src/SB03QX.f - src/SB03QY.f src/SB03RD.f src/SB03SD.f src/SB03SX.f src/SB03SY.f - src/SB03TD.f src/SB03UD.f src/SB04MD.f src/SB04MR.f src/SB04MU.f - src/SB04MW.f src/SB04MY.f src/SB04ND.f src/SB04NV.f src/SB04NW.f - src/SB04NX.f src/SB04NY.f src/SB04OD.f src/SB04OW.f src/SB04PD.f - src/SB04PX.f src/SB04PY.f src/SB04QD.f src/SB04QR.f src/SB04QU.f - src/SB04QY.f src/SB04RD.f src/SB04RV.f src/SB04RW.f src/SB04RX.f - src/SB04RY.f src/SB06ND.f src/SB08CD.f src/SB08DD.f src/SB08ED.f - src/SB08FD.f src/SB08GD.f src/SB08HD.f src/SB08MD.f src/SB08MY.f - src/SB08ND.f src/SB08NY.f src/SB09MD.f src/SB10AD.f src/SB10DD.f - src/SB10ED.f src/SB10FD.f src/SB10HD.f src/SB10ID.f src/SB10JD.f - src/SB10KD.f src/SB10LD.f src/SB10MD.f src/SB10PD.f src/SB10QD.f - src/SB10RD.f src/SB10SD.f src/SB10TD.f src/SB10UD.f src/SB10VD.f - src/SB10WD.f src/SB10YD.f src/SB10ZD.f src/SB10ZP.f src/SB16AD.f - src/SB16AY.f src/SB16BD.f src/SB16CD.f src/SB16CY.f src/SG02AD.f - src/SG03AD.f src/SG03AX.f src/SG03AY.f src/SG03BD.f src/SG03BU.f - src/SG03BV.f src/SG03BW.f src/SG03BX.f src/SG03BY.f src/TB01ID.f - src/TB01IZ.f src/TB01KD.f src/TB01LD.f src/TB01MD.f src/TB01ND.f - src/TB01PD.f src/TB01TD.f src/TB01TY.f src/TB01UD.f src/TB01VD.f - src/TB01VY.f src/TB01WD.f src/TB01XD.f src/TB01XZ.f src/TB01YD.f - src/TB01ZD.f src/TB03AD.f src/TB03AY.f src/TB04AD.f src/TB04AY.f - src/TB04BD.f src/TB04BV.f src/TB04BW.f src/TB04BX.f src/TB04CD.f - src/TB05AD.f src/TC01OD.f src/TC04AD.f src/TC05AD.f src/TD03AD.f - src/TD03AY.f src/TD04AD.f src/TD05AD.f src/TF01MD.f src/TF01MX.f - src/TF01MY.f src/TF01ND.f src/TF01OD.f src/TF01PD.f src/TF01QD.f - src/TF01RD.f src/TG01AD.f src/TG01AZ.f src/TG01BD.f src/TG01CD.f - src/TG01DD.f src/TG01ED.f src/TG01FD.f src/TG01FZ.f src/TG01HD.f - src/TG01HX.f src/TG01ID.f src/TG01JD.f src/TG01WD.f src/UD01BD.f - src/UD01CD.f src/UD01DD.f src/UD01MD.f src/UD01MZ.f src/UD01ND.f - src/UE01MD.f - - src/delctg.f src/select.f - src/SLCT_DLATZM.f src/SLCT_ZLATZM.f - - src/ftruefalse.f src/XERBLA.f ) +set(SLYCOT_FSOURCE src/ftruefalse.f src/XERBLA.f) + set(F2PYSOURCE src/_wrapper.pyf) set(F2PYSOURCE_DEPS src/analysis.pyf src/math.pyf @@ -129,7 +628,7 @@ set(GENERATED_MODULE set(CMAKE_Fortran_FLAGS ) -add_custom_target(wrapper ALL DEPENDS ${FSOURCES}) +add_custom_target(wrapper ALL DEPENDS ${SLICOT_FSOURCE} ${SLYCOT_FSOURCE}) add_custom_command( OUTPUT _wrappermodule.c _wrapper-f2pywrappers.f COMMAND ${F2PY_EXECUTABLE} -m SLYCOT @@ -142,7 +641,7 @@ add_library( _wrappermodule.c ${F2PY_INCLUDE_DIR}/fortranobject.c _wrapper-f2pywrappers.f - ${FSOURCES}) + ${SLICOT_FSOURCE} ${SLYCOT_FSOURCE}) target_link_libraries(${SLYCOT_MODULE} ${LAPACK_LIBRARIES}) diff --git a/slycot/src/AB01MD.f b/slycot/src/AB01MD.f deleted file mode 100644 index d00d02a8..00000000 --- a/slycot/src/AB01MD.f +++ /dev/null @@ -1,402 +0,0 @@ - SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C single-input system -C -C dX/dt = A * X + B * U, -C -C where A is an N-by-N matrix and B is an N element vector which -C are reduced by this routine to orthogonal canonical form using -C (and optionally accumulating) orthogonal similarity -C transformations. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT upper Hessenberg -C part of this array contains the canonical form of the -C state dynamics matrix, given by Z' * A * Z, of a -C controllable realization for the original system. The -C elements below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, the original input/state vector B. -C On exit, the leading NCONT elements of this array contain -C canonical form of the input/state vector, given by Z' * B, -C with all elements but B(1) set to zero. -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this array -C contains the matrix of accumulated orthogonal similarity -C transformations which reduces the given system to -C orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of (A,B). If the user sets TOL > 0, then -C the given value of TOL is used as an absolute tolerance; -C elements with absolute value less than TOL are considered -C neglijible. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by -C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder matrix which reduces all but the first element -C of vector B to zero is found and this orthogonal similarity -C transformation is applied to the matrix A. The resulting A is then -C reduced to upper Hessenberg form by a sequence of Householder -C transformations. Finally, the order of the controllable state- -C space representation (NCONT) is determined by finding the position -C of the first sub-diagonal element of A which is below an -C appropriate zero threshold, either TOL or TOLDEF (see parameter -C TOL); if NORM(B) is smaller than this threshold, NCONT is set to -C zero, and no computations for reducing the system to orthogonal -C canonical form are performed. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Hammarling, S.J. -C Notes on the use of orthogonal similarity transformations in -C control. -C NPL Report DITC 8/82, August 1982. -C -C [3] Paige, C.C -C Properties of numerical algorithms related to computing -C controllability. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. -C Supersedes Release 2.0 routine AB01AD by T.W.C. Williams, -C Kingston Polytechnic, United Kingdom, October 1982. -C -C REVISIONS -C -C V. Sima, February 16, 1998, October 19, 2001, February 2, 2005. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INFO, LDA, LDZ, LDWORK, N, NCONT - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), TAU(*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER ITAU, J - DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, - $ TOLDEF, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION NBLK(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, - $ MB01PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX(1,N) ) THEN - INFO = -4 - ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. - $ LJOBZ .AND. LDZ.LT.MAX(1,N) ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NCONT = 0 - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = ONE -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'M', N, 1, B, N, DWORK ) -C -C Return if matrix B is zero. -C - IF( BNORM.EQ.ZERO ) THEN - IF( LJOBF ) THEN - CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) - END IF - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) - CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) -C -C Calculate the Frobenius norm of A and the 1-norm of B (used for -C controlability test). -C - FANORM = DLANGE( 'F', N, N, A, LDA, DWORK ) - FBNORM = DLANGE( '1', N, 1, B, N, DWORK ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) - TOLDEF = THRESH*MAX( FANORM, FBNORM ) - END IF -C - ITAU = 1 - IF ( FBNORM.GT.TOLDEF ) THEN -C -C B is not negligible compared with A. -C - IF ( N.GT.1 ) THEN -C -C Transform B by a Householder matrix Z1: store vector -C describing this temporarily in B and in the local scalar H. -C - CALL DLARFG( N, B(1), B(2), 1, H ) -C - B1 = B(1) - B(1) = ONE -C -C Form Z1 * A * Z1. -C - CALL DLARF( 'R', N, N, B, 1, H, A, LDA, DWORK ) - CALL DLARF( 'L', N, N, B, 1, H, A, LDA, DWORK ) -C - B(1) = B1 - TAU(1) = H - ITAU = ITAU + 1 - ELSE - B1 = B(1) - END IF -C -C Reduce modified A to upper Hessenberg form by an orthogonal -C similarity transformation with matrix Z2. -C Workspace: need N; prefer N*NB. -C - CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) - WRKOPT = DWORK(1) -C - IF ( LJOBZ ) THEN -C -C Save the orthogonal transformations used, so that they could -C be accumulated by calling DORGQR routine. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'F', N-1, 1, B(2), N-1, Z(2,1), LDZ ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'L', N-2, N-2, A(3,1), LDA, Z(3,2), LDZ ) - IF ( LJOBI ) THEN -C -C Form the orthogonal transformation matrix Z = Z1 * Z2. -C Workspace: need N; prefer N*NB. -C - CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C -C Annihilate the lower part of A and B. -C - IF ( N.GT.2 ) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'F', N-1, 1, ZERO, ZERO, B(2), N-1 ) -C -C Find NCONT by checking sizes of the sub-diagonal elements of -C transformed A. -C - IF ( TOL.LE.ZERO ) TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) -C - J = 1 -C -C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO -C - 10 CONTINUE - IF ( J.LT.N ) THEN - IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN - J = J + 1 - GO TO 10 - END IF - END IF -C -C END WHILE 10 -C -C First negligible sub-diagonal element found, if any: set NCONT. -C - NCONT = J - IF ( J.LT.N ) A(J+1,J) = ZERO -C -C Undo scaling of A and B. -C - CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, - $ LDA, INFO ) - CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - IF ( NCONT.LT.N ) - $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, - $ A(1,NCONT+1), LDA, INFO ) - ELSE -C -C B is negligible compared with A. No computations for reducing -C the system to orthogonal canonical form have been performed, -C except scaling (which is undoed). -C - IF( LJOBF ) THEN - CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) - END IF - CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB01MD *** - END diff --git a/slycot/src/AB01ND.f b/slycot/src/AB01ND.f deleted file mode 100644 index c6280fcb..00000000 --- a/slycot/src/AB01ND.f +++ /dev/null @@ -1,470 +0,0 @@ - SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, - $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C multi-input system -C -C dX/dt = A * X + B * U, -C -C where A and B are N-by-N and N-by-M matrices, respectively, -C which are reduced by this routine to orthogonal canonical form -C using (and optionally accumulating) orthogonal similarity -C transformations. Specifically, the pair (A, B) is reduced to -C the pair (Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B, given by -C -C [ Acont * ] [ Bcont ] -C Ac = [ ], Bc = [ ], -C [ 0 Auncont ] [ 0 ] -C -C and -C -C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] -C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] -C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] -C Acont = [ . . . . . . . ], Bc = [ . ], -C [ . . . . . . ] [ . ] -C [ . . . . . ] [ . ] -C [ 0 0 . . . Ap,p-1 App ] [ 0 ] -C -C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and -C p is the controllability index of the pair. The size of the -C block Auncont is equal to the dimension of the uncontrollable -C subspace of the pair (A, B). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT part contains the -C upper block Hessenberg state dynamics matrix Acont in Ac, -C given by Z' * A * Z, of a controllable realization for -C the original system. The elements below the first block- -C subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading NCONT-by-M part of this array -C contains the transformed input matrix Bcont in Bc, given -C by Z' * B, with all elements but the first block set to -C zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C INDCON (output) INTEGER -C The controllability index of the controllable part of the -C system representation. -C -C NBLK (output) INTEGER array, dimension (N) -C The leading INDCON elements of this array contain the -C the orders of the diagonal blocks of Acont. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this -C array contains the matrix of accumulated orthogonal -C similarity transformations which reduces the given system -C to orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N, 3*M). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Matrix B is first QR-decomposed and the appropriate orthogonal -C similarity transformation applied to the matrix A. Leaving the -C first rank(B) states unchanged, the remaining lower left block -C of A is then QR-decomposed and the new orthogonal matrix, Q1, -C is also applied to the right of A to complete the similarity -C transformation. By continuing in this manner, a completely -C controllable state-space pair (Acont, Bcont) is found for the -C given (A, B), where Acont is upper block Hessenberg with each -C subdiagonal block of full row rank, and Bcont is zero apart from -C its (independent) first rank(B) rows. -C NOTE that the system controllability indices are easily -C calculated from the dimensions of the blocks of Acont. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Paige, C.C. -C Properties of numerical algorithms related to computing -C controllablity. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and -C Postlethwaite, I. -C Optimal Pole Assignment Design of Linear Multi-Input Systems. -C Leicester University, Report 99-11, May 1996. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C If the system matrices A and B are badly scaled, it would be -C useful to scale them with SLICOT routine TB01ID, before calling -C the routine. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB01BD by P.Hr. Petkov. -C -C REVISIONS -C -C January 14, 1997, June 4, 1997, February 13, 1998, -C September 22, 2003, February 29, 2004. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INDCON, INFO, LDA, LDB, LDWORK, LDZ, M, N, NCONT - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), Z(LDZ,*) - INTEGER IWORK(*), NBLK(*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, - $ WRKOPT - DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, - $ MB01PD, MB03OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.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( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, N, 3*M ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB01ND', -INFO ) - RETURN - END IF -C - NCONT = 0 - INDCON = 0 -C -C Quick return if possible. -C - IF ( MIN( N, M ).EQ.0 ) THEN - IF( N.GT.0 ) THEN - IF ( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - ELSE IF ( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - END IF - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) -C -C Return if matrix B is zero. -C - IF( BNORM.EQ.ZERO ) THEN - IF ( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - ELSE IF ( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'Scale', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'Scale', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, - $ INFO ) -C -C Compute the Frobenius norm of [ B A ] (used for rank estimation). -C - FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), - $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) - END IF -C - WRKOPT = 1 - NI = 0 - ITAU = 1 - NCRT = N - MCRT = M - IQR = 1 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - 10 CONTINUE -C -C Rank-revealing QR decomposition with column pivoting. -C The calculation is performed in NCRT rows of B starting from -C the row IQR (initialized to 1 and then set to rank(B)+1). -C Workspace: 3*MCRT. -C - CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, - $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) -C - IF ( RANK.NE.0 ) THEN - NJ = NI - NI = NCONT - NCONT = NCONT + RANK - INDCON = INDCON + 1 - NBLK(INDCON) = RANK -C -C Premultiply and postmultiply the appropriate block row -C and block column of A by Q' and Q, respectively. -C Workspace: need NCRT; -C prefer NCRT*NB. -C - CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Workspace: need N; -C prefer N*NB. -C - CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C If required, save transformations. -C - IF ( LJOBZ.AND.NCRT.GT.1 ) THEN - CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), - $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) - END IF -C -C Zero the subdiagonal elements of the current matrix. -C - IF ( RANK.GT.1 ) - $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), - $ LDB ) -C -C Backward permutation of the columns of B or A. -C - IF ( INDCON.EQ.1 ) THEN - CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) - IQR = RANK + 1 - ELSE - DO 20 J = 1, MCRT - CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), - $ 1 ) - 20 CONTINUE - END IF -C - ITAU = ITAU + RANK - IF ( RANK.NE.NCRT ) THEN - MCRT = RANK - NCRT = NCRT - RANK - CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, - $ B(IQR,1), LDB ) - CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, - $ A(NCONT+1,NI+1), LDA ) - GO TO 10 - END IF - END IF -C -C If required, accumulate transformations. -C Workspace: need N; prefer N*NB. -C - IF ( LJOBI ) THEN - CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C -C Annihilate the trailing blocks of B. -C - IF ( N.GE.IQR ) - $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) -C -C Annihilate the trailing elements of TAU, if JOBZ = 'F'. -C - IF ( LJOBF ) THEN - DO 30 J = ITAU, N - TAU(J) = ZERO - 30 CONTINUE - END IF -C -C Undo scaling of A and B. -C - IF ( INDCON.LT.N ) THEN - NBL = INDCON + 1 - NBLK(NBL) = N - NCONT - ELSE - NBL = 0 - END IF - CALL MB01PD( 'Undo', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, - $ LDA, INFO ) - CALL MB01PD( 'Undo', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, - $ LDB, INFO ) -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB01ND *** - END diff --git a/slycot/src/AB01OD.f b/slycot/src/AB01OD.f deleted file mode 100644 index f85ed562..00000000 --- a/slycot/src/AB01OD.f +++ /dev/null @@ -1,535 +0,0 @@ - SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, - $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices A and B using (and optionally accumulating) -C state-space and input-space transformations U and V respectively, -C such that the pair of matrices -C -C Ac = U' * A * U, Bc = U' * B * V -C -C are in upper "staircase" form. Specifically, -C -C [ Acont * ] [ Bcont ] -C Ac = [ ], Bc = [ ], -C [ 0 Auncont ] [ 0 ] -C -C and -C -C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] -C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] -C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] -C Acont = [ . . . . . . . ], Bc = [ . ], -C [ . . . . . . ] [ . ] -C [ . . . . . ] [ . ] -C [ 0 0 . . . Ap,p-1 App ] [ 0 ] -C -C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and -C p is the controllability index of the pair. The size of the -C block Auncont is equal to the dimension of the uncontrollable -C subspace of the pair (A, B). The first stage of the reduction, -C the "forward" stage, accomplishes the reduction to the orthogonal -C canonical form (see SLICOT library routine AB01ND). The blocks -C B1, A21, ..., Ap,p-1 are further reduced in a second, "backward" -C stage to upper triangular form using RQ factorization. Each of -C these stages is optional. -C -C ARGUMENTS -C -C Mode Parameters -C -C STAGES CHARACTER*1 -C Specifies the reduction stages to be performed as follows: -C = 'F': Perform the forward stage only; -C = 'B': Perform the backward stage only; -C = 'A': Perform both (all) stages. -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the state-space transformations as follows: -C = 'N': Do not form U; -C = 'I': U is internally initialized to the unit matrix (if -C STAGES <> 'B'), or updated (if STAGES = 'B'), and -C the orthogonal transformation matrix U is -C returned. -C -C JOBV CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix V the input-space transformations as follows: -C = 'N': Do not form V; -C = 'I': V is initialized to the unit matrix and the -C orthogonal transformation matrix V is returned. -C JOBV is not referenced if STAGES = 'F'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The actual input dimension. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A to be transformed. -C If STAGES = 'B', A should be in the orthogonal canonical -C form, as returned by SLICOT library routine AB01ND. -C On exit, the leading N-by-N part of this array contains -C the transformed state transition matrix U' * A * U. -C The leading NCONT-by-NCONT part contains the upper block -C Hessenberg state matrix Acont in Ac, given by U' * A * U, -C of a controllable realization for the original system. -C The elements below the first block-subdiagonal are set to -C zero. If STAGES <> 'F', the subdiagonal blocks of A are -C triangularized by RQ factorization, and the annihilated -C elements are explicitly zeroed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B to be transformed. -C If STAGES = 'B', B should be in the orthogonal canonical -C form, as returned by SLICOT library routine AB01ND. -C On exit with STAGES = 'F', the leading N-by-M part of -C this array contains the transformed input matrix U' * B, -C with all elements but the first block set to zero. -C On exit with STAGES <> 'F', the leading N-by-M part of -C this array contains the transformed input matrix -C U' * B * V, with all elements but the first block set to -C zero and the first block in upper triangular form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C If STAGES <> 'B' or JOBU = 'N', then U need not be set -C on entry. -C If STAGES = 'B' and JOBU = 'I', then, on entry, the -C leading N-by-N part of this array must contain the -C transformation matrix U that reduced the pair to the -C orthogonal canonical form. -C On exit, if JOBU = 'I', the leading N-by-N part of this -C array contains the transformation matrix U that performed -C the specified reduction. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. -C If JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,M) -C If JOBV = 'I', then the leading M-by-M part of this array -C contains the transformation matrix V. -C If STAGES = 'F', or JOBV = 'N', the array V is not -C referenced and can be supplied as a dummy array (i.e. set -C parameter LDV = 1 and declare this array to be V(1,1) in -C the calling program). -C -C LDV INTEGER -C The leading dimension of array V. -C If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M); -C if STAGES = 'F' or JOBV = 'N', LDV >= 1. -C -C NCONT (input/output) INTEGER -C The order of the controllable state-space representation. -C NCONT is input only if STAGES = 'B'. -C -C INDCON (input/output) INTEGER -C The number of stairs in the staircase form (also, the -C controllability index of the controllable part of the -C system representation). -C INDCON is input only if STAGES = 'B'. -C -C KSTAIR (input/output) INTEGER array, dimension (N) -C The leading INDCON elements of this array contain the -C dimensions of the stairs, or, also, the orders of the -C diagonal blocks of Acont. -C KSTAIR is input if STAGES = 'B', and output otherwise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). -C TOL is not referenced if STAGES = 'B'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C IWORK is not referenced if STAGES = 'B'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M)); -C If STAGES = 'B', LDWORK >= MAX(1, M + MAX(N,M)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Staircase reduction of the pencil [B|sI - A] is used. Orthogonal -C transformations U and V are constructed such that -C -C -C |B |sI-A * . . . * * | -C | 1| 11 . . . | -C | | A sI-A . . . | -C | | 21 22 . . . | -C | | . . * * | -C [U'BV|sI - U'AU] = |0 | 0 . . | -C | | A sI-A * | -C | | p,p-1 pp | -C | | | -C |0 | 0 0 sI-A | -C | | p+1,p+1| -C -C -C where the i-th diagonal block of U'AU has dimension KSTAIR(i), -C for i = 1,...,p. The value of p is returned in INDCON. The last -C block contains the uncontrollable modes of the (A,B)-pair which -C are also the generalized eigenvalues of the above pencil. -C -C The complete reduction is performed in two stages. The first, -C forward stage accomplishes the reduction to the orthogonal -C canonical form. The second, backward stage consists in further -C reduction to triangular form by applying left and right orthogonal -C transformations. -C -C REFERENCES -C -C [1] Van Dooren, P. -C The generalized eigenvalue problem in linear system theory. -C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. -C -C [2] Miminis, G. and Paige, C. -C An algorithm for pole assignment of time-invariant multi-input -C linear systems. -C Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + M) x N**2) operations and is -C backward stable (see [1]). -C -C FURTHER COMMENTS -C -C If the system matrices A and B are badly scaled, it would be -C useful to scale them with SLICOT routine TB01ID, before calling -C the routine. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB01CD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C January 14, 1997, February 12, 1998, September 22, 2003. -C -C KEYWORDS -C -C Controllability, generalized eigenvalue problem, orthogonal -C transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV, STAGES - INTEGER INDCON, INFO, LDA, LDB, LDU, LDV, LDWORK, M, N, - $ NCONT - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*), KSTAIR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - LOGICAL LJOBUI, LJOBVI, LSTAGB, LSTGAB - INTEGER I, I0, IBSTEP, ITAU, J0, JINI, JWORK, MCRT, MM, - $ NCRT, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB01ND, DGERQF, DLACPY, DLASET, DORGRQ, DORMRQ, - $ DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LJOBUI = LSAME( JOBU, 'I' ) -C - LSTAGB = LSAME( STAGES, 'B' ) - LSTGAB = LSAME( STAGES, 'A' ).OR.LSTAGB -C - IF ( LSTGAB ) THEN - LJOBVI = LSAME( JOBV, 'I' ) - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LSTGAB .AND. .NOT.LSAME( STAGES, 'F' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBUI .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.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( LDU.LT.1 .OR. ( LJOBUI .AND. LDU.LT.N ) ) THEN - INFO = -11 - ELSE IF( .NOT.LSTAGB .AND. LDWORK.LT.MAX( 1, N + MAX( N, 3*M ) ) - $ .OR. LSTAGB .AND. LDWORK.LT.MAX( 1, M + MAX( N, M ) ) ) - $ THEN - INFO = -20 - ELSE IF( LSTAGB .AND. NCONT.GT.N ) THEN - INFO = -14 - ELSE IF( LSTAGB .AND. INDCON.GT.N ) THEN - INFO = -15 - ELSE IF( LSTGAB ) THEN - IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -3 - ELSE IF( LDV.LT.1 .OR. ( LJOBVI .AND. LDV.LT.M ) ) THEN - INFO = -13 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( N, M ).EQ.0 ) THEN - NCONT = 0 - INDCON = 0 - IF( N.GT.0 .AND. LJOBUI ) - $ CALL DLASET( 'F', N, N, ZERO, ONE, U, LDU ) - IF( LSTGAB ) THEN - IF( M.GT.0 .AND. LJOBVI ) - $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) - END IF - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - ITAU = 1 - WRKOPT = 1 -C - IF ( .NOT.LSTAGB ) THEN -C -C Perform the forward stage computations of the staircase -C algorithm on B and A: reduce the (A, B) pair to orthogonal -C canonical form. -C -C Workspace: N + MAX(N,3*M). -C - JWORK = N + 1 - CALL AB01ND( JOBU, N, M, A, LDA, B, LDB, NCONT, INDCON, - $ KSTAIR, U, LDU, DWORK(ITAU), TOL, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 - END IF -C -C Exit if no further reduction to triangularize B1 and subdiagonal -C blocks of A is required, or if the order of the controllable part -C is 0. -C - IF ( .NOT.LSTGAB ) THEN - DWORK(1) = WRKOPT - RETURN - ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN - IF( LJOBVI ) - $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) - DWORK(1) = WRKOPT - RETURN - END IF -C -C Now perform the backward steps except the last one. -C - MCRT = KSTAIR(INDCON) - I0 = NCONT - MCRT + 1 - JWORK = M + 1 -C - DO 10 IBSTEP = INDCON, 2, -1 - NCRT = KSTAIR(IBSTEP-1) - J0 = I0 - NCRT - MM = MIN( NCRT, MCRT ) -C -C Compute the RQ factorization of the current subdiagonal block -C of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension -C MCRT-by-NCRT, starting in position (I0,J0). -C The matrix Q' should postmultiply U, if required. -C Workspace: need M + MCRT; -C prefer M + MCRT*NB. -C - CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Set JINI to the first column number in A where the current -C transformation Q is to be applied, taking the block Hessenberg -C form into account. -C - IF ( IBSTEP.GT.2 ) THEN - JINI = J0 - KSTAIR(IBSTEP-2) - ELSE - JINI = 1 -C -C Premultiply the first block row (B1) of B by Q. -C Workspace: need 2*M; -C prefer M + M*NB. -C - CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0), - $ LDA, DWORK(ITAU), B, LDB, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - END IF -C -C Premultiply the appropriate block row of A by Q. -C Workspace: need M + N; -C prefer M + N*NB. -C - CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM, - $ A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Postmultiply the appropriate block column of A by Q'. -C Workspace: need M + I0-1; -C prefer M + (I0-1)*NB. -C - CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0), - $ LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LJOBUI ) THEN -C -C Update U, postmultiplying it by Q'. -C Workspace: need M + N; -C prefer M + N*NB. -C - CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0), - $ LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - END IF -C -C Zero the subdiagonal elements of the current subdiagonal block -C of A. -C - CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA ) - IF ( I0.LT.N ) - $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, - $ A(I0+1,I0-MCRT), LDA ) -C - MCRT = NCRT - I0 = J0 -C - 10 CONTINUE -C -C Now perform the last backward step on B, V = Qb'. -C -C Compute the RQ factorization of the first block of B, B1 = R*Qb. -C Workspace: need M + MCRT; -C prefer M + MCRT*NB. -C - CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LJOBVI ) THEN -C -C Accumulate the input-space transformations V. -C Workspace: need 2*M; prefer M + M*NB. -C - CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV ) - IF ( MCRT.GT.1 ) - $ CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB, - $ V(M-MCRT+2,M-MCRT+1), LDV ) - CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C - DO 20 I = 2, M - CALL DSWAP( I-1, V(I,1), LDV, V(1,I), 1 ) - 20 CONTINUE -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - END IF -C -C Zero the subdiagonal elements of the submatrix B1. -C - CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB ) - IF ( MCRT.GT.1 ) - $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1), - $ LDB ) -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB01OD *** - END diff --git a/slycot/src/AB04MD.f b/slycot/src/AB04MD.f deleted file mode 100644 index b5856fcd..00000000 --- a/slycot/src/AB04MD.f +++ /dev/null @@ -1,345 +0,0 @@ - SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C, - $ LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform a transformation on the parameters (A,B,C,D) of a -C system, which is equivalent to a bilinear transformation of the -C corresponding transfer function matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C Indicates the type of the original system and the -C transformation to be performed as follows: -C = 'D': discrete-time -> continuous-time; -C = 'C': continuous-time -> discrete-time. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C ALPHA, (input) DOUBLE PRECISION -C BETA Parameters specifying the bilinear transformation. -C Recommended values for stable systems: ALPHA = 1, -C BETA = 1. ALPHA <> 0, BETA <> 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state matrix A of the original system. -C On exit, the leading N-by-N part of this array contains -C _ -C the state matrix A of the transformed system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the original system. -C On exit, the leading N-by-M part of this array contains -C _ -C the input matrix B of the transformed system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C of the original system. -C On exit, the leading P-by-N part of this array contains -C _ -C the output matrix C of the transformed system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix D for the original system. -C On exit, the leading P-by-M part of this array contains -C _ -C the input/output matrix D of the transformed system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK >= MAX(1,N*NB), where NB -C is the optimal blocksize. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix (ALPHA*I + A) is exactly singular; -C = 2: if the matrix (BETA*I - A) is exactly singular. -C -C METHOD -C -C The parameters of the discrete-time system are transformed into -C the parameters of the continuous-time system (TYPE = 'D'), or -C vice-versa (TYPE = 'C') by the transformation: -C -C 1. Discrete -> continuous -C _ -1 -C A = beta*(alpha*I + A) * (A - alpha*I) -C _ -1 -C B = sqrt(2*alpha*beta) * (alpha*I + A) * B -C _ -1 -C C = sqrt(2*alpha*beta) * C * (alpha*I + A) -C _ -1 -C D = D - C * (alpha*I + A) * B -C -C which is equivalent to the bilinear transformation -C -C z - alpha -C z -> s = beta --------- . -C z + alpha -C -C of one transfer matrix onto the other. -C -C 2. Continuous -> discrete -C _ -1 -C A = alpha*(beta*I - A) * (beta*I + A) -C _ -1 -C B = sqrt(2*alpha*beta) * (beta*I - A) * B -C _ -1 -C C = sqrt(2*alpha*beta) * C * (beta*I - A) -C _ -1 -C D = D + C * (beta*I - A) * B -C -C which is equivalent to the bilinear transformation -C -C beta + s -C s -> z = alpha -------- . -C beta - s -C -C of one transfer matrix onto the other. -C -C REFERENCES -C -C [1] Al-Saggaf, U.M. and Franklin, G.F. -C Model reduction via balanced realizations: a extension and -C frequency weighting techniques. -C IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The time taken is approximately proportional to N . -C The accuracy depends mainly on the condition number of the matrix -C to be inverted. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, Nov. 1996. -C Supersedes Release 2.0 routine AB04AD by W. van der Linden, and -C A.J. Geurts, Technische Hogeschool Eindhoven, Holland. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bilinear transformation, continuous-time system, discrete-time -C system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LTYPE - INTEGER I, IP - DOUBLE PRECISION AB2, PALPHA, PBETA, SQRAB2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL, - $ DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Executable Statements .. -C - INFO = 0 - LTYPE = LSAME( TYPE, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( ALPHA.EQ.ZERO ) THEN - INFO = -5 - ELSE IF( BETA.EQ.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB04MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) - $ RETURN -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF (LTYPE) THEN -C -C Discrete-time to continuous-time with (ALPHA, BETA). -C - PALPHA = ALPHA - PBETA = BETA - ELSE -C -C Continuous-time to discrete-time with (ALPHA, BETA) is -C equivalent with discrete-time to continuous-time with -C (-BETA, -ALPHA), if B and C change the sign. -C - PALPHA = -BETA - PBETA = -ALPHA - END IF -C - AB2 = PALPHA*PBETA*TWO - SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA ) -C -1 -C Compute (alpha*I + A) . -C - DO 10 I = 1, N - A(I,I) = A(I,I) + PALPHA - 10 CONTINUE -C - CALL DGETRF( N, N, A, LDA, IWORK, INFO ) -C - IF (INFO.NE.0) THEN -C -C Error return. -C - IF (LTYPE) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C -1 -C Compute (alpha*I+A) *B. -C - CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO ) -C -1 -C Compute D - C*(alpha*I+A) *B. -C - CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C, - $ LDC, B, LDB, ONE, D, LDD ) -C -C Scale B by sqrt(2*alpha*beta). -C - CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO ) -C -1 -C Compute sqrt(2*alpha*beta)*C*(alpha*I + A) . -C - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N, - $ SQRAB2, A, LDA, C, LDC ) -C - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE, - $ A, LDA, C, LDC ) -C -C Apply column interchanges to the solution matrix. -C - DO 20 I = N-1, 1, -1 - IP = IWORK(I) - IF ( IP.NE.I ) - $ CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 ) - 20 CONTINUE -C -1 -C Compute beta*(alpha*I + A) *(A - alpha*I) as -C -1 -C beta*I - 2*alpha*beta*(alpha*I + A) . -C -C Workspace: need N; prefer N*NB. -C - CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) -C - DO 30 I = 1, N - CALL DSCAL(N, -AB2, A(1,I), 1) - A(I,I) = A(I,I) + PBETA - 30 CONTINUE -C - RETURN -C *** Last line of AB04MD *** - END diff --git a/slycot/src/AB05MD.f b/slycot/src/AB05MD.f deleted file mode 100644 index 0324368b..00000000 --- a/slycot/src/AB05MD.f +++ /dev/null @@ -1,547 +0,0 @@ - SUBROUTINE AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, - $ D, LDD, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To obtain the state-space model (A,B,C,D) for the cascaded -C inter-connection of two systems, each given in state-space form. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes to obtain the matrix A -C in the upper or lower block diagonal form, as follows: -C = 'U': Obtain A in the upper block diagonal form; -C = 'L': Obtain A in the lower block diagonal form. -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D (for UPLO = 'L'), or A2 -C and A, B2 and B, C2 and C, and D2 and D (for -C UPLO = 'U'), i.e. the same name is effectively -C used for each pair (for all pairs) in the routine -C call. In this case, setting LDA1 = LDA, -C LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD, or -C LDA2 = LDA, LDB2 = LDB, LDC2 = LDC, and LDD2 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables for the first system. -C M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables from the first system and -C the number of input variables for the second system. -C P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2. N2 >= 0. -C -C P2 (input) INTEGER -C The number of output variables from the second system. -C P2 >= 0. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) -C The leading N2-by-P1 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P2-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P2) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) -C The leading P2-by-P1 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P2). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the resulting -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the cascaded system. -C If OVER = 'O', the array A can overlap A1, if UPLO = 'L', -C or A2, if UPLO = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1) -C The leading N-by-M1 part of this array contains the -C input/state matrix B for the cascaded system. -C If OVER = 'O', the array B can overlap B1, if UPLO = 'L', -C or B2, if UPLO = 'U'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P2-by-N part of this array contains the -C state/output matrix C for the cascaded system. -C If OVER = 'O', the array C can overlap C1, if UPLO = 'L', -C or C2, if UPLO = 'U'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P2) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1) -C The leading P2-by-M1 part of this array contains the -C input/output matrix D for the cascaded system. -C If OVER = 'O', the array D can overlap D1, if UPLO = 'L', -C or D2, if UPLO = 'U'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P2). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The array DWORK is not referenced if OVER = 'N'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, P1*MAX(N1, M1, N2, P2) ) if OVER = 'O'. -C LDWORK >= 1 if OVER = 'N'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C After cascaded inter-connection of the two systems -C -C X1' = A1*X1 + B1*U -C V = C1*X1 + D1*U -C -C X2' = A2*X2 + B2*V -C Y = C2*X2 + D2*V -C -C (where ' denotes differentiation with respect to time) -C -C the following state-space model will be obtained: -C -C X' = A*X + B*U -C Y = C*X + D*U -C -C where matrix A has the form ( A1 0 ), -C ( B2*C1 A2) -C -C matrix B has the form ( B1 ), -C ( B2*D1 ) -C -C matrix C has the form ( D2*C1 C2 ) and -C -C matrix D has the form ( D2*D1 ). -C -C This form is returned by the routine when UPLO = 'L'. Note that -C when A1 and A2 are block lower triangular, the resulting state -C matrix is also block lower triangular. -C -C By applying a similarity transformation to the system above, -C using the matrix ( 0 I ), where I is the identity matrix of -C ( J 0 ) -C order N2, and J is the identity matrix of order N1, the -C system matrices become -C -C A = ( A2 B2*C1 ), -C ( 0 A1 ) -C -C B = ( B2*D1 ), -C ( B1 ) -C -C C = ( C2 D2*C1 ) and -C -C D = ( D2*D1 ). -C -C This form is returned by the routine when UPLO = 'U'. Note that -C when A1 and A2 are block upper triangular (for instance, in the -C real Schur form), the resulting state matrix is also block upper -C triangular. -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C The algorithm requires P1*(N1+M1)*(N2+P2) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, Nov. 1996. -C Supersedes Release 2.0 routine AB05AD by C.J.Benson, Kingston -C Polytechnic, United Kingdom, January 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Cascade control, continuous-time system, multivariable -C system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER, UPLO - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, - $ N2, P1, P2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), - $ DWORK(*) -C .. Local Scalars .. - LOGICAL LOVER, LUPLO - INTEGER I, I1, I2, J, LDWN2, LDWP1, LDWP2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - LUPLO = LSAME( UPLO, 'L' ) - N = N1 + N2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -2 - ELSE IF( N1.LT.0 ) THEN - INFO = -3 - ELSE IF( M1.LT.0 ) THEN - INFO = -4 - ELSE IF( P1.LT.0 ) THEN - INFO = -5 - ELSE IF( N2.LT.0 ) THEN - INFO = -6 - ELSE IF( P2.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -9 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -11 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -13 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -15 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN - INFO = -23 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P2 ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -30 - ELSE IF( LDD.LT.MAX( 1, P2 ) ) THEN - INFO = -32 - ELSE IF( ( LOVER.AND.LDWORK.LT.MAX( 1, P1*MAX( N1, M1, N2, P2 )) ) - $.OR.( .NOT.LOVER.AND.LDWORK.LT.1 ) ) THEN - INFO = -34 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M1, P2 ) ).EQ.0 ) - $ RETURN -C -C Set row/column indices for storing the results. -C - IF ( LUPLO ) THEN - I1 = 1 - I2 = MIN( N1 + 1, N ) - ELSE - I1 = MIN( N2 + 1, N ) - I2 = 1 - END IF -C - LDWN2 = MAX( 1, N2 ) - LDWP1 = MAX( 1, P1 ) - LDWP2 = MAX( 1, P2 ) -C -C Construct the cascaded system matrices, taking the desired block -C structure and possible overwriting into account. -C -C Form the diagonal blocks of matrix A. -C - IF ( LUPLO ) THEN -C -C Lower block diagonal structure. -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', N2, N2, A2, LDA2, A(I2,I2), LDA ) - ELSE -C -C Upper block diagonal structure. -C - IF ( LOVER .AND. LDA2.LE.LDA ) THEN - IF ( LDA2.LT.LDA ) THEN -C - DO 40 J = N2, 1, -1 - DO 30 I = N2, 1, -1 - A(I,J) = A2(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N2, N2, A2, LDA2, A, LDA ) - END IF - IF ( N1.GT.0 ) - $ CALL DLACPY( 'F', N1, N1, A1, LDA1, A(I1,I1), LDA ) - END IF -C -C Form the off-diagonal blocks of matrix A. -C - IF ( MIN( N1, N2 ).GT.0 ) THEN - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(I1,I2), LDA ) - CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, ONE, - $ B2, LDB2, C1, LDC1, ZERO, A(I2,I1), LDA ) - END IF -C - IF ( LUPLO ) THEN -C -C Form the matrix B. -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 60 J = M1, 1, -1 - DO 50 I = N1, 1, -1 - B(I,J) = B1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) - END IF -C - IF ( MIN( N2, M1 ).GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, B2, LDB2, D1, LDD1, ZERO, B(I2,1), LDB ) -C -C Form the matrix C. -C - IF ( N1.GT.0 ) THEN - IF ( LOVER ) THEN -C -C Workspace: P1*N1. -C - CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK, LDWP1 ) - CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, - $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, C, LDC ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, - $ ONE, D2, LDD2, C1, LDC1, ZERO, C, LDC ) - END IF - END IF -C - IF ( MIN( P2, N2 ).GT.0 ) - $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(1,I2), LDC ) -C -C Now form the matrix D. -C - IF ( LOVER ) THEN -C -C Workspace: P1*M1. -C - CALL DLACPY( 'F', P1, M1, D1, LDD1, DWORK, LDWP1 ) - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, D, LDD ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) - END IF -C - ELSE -C -C Form the matrix B. -C - IF ( LOVER ) THEN -C -C Workspace: N2*P1. -C - CALL DLACPY( 'F', N2, P1, B2, LDB2, DWORK, LDWN2 ) - IF ( MIN( N2, M1 ).GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, DWORK, LDWN2, D1, LDD1, ZERO, B(I2,1), - $ LDB ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, B2, LDB2, D1, LDD1, ZERO, B, LDB ) - END IF -C - IF ( MIN( N1, M1 ).GT.0 ) - $ CALL DLACPY( 'F', N1, M1, B1, LDB1, B(I1,1), LDB ) -C -C Form the matrix C. -C - IF ( LOVER .AND. LDC2.LE.LDC ) THEN - IF ( LDC2.LT.LDC ) THEN -C - DO 80 J = N2, 1, -1 - DO 70 I = P2, 1, -1 - C(I,J) = C2(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P2, N2, C2, LDC2, C, LDC ) - END IF -C - IF ( MIN( P2, N1 ).GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, - $ ONE, D2, LDD2, C1, LDC1, ZERO, C(1,I1), LDC ) -C -C Now form the matrix D. -C - IF ( LOVER ) THEN -C -C Workspace: P2*P1. -C - CALL DLACPY( 'F', P2, P1, D2, LDD2, DWORK, LDWP2 ) - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, DWORK, LDWP2, D1, LDD1, ZERO, D, LDD ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, - $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) - END IF - END IF -C - RETURN -C *** Last line of AB05MD *** - END diff --git a/slycot/src/AB05ND.f b/slycot/src/AB05ND.f deleted file mode 100644 index 507d6ea1..00000000 --- a/slycot/src/AB05ND.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE AB05ND( OVER, N1, M1, P1, N2, ALPHA, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, - $ D, LDD, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To obtain the state-space model (A,B,C,D) for the feedback -C inter-connection of two systems, each given in state-space form. -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables for the first system and the -C number of output variables from the second system. -C M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables from the first system and -C the number of input variables for the second system. -C P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2. N2 >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C A coefficient multiplying the transfer-function matrix -C (or the output equation) of the second system. -C ALPHA = +1 corresponds to positive feedback, and -C ALPHA = -1 corresponds to negative feedback. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) -C The leading N2-by-P1 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading M1-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,M1) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) -C The leading M1-by-P1 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,M1). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the connected -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the connected system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1) -C The leading N-by-M1 part of this array contains the -C input/state matrix B for the connected system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P1-by-N part of this array contains the -C state/output matrix C for the connected system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P1) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1) -C The leading P1-by-M1 part of this array contains the -C input/output matrix D for the connected system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P1). -C -C Workspace -C -C IWORK INTEGER array, dimension (P1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. If OVER = 'N', -C LDWORK >= MAX(1, P1*P1, M1*M1, N1*P1), and if OVER = 'O', -C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*M1, N1*P1) ), -C if M1 <= N*N2; -C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*(M1+1), N1*P1) ), -C if M1 > N*N2. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C > 0: if INFO = i, 1 <= i <= P1, the system is not -C completely controllable. That is, the matrix -C (I + ALPHA*D1*D2) is exactly singular (the element -C U(i,i) of the upper triangular factor of LU -C factorization is exactly zero), possibly due to -C rounding errors. -C -C METHOD -C -C After feedback inter-connection of the two systems, -C -C X1' = A1*X1 + B1*U1 -C Y1 = C1*X1 + D1*U1 -C -C X2' = A2*X2 + B2*U2 -C Y2 = C2*X2 + D2*U2 -C -C (where ' denotes differentiation with respect to time) -C -C the following state-space model will be obtained: -C -C X' = A*X + B*U -C Y = C*X + D*U -C -C where U = U1 + alpha*Y2, X = ( X1 ), -C Y = Y1 = U2, ( X2 ) -C -C matrix A has the form -C -C ( A1 - alpha*B1*E12*D2*C1 - alpha*B1*E12*C2 ), -C ( B2*E21*C1 A2 - alpha*B2*E21*D1*C2 ) -C -C matrix B has the form -C -C ( B1*E12 ), -C ( B2*E21*D1 ) -C -C matrix C has the form -C -C ( E21*C1 - alpha*E21*D1*C2 ), -C -C matrix D has the form -C -C ( E21*D1 ), -C -C E21 = ( I + alpha*D1*D2 )-INVERSE and -C E12 = ( I + alpha*D2*D1 )-INVERSE = I - alpha*D2*E21*D1. -C -C Taking N1 = 0 and/or N2 = 0 on the routine call will solve the -C constant plant and/or constant feedback cases. -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB05BD by C.J.Benson, Kingston -C Polytechnic, United Kingdom, January 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Continuous-time system, multivariable system, state-space model, -C state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO=0.0D0, ONE=1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, - $ N2, P1 - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), - $ DWORK(*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J, LDW, LDWM1 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, - $ DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - LDWM1 = MAX( 1, M1 ) - N = N1 + N2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M1.LT.0 ) THEN - INFO = -3 - ELSE IF( P1.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -8 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -10 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -12 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -14 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -16 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -18 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.LDWM1 ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -20 - ELSE IF( LDD2.LT.LDWM1 ) THEN - INFO = -22 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -27 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -29 - ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN - INFO = -31 - ELSE - LDW = MAX( P1*P1, M1*M1, N1*P1 ) - IF( LOVER ) THEN - IF( M1.GT.N*N2 ) - $ LDW = MAX( LDW, M1*( M1 + 1 ) ) - LDW = N1*P1 + LDW - END IF - IF( LDWORK.LT.MAX( 1, LDW ) ) - $ INFO = -34 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M1, P1 ) ).EQ.0 ) - $ RETURN -C - IF ( P1.GT.0 ) THEN -C -C Form ( I + alpha * D1 * D2 ). -C - CALL DLASET( 'F', P1, P1, ZERO, ONE, DWORK, P1 ) - CALL DGEMM ( 'No transpose', 'No transpose', P1, P1, M1, ALPHA, - $ D1, LDD1, D2, LDD2, ONE, DWORK, P1 ) -C -C Factorize this matrix. -C - CALL DGETRF( P1, P1, DWORK, P1, IWORK, INFO ) -C - IF ( INFO.NE.0 ) - $ RETURN -C -C Form E21 * D1. -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 20 J = M1, 1, -1 - DO 10 I = P1, 1, -1 - D(I,J) = D1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) - END IF -C - CALL DGETRS( 'No transpose', P1, M1, DWORK, P1, IWORK, D, LDD, - $ INFO ) - IF ( N1.GT.0 ) THEN -C -C Form E21 * C1. -C - IF ( LOVER ) THEN -C -C First save C1. -C - LDW = LDW - P1*N1 + 1 - CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK(LDW), P1 ) -C - IF ( LDC1.NE.LDC ) - $ CALL DLACPY( 'F', P1, N1, DWORK(LDW), P1, C, LDC ) - ELSE - CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) - END IF -C - CALL DGETRS( 'No transpose', P1, N1, DWORK, P1, IWORK, - $ C, LDC, INFO ) - END IF -C -C Form E12 = I - alpha * D2 * ( E21 * D1 ). -C - CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) - CALL DGEMM ( 'No transpose', 'No transpose', M1, M1, P1, - $ -ALPHA, D2, LDD2, D, LDD, ONE, DWORK, LDWM1 ) -C - ELSE - CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) - END IF -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 40 J = N1, 1, -1 - DO 30 I = N1, 1, -1 - A(I,J) = A1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N1.GT.0 .AND. M1.GT.0 ) THEN -C -C Form B1 * E12. -C - IF ( LOVER ) THEN -C -C Use the blocks (1,2) and (2,2) of A as workspace. -C - IF ( N1*M1.LE.N*N2 ) THEN -C -C Use BLAS 3 code. -C - CALL DLACPY( 'F', N1, M1, B1, LDB1, A(1,N1+1), N1 ) - CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, - $ ONE, A(1,N1+1), N1, DWORK, LDWM1, ZERO, B, - $ LDB ) - ELSE IF ( LDB1.LT.LDB ) THEN -C - DO 60 J = M1, 1, -1 - DO 50 I = N1, 1, -1 - B(I,J) = B1(I,J) - 50 CONTINUE - 60 CONTINUE -C - IF ( M1.LE.N*N2 ) THEN -C -C Use BLAS 2 code. -C - DO 70 J = 1, N1 - CALL DCOPY( M1, B(J,1), LDB, A(1,N1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) - 70 CONTINUE -C - ELSE -C -C Use additional workspace. -C - DO 80 J = 1, N1 - CALL DCOPY( M1, B(J,1), LDB, DWORK(M1*M1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) - 80 CONTINUE -C - END IF -C - ELSE IF ( M1.LE.N*N2 ) THEN -C -C Use BLAS 2 code. -C - DO 90 J = 1, N1 - CALL DCOPY( M1, B1(J,1), LDB1, A(1,N1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) - 90 CONTINUE -C - ELSE -C -C Use additional workspace. -C - DO 100 J = 1, N1 - CALL DCOPY( M1, B1(J,1), LDB1, DWORK(M1*M1+1), 1 ) - CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, - $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) - 100 CONTINUE -C - END IF - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, - $ ONE, B1, LDB1, DWORK, LDWM1, ZERO, B, LDB ) - END IF - END IF -C - IF ( N2.GT.0 ) THEN -C -C Complete matrices B and C. -C - IF ( P1.GT.0 ) THEN - CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, - $ ONE, B2, LDB2, D, LDD, ZERO, B(N1+1,1), LDB ) - CALL DGEMM ( 'No transpose', 'No transpose', P1, N2, M1, - $ -ALPHA, D, LDD, C2, LDC2, ZERO, C(1,N1+1), LDC - $ ) - ELSE IF ( M1.GT.0 ) THEN - CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) - END IF - END IF -C - IF ( N1.GT.0 .AND. P1.GT.0 ) THEN -C -C Form upper left quadrant of A. -C - CALL DGEMM ( 'No transpose', 'No transpose', N1, P1, M1, - $ -ALPHA, B, LDB, D2, LDD2, ZERO, DWORK, N1 ) -C - IF ( LOVER ) THEN - CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, - $ ONE, DWORK, N1, DWORK(LDW), P1, ONE, A, LDA ) - ELSE - CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, - $ ONE, DWORK, N1, C1, LDC1, ONE, A, LDA ) - END IF - END IF -C - IF ( N2.GT.0 ) THEN -C -C Form lower right quadrant of A. -C - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) - IF ( M1.GT.0 ) - $ CALL DGEMM ( 'No transpose', 'No transpose', N2, N2, M1, - $ -ALPHA, B(N1+1,1), LDB, C2, LDC2, ONE, - $ A(N1+1,N1+1), LDA ) -C -C Complete the matrix A. -C - CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, - $ ONE, B2, LDB2, C, LDC, ZERO, A(N1+1,1), LDA ) - CALL DGEMM ( 'No transpose', 'No transpose', N1, N2, M1, - $ -ALPHA, B, LDB, C2, LDC2, ZERO, A(1,N1+1), LDA ) - END IF -C - RETURN -C *** Last line of AB05ND *** - END diff --git a/slycot/src/AB05OD.f b/slycot/src/AB05OD.f deleted file mode 100644 index 6eafa694..00000000 --- a/slycot/src/AB05OD.f +++ /dev/null @@ -1,418 +0,0 @@ - SUBROUTINE AB05OD( OVER, N1, M1, P1, N2, M2, ALPHA, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, M, A, LDA, B, LDB, C, - $ LDC, D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To obtain the state-space model (A,B,C,D) for rowwise -C concatenation (parallel inter-connection on outputs, with separate -C inputs) of two systems, each given in state-space form. -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables for the first system. -C M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables from each system. P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2. N2 >= 0. -C -C M2 (input) INTEGER -C The number of input variables for the second system. -C M2 >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C A coefficient multiplying the transfer-function matrix -C (or the output equation) of the second system. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) -C The leading N2-by-M2 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P1-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P1) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) -C The leading P1-by-M2 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P1). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the connected -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C M (output) INTEGER -C The number of input variables (M1 + M2) for the connected -C system, i.e. the number of columns of B and D. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the connected system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) -C The leading N-by-M part of this array contains the -C input/state matrix B for the connected system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P1-by-N part of this array contains the -C state/output matrix C for the connected system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P1) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) -C The leading P1-by-M part of this array contains the -C input/output matrix D for the connected system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C After rowwise concatenation (parallel inter-connection with -C separate inputs) of the two systems, -C -C X1' = A1*X1 + B1*U -C Y1 = C1*X1 + D1*U -C -C X2' = A2*X2 + B2*V -C Y2 = C2*X2 + D2*V -C -C (where ' denotes differentiation with respect to time), -C -C with the output equation for the second system multiplied by a -C scalar alpha, the following state-space model will be obtained: -C -C X' = A*X + B*(U) -C (V) -C -C Y = C*X + D*(U) -C (V) -C -C where matrix A has the form ( A1 0 ), -C ( 0 A2 ) -C -C matrix B has the form ( B1 0 ), -C ( 0 B2 ) -C -C matrix C has the form ( C1 alpha*C2 ) and -C -C matrix D has the form ( D1 alpha*D2 ). -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. -C Supersedes Release 2.0 routine AB05CD by C.J.Benson, Kingston -C Polytechnic, United Kingdom, January 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Continuous-time system, multivariable system, state-space model, -C state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, - $ N2, P1 - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - N = N1 + N2 - M = M1 + M2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M1.LT.0 ) THEN - INFO = -3 - ELSE IF( P1.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( M2.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -9 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -11 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -13 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -15 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P1 ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDD2.LT.MAX( 1, P1 ) ) THEN - INFO = -23 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -27 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -29 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -31 - ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN - INFO = -33 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P1 ) ).EQ.0 ) - $ RETURN -C -C First form the matrix A. -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) - CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) - END IF -C -C Now form the matrix B. -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 40 J = M1, 1, -1 - DO 30 I = N1, 1, -1 - B(I,J) = B1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) - END IF -C - IF ( M2.GT.0 ) THEN - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) - CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) - END IF - IF ( N2.GT.0 ) - $ CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) -C -C Now form the matrix C. -C - IF ( LOVER .AND. LDC1.LE.LDC ) THEN - IF ( LDC1.LT.LDC ) THEN -C - DO 60 J = N1, 1, -1 - DO 50 I = P1, 1, -1 - C(I,J) = C1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLACPY( 'F', P1, N2, C2, LDC2, C(1,N1+1), LDC ) - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, N2, C(1,N1+1), LDC, - $ INFO ) - END IF -C -C Now form the matrix D. -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 80 J = M1, 1, -1 - DO 70 I = P1, 1, -1 - D(I,J) = D1(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) - END IF -C - IF ( M2.GT.0 ) THEN - CALL DLACPY( 'F', P1, M2, D2, LDD2, D(1,M1+1), LDD ) - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, M2, D(1,M1+1), LDD, - $ INFO ) - END IF -C - RETURN -C *** Last line of AB05OD *** - END diff --git a/slycot/src/AB05PD.f b/slycot/src/AB05PD.f deleted file mode 100644 index 918aed8a..00000000 --- a/slycot/src/AB05PD.f +++ /dev/null @@ -1,385 +0,0 @@ - SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1, - $ C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2, - $ LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the state-space model G = (A,B,C,D) corresponding to -C the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and -C G2 = (A2,B2,C2,D2). G, G1, and G2 are the transfer-function -C matrices of the corresponding state-space models. -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1, the number of rows of B1 and -C the number of columns of C1. N1 >= 0. -C -C M (input) INTEGER -C The number of input variables of the two systems, i.e. the -C number of columns of matrices B1, D1, B2 and D2. M >= 0. -C -C P (input) INTEGER -C The number of output variables of the two systems, i.e. -C the number of rows of matrices C1, D1, C2 and D2. P >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2, the number of rows of B2 and -C the number of columns of C2. N2 >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The coefficient multiplying G2. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M) -C The leading N1-by-M part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M) -C The leading N2-by-M part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the resulting -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the resulting system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the -C input/state matrix B for the resulting system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P-by-N part of this array contains the -C state/output matrix C for the resulting system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C input/output matrix D for the resulting system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices of the resulting systems are determined as: -C -C ( A1 0 ) ( B1 ) -C A = ( ) , B = ( ) , -C ( 0 A2 ) ( B2 ) -C -C C = ( C1 alpha*C2 ) , D = D1 + alpha*D2 . -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Feb. 2004. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO=0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, M, N, N1, N2, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J, N1P1 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - N = N1 + N2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -8 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -10 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -12 - ELSE IF( LDD1.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -16 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -18 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -20 - ELSE IF( LDD2.LT.MAX( 1, P ) ) THEN - INFO = -22 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -27 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -29 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -31 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P ) ).EQ.0 ) - $ RETURN -C - N1P1 = N1 + 1 -C -C ( A1 0 ) -C Construct A = ( ) . -C ( 0 A2 ) -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1P1), LDA ) - CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1P1,1), LDA ) - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1P1,N1P1), LDA ) - END IF -C -C ( B1 ) -C Construct B = ( ) . -C ( B2 ) -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 40 J = M, 1, -1 - DO 30 I = N1, 1, -1 - B(I,J) = B1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M, B1, LDB1, B, LDB ) - END IF -C - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', N2, M, B2, LDB2, B(N1P1,1), LDB ) -C -C Construct C = ( C1 alpha*C2 ) . -C - IF ( LOVER .AND. LDC1.LE.LDC ) THEN - IF ( LDC1.LT.LDC ) THEN -C - DO 60 J = N1, 1, -1 - DO 50 I = P, 1, -1 - C(I,J) = C1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P, N1, C1, LDC1, C, LDC ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLACPY( 'F', P, N2, C2, LDC2, C(1,N1P1), LDC ) - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P, N2, C(1,N1P1), LDC, - $ INFO ) - END IF -C -C Construct D = D1 + alpha*D2 . -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 80 J = M, 1, -1 - DO 70 I = P, 1, -1 - D(I,J) = D1(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P, M, D1, LDD1, D, LDD ) - END IF -C - DO 90 J = 1, M - CALL DAXPY( P, ALPHA, D2(1,J), 1, D(1,J), 1 ) - 90 CONTINUE -C - RETURN -C *** Last line of AB05PD *** - END diff --git a/slycot/src/AB05QD.f b/slycot/src/AB05QD.f deleted file mode 100644 index c9f54bca..00000000 --- a/slycot/src/AB05QD.f +++ /dev/null @@ -1,419 +0,0 @@ - SUBROUTINE AB05QD( OVER, N1, M1, P1, N2, M2, P2, A1, LDA1, B1, - $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, - $ C2, LDC2, D2, LDD2, N, M, P, A, LDA, B, LDB, - $ C, LDC, D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To append two systems G1 and G2 in state-space form together. -C If G1 = (A1,B1,C1,D1) and G2 = (A2,B2,C2,D2) are the state-space -C models of the given two systems having the transfer-function -C matrices G1 and G2, respectively, this subroutine constructs the -C state-space model G = (A,B,C,D) which corresponds to the -C transfer-function matrix -C -C ( G1 0 ) -C G = ( ) -C ( 0 G2 ) -C -C ARGUMENTS -C -C Mode Parameters -C -C OVER CHARACTER*1 -C Indicates whether the user wishes to overlap pairs of -C arrays, as follows: -C = 'N': Do not overlap; -C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, -C C1 and C, and D1 and D, i.e. the same name is -C effectively used for each pair (for all pairs) -C in the routine call. In this case, setting -C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD -C will give maximum efficiency. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The number of state variables in the first system, i.e. -C the order of the matrix A1, the number of rows of B1 and -C the number of columns of C1. N1 >= 0. -C -C M1 (input) INTEGER -C The number of input variables in the first system, i.e. -C the number of columns of matrices B1 and D1. M1 >= 0. -C -C P1 (input) INTEGER -C The number of output variables in the first system, i.e. -C the number of rows of matrices C1 and D1. P1 >= 0. -C -C N2 (input) INTEGER -C The number of state variables in the second system, i.e. -C the order of the matrix A2, the number of rows of B2 and -C the number of columns of C2. N2 >= 0. -C -C M2 (input) INTEGER -C The number of input variables in the second system, i.e. -C the number of columns of matrices B2 and D2. M2 >= 0. -C -C P2 (input) INTEGER -C The number of output variables in the second system, i.e. -C the number of rows of matrices C2 and D2. P2 >= 0. -C -C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) -C The leading N1-by-N1 part of this array must contain the -C state transition matrix A1 for the first system. -C -C LDA1 INTEGER -C The leading dimension of array A1. LDA1 >= MAX(1,N1). -C -C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) -C The leading N1-by-M1 part of this array must contain the -C input/state matrix B1 for the first system. -C -C LDB1 INTEGER -C The leading dimension of array B1. LDB1 >= MAX(1,N1). -C -C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) -C The leading P1-by-N1 part of this array must contain the -C state/output matrix C1 for the first system. -C -C LDC1 INTEGER -C The leading dimension of array C1. -C LDC1 >= MAX(1,P1) if N1 > 0. -C LDC1 >= 1 if N1 = 0. -C -C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) -C The leading P1-by-M1 part of this array must contain the -C input/output matrix D1 for the first system. -C -C LDD1 INTEGER -C The leading dimension of array D1. LDD1 >= MAX(1,P1). -C -C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) -C The leading N2-by-N2 part of this array must contain the -C state transition matrix A2 for the second system. -C -C LDA2 INTEGER -C The leading dimension of array A2. LDA2 >= MAX(1,N2). -C -C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) -C The leading N2-by-M2 part of this array must contain the -C input/state matrix B2 for the second system. -C -C LDB2 INTEGER -C The leading dimension of array B2. LDB2 >= MAX(1,N2). -C -C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) -C The leading P2-by-N2 part of this array must contain the -C state/output matrix C2 for the second system. -C -C LDC2 INTEGER -C The leading dimension of array C2. -C LDC2 >= MAX(1,P2) if N2 > 0. -C LDC2 >= 1 if N2 = 0. -C -C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) -C The leading P2-by-M2 part of this array must contain the -C input/output matrix D2 for the second system. -C -C LDD2 INTEGER -C The leading dimension of array D2. LDD2 >= MAX(1,P2). -C -C N (output) INTEGER -C The number of state variables (N1 + N2) in the resulting -C system, i.e. the order of the matrix A, the number of rows -C of B and the number of columns of C. -C -C M (output) INTEGER -C The number of input variables (M1 + M2) in the resulting -C system, i.e. the number of columns of B and D. -C -C P (output) INTEGER -C The number of output variables (P1 + P2) of the resulting -C system, i.e. the number of rows of C and D. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) -C The leading N-by-N part of this array contains the state -C transition matrix A for the resulting system. -C The array A can overlap A1 if OVER = 'O'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N1+N2). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) -C The leading N-by-M part of this array contains the -C input/state matrix B for the resulting system. -C The array B can overlap B1 if OVER = 'O'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1+N2). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) -C The leading P-by-N part of this array contains the -C state/output matrix C for the resulting system. -C The array C can overlap C1 if OVER = 'O'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P1+P2) if N1+N2 > 0. -C LDC >= 1 if N1+N2 = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) -C The leading P-by-M part of this array contains the -C input/output matrix D for the resulting system. -C The array D can overlap D1 if OVER = 'O'. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P1+P2). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices of the resulting systems are determined as: -C -C ( A1 0 ) ( B1 0 ) -C A = ( ) , B = ( ) , -C ( 0 A2 ) ( 0 B2 ) -C -C ( C1 0 ) ( D1 0 ) -C C = ( ) , D = ( ) . -C ( 0 C2 ) ( 0 D2 ) -C -C REFERENCES -C -C None -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO=0.0D0 ) -C .. Scalar Arguments .. - CHARACTER OVER - INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, - $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, - $ N2, P, P1, P2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), - $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), - $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) -C .. Local Scalars .. - LOGICAL LOVER - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - LOVER = LSAME( OVER, 'O' ) - N = N1 + N2 - M = M1 + M2 - P = P1 + P2 - INFO = 0 -C -C Test the input scalar arguments. -C - IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN - INFO = -1 - ELSE IF( N1.LT.0 ) THEN - INFO = -2 - ELSE IF( M1.LT.0 ) THEN - INFO = -3 - ELSE IF( P1.LT.0 ) THEN - INFO = -4 - ELSE IF( N2.LT.0 ) THEN - INFO = -5 - ELSE IF( M2.LT.0 ) THEN - INFO = -6 - ELSE IF( P2.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN - INFO = -9 - ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN - INFO = -11 - ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. - $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN - INFO = -13 - ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN - INFO = -15 - ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. - $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN - INFO = -23 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -30 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -32 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -34 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P ) ).EQ.0 ) - $ RETURN -C ( A1 0 ) -C Construct A = ( ) . -C ( 0 A2 ) -C - IF ( LOVER .AND. LDA1.LE.LDA ) THEN - IF ( LDA1.LT.LDA ) THEN -C - DO 20 J = N1, 1, -1 - DO 10 I = N1, 1, -1 - A(I,J) = A1(I,J) - 10 CONTINUE - 20 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) - END IF -C - IF ( N2.GT.0 ) THEN - CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) - CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) - CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) - END IF -C -C ( B1 0 ) -C Construct B = ( ) . -C ( 0 B2 ) -C - IF ( LOVER .AND. LDB1.LE.LDB ) THEN - IF ( LDB1.LT.LDB ) THEN -C - DO 40 J = M1, 1, -1 - DO 30 I = N1, 1, -1 - B(I,J) = B1(I,J) - 30 CONTINUE - 40 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) - END IF -C - IF ( M2.GT.0 ) - $ CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) - IF ( N2.GT.0 ) THEN - CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) - IF ( M2.GT.0 ) - $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) - END IF -C -C ( C1 0 ) -C Construct C = ( ) . -C ( 0 C2 ) -C - IF ( LOVER .AND. LDC1.LE.LDC ) THEN - IF ( LDC1.LT.LDC ) THEN -C - DO 60 J = N1, 1, -1 - DO 50 I = P1, 1, -1 - C(I,J) = C1(I,J) - 50 CONTINUE - 60 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) - END IF -C - IF ( N2.GT.0 ) - $ CALL DLASET( 'F', P1, N2, ZERO, ZERO, C(1,N1+1), LDC ) - IF ( P2.GT.0 ) THEN - IF ( N1.GT.0 ) - $ CALL DLASET( 'F', P2, N1, ZERO, ZERO, C(P1+1,1), LDC ) - IF ( N2.GT.0 ) - $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(P1+1,N1+1), LDC ) - END IF -C -C ( D1 0 ) -C Construct D = ( ) . -C ( 0 D2 ) -C - IF ( LOVER .AND. LDD1.LE.LDD ) THEN - IF ( LDD1.LT.LDD ) THEN -C - DO 80 J = M1, 1, -1 - DO 70 I = P1, 1, -1 - D(I,J) = D1(I,J) - 70 CONTINUE - 80 CONTINUE -C - END IF - ELSE - CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) - END IF -C - IF ( M2.GT.0 ) - $ CALL DLASET( 'F', P1, M2, ZERO, ZERO, D(1,M1+1), LDD ) - IF ( P2.GT.0 ) THEN - CALL DLASET( 'F', P2, M1, ZERO, ZERO, D(P1+1,1), LDD ) - IF ( M2.GT.0 ) - $ CALL DLACPY( 'F', P2, M2, D2, LDD2, D(P1+1,M1+1), LDD ) - END IF -C - RETURN -C *** Last line of AB05QD *** - END diff --git a/slycot/src/AB05RD.f b/slycot/src/AB05RD.f deleted file mode 100644 index 4592f93d..00000000 --- a/slycot/src/AB05RD.f +++ /dev/null @@ -1,393 +0,0 @@ - SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A, - $ LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK, - $ G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC, - $ DC, LDDC, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a given state space system (A,B,C,D) the closed- -C loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and -C state feedback control law -C -C u = alpha*F*y + beta*K*x + G*v -C z = H*y. -C -C ARGUMENTS -C -C Mode Parameters -C -C FBTYPE CHARACTER*1 -C Specifies the type of the feedback law as follows: -C = 'I': Unitary output feedback (F = I); -C = 'O': General output feedback. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears -C in the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of state vector x, i.e. the order of the -C matrix A, the number of rows of B and the number of -C columns of C. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector u, i.e. the number of -C columns of matrices B and D, and the number of rows of F. -C M >= 0. -C -C P (input) INTEGER -C The dimension of output vector y, i.e. the number of rows -C of matrices C and D, and the number of columns of F. -C P >= 0 and P = M if FBTYPE = 'I'. -C -C MV (input) INTEGER -C The dimension of the new input vector v, i.e. the number -C of columns of matrix G. MV >= 0. -C -C PZ (input) INTEGER. -C The dimension of the new output vector z, i.e. the number -C of rows of matrix H. PZ >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The coefficient alpha in the output feedback law. -C -C BETA (input) DOUBLE PRECISION. -C The coefficient beta in the state feedback law. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state transition matrix A. -C On exit, the leading N-by-N part of this array contains -C the state matrix Ac of the closed-loop system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the intermediary input matrix B1 (see METHOD). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading P-by-N part of this array contains -C the intermediary output matrix C1+BETA*D1*K (see METHOD). -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the system direct input/output -C transmission matrix D. -C On exit, the leading P-by-M part of this array contains -C the intermediary direct input/output transmission matrix -C D1 (see METHOD). -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C F (input) DOUBLE PRECISION array, dimension (LDF,P) -C If FBTYPE = 'O', the leading M-by-P part of this array -C must contain the output feedback matrix F. -C If FBTYPE = 'I', then the feedback matrix is assumed to be -C an M x M order identity matrix. -C The array F is not referenced if FBTYPE = 'I' or -C ALPHA = 0. -C -C LDF INTEGER -C The leading dimension of array F. -C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. -C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. -C -C K (input) DOUBLE PRECISION array, dimension (LDK,N) -C The leading M-by-N part of this array must contain the -C state feedback matrix K. -C The array K is not referenced if BETA = 0. -C -C LDK INTEGER -C The leading dimension of the array K. -C LDK >= MAX(1,M) if BETA <> 0. -C LDK >= 1 if BETA = 0. -C -C G (input) DOUBLE PRECISION array, dimension (LDG,MV) -C The leading M-by-MV part of this array must contain the -C system input scaling matrix G. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,P) -C The leading PZ-by-P part of this array must contain the -C system output scaling matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= MAX(1,PZ). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal condition number of the matrix -C I - alpha*D*F. -C -C BC (output) DOUBLE PRECISION array, dimension (LDBC,MV) -C The leading N-by-MV part of this array contains the input -C matrix Bc of the closed-loop system. -C -C LDBC INTEGER -C The leading dimension of array BC. LDBC >= MAX(1,N). -C -C CC (output) DOUBLE PRECISION array, dimension (LDCC,N) -C The leading PZ-by-N part of this array contains the -C system output matrix Cc of the closed-loop system. -C -C LDCC INTEGER -C The leading dimension of array CC. -C LDCC >= MAX(1,PZ) if N > 0. -C LDCC >= 1 if N = 0. -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,MV) -C If JOBD = 'D', the leading PZ-by-MV part of this array -C contains the direct input/output transmission matrix Dc -C of the closed-loop system. -C The array DC is not referenced if JOBD = 'Z'. -C -C LDDC INTEGER -C The leading dimension of array DC. -C LDDC >= MAX(1,PZ) if JOBD = 'D'. -C LDDC >= 1 if JOBD = 'Z'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,2*P) if JOBD = 'D'. -C LIWORK >= 1 if JOBD = 'Z'. -C IWORK is not referenced if JOBD = 'Z'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= wspace, where -C wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D', -C wspace = MAX( 1, M ) if JOBD = 'Z'. -C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix I - alpha*D*F is numerically singular. -C -C METHOD -C -C The matrices of the closed-loop system have the expressions: -C -C Ac = A1 + beta*B1*K, Bc = B1*G, -C Cc = H*(C1 + beta*D1*K), Dc = H*D1*G, -C -C where -C -C A1 = A + alpha*B*F*E*C, B1 = B + alpha*B*F*E*D, -C C1 = E*C, D1 = E*D, -C -C with E = (I - alpha*D*F)**-1. -C -C NUMERICAL ASPECTS -C -C The accuracy of computations basically depends on the conditioning -C of the matrix I - alpha*D*F. If RCOND is very small, it is likely -C that the computed results are inaccurate. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C January 14, 1997, February 18, 1998. -C V. Sima, Research Institute for Informatics, Bucharest, July 2003, -C Jan. 2005. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FBTYPE, JOBD - INTEGER INFO, LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, - $ LDF, LDG, LDH, LDK, LDWORK, M, MV, N, P, PZ - DOUBLE PRECISION ALPHA, BETA, RCOND -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), BC(LDBC,*), C(LDC,*), - $ CC(LDCC,*), D(LDD,*), DC(LDDC,*), DWORK(*), - $ F(LDF,*), G(LDG,*), H(LDH,*), K(LDK,*) -C .. Local Scalars .. - LOGICAL LJOBD, OUTPF, UNITF - INTEGER LDWP -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL AB05SD, DGEMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - UNITF = LSAME( FBTYPE, 'I' ) - OUTPF = LSAME( FBTYPE, 'O' ) - LJOBD = LSAME( JOBD, 'D' ) -C - INFO = 0 -C - IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN - INFO = -5 - ELSE IF( MV.LT.0 ) THEN - INFO = -6 - ELSE IF( PZ.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -15 - ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN - INFO = -17 - ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) - $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN - INFO = -19 - ELSE IF( ( BETA.NE.ZERO .AND. LDK.LT.MAX( 1, M ) ) .OR. - $ ( BETA.EQ.ZERO .AND. LDK.LT.1 ) ) THEN - INFO = -21 - ELSE IF( LDG.LT.MAX( 1, M ) ) THEN - INFO = -23 - ELSE IF( LDH.LT.MAX( 1, PZ ) ) THEN - INFO = -25 - ELSE IF( LDBC.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( ( N.GT.0 .AND. LDCC.LT.MAX( 1, PZ ) ) .OR. - $ ( N.EQ.0 .AND. LDCC.LT.1 ) ) THEN - INFO = -30 - ELSE IF( ( ( LJOBD .AND. LDDC.LT.MAX( 1, PZ ) ) .OR. - $ ( .NOT.LJOBD .AND. LDDC.LT.1 ) ) ) THEN - INFO = -32 - ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*MV, P*P + 4*P ) ) - $ .OR. ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN - INFO = -35 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MIN( M, P ), MIN( MV, PZ ) ).EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C -C Apply the partial output feedback u = alpha*F*y + v1 -C - CALL AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, C, - $ LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, LDWORK, - $ INFO ) - IF ( INFO.NE.0 ) RETURN -C -C Apply the partial state feedback v1 = beta*K*x + v2. -C -C Compute Ac = A1 + beta*B1*K and C1 <- C1 + beta*D1*K. -C - IF( BETA.NE.ZERO .AND. N.GT.0 ) THEN - CALL DGEMM( 'N', 'N', N, N, M, BETA, B, LDB, K, LDK, ONE, A, - $ LDA ) - IF( LJOBD ) - $ CALL DGEMM( 'N', 'N', P, N, M, BETA, D, LDD, K, LDK, ONE, - $ C, LDC ) - END IF -C -C Apply the input and output conversions v2 = G*v, z = H*y. -C -C Compute Bc = B1*G. -C - CALL DGEMM( 'N', 'N', N, MV, M, ONE, B, LDB, G, LDG, ZERO, BC, - $ LDBC ) -C -C Compute Cc = H*C1. -C - IF( N.GT.0 ) - $ CALL DGEMM( 'N', 'N', PZ, N, P, ONE, H, LDH, C, LDC, ZERO, CC, - $ LDCC ) -C -C Compute Dc = H*D1*G. -C - IF( LJOBD ) THEN - LDWP = MAX( 1, P ) - CALL DGEMM( 'N', 'N', P, MV, M, ONE, D, LDD, G, LDG, ZERO, - $ DWORK, LDWP ) - CALL DGEMM( 'N', 'N', PZ, MV, P, ONE, H, LDH, DWORK, LDWP, - $ ZERO, DC, LDDC ) - END IF -C - RETURN -C *** Last line of AB05RD *** - END diff --git a/slycot/src/AB05SD.f b/slycot/src/AB05SD.f deleted file mode 100644 index 7cc57b5c..00000000 --- a/slycot/src/AB05SD.f +++ /dev/null @@ -1,371 +0,0 @@ - SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, - $ C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, - $ LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a given state space system (A,B,C,D) the closed- -C loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback -C control law -C -C u = alpha*F*y + v. -C -C ARGUMENTS -C -C Mode Parameters -C -C FBTYPE CHARACTER*1 -C Specifies the type of the feedback law as follows: -C = 'I': Unitary output feedback (F = I); -C = 'O': General output feedback. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e. the order of the -C matrix A, the number of rows of B and the number of -C columns of C. N >= 0. -C -C M (input) INTEGER -C The number of input variables, i.e. the number of columns -C of matrices B and D, and the number of rows of F. M >= 0. -C -C P (input) INTEGER -C The number of output variables, i.e. the number of rows of -C matrices C and D, and the number of columns of F. P >= 0 -C and P = M if FBTYPE = 'I'. -C -C ALPHA (input) DOUBLE PRECISION -C The coefficient alpha in the output feedback law. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state transition matrix A. -C On exit, the leading N-by-N part of this array contains -C the state matrix Ac of the closed-loop system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the input matrix Bc of the closed-loop system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading P-by-N part of this array contains -C the output matrix Cc of the closed-loop system. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the system direct input/output transmission -C matrix D. -C On exit, if JOBD = 'D', the leading P-by-M part of this -C array contains the direct input/output transmission -C matrix Dc of the closed-loop system. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C F (input) DOUBLE PRECISION array, dimension (LDF,P) -C If FBTYPE = 'O', the leading M-by-P part of this array -C must contain the output feedback matrix F. -C If FBTYPE = 'I', then the feedback matrix is assumed to be -C an M x M order identity matrix. -C The array F is not referenced if FBTYPE = 'I' or -C ALPHA = 0. -C -C LDF INTEGER -C The leading dimension of array F. -C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. -C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal condition number of the matrix -C I - alpha*D*F. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,2*P) if JOBD = 'D'. -C LIWORK >= 1 if JOBD = 'Z'. -C IWORK is not referenced if JOBD = 'Z'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= wspace, where -C wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D', -C wspace = MAX( 1, M ) if JOBD = 'Z'. -C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix I - alpha*D*F is numerically singular. -C -C METHOD -C -C The matrices of the closed-loop system have the expressions: -C -C Ac = A + alpha*B*F*E*C, Bc = B + alpha*B*F*E*D, -C Cc = E*C, Dc = E*D, -C -C where E = (I - alpha*D*F)**-1. -C -C NUMERICAL ASPECTS -C -C The accuracy of computations basically depends on the conditioning -C of the matrix I - alpha*D*F. If RCOND is very small, it is likely -C that the computed results are inaccurate. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Research Establishment, -C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, -C Belgium, Nov. 1996. -C -C REVISIONS -C -C January 14, 1997. -C V. Sima, Research Institute for Informatics, Bucharest, July 2003. -C -C KEYWORDS -C -C Multivariable system, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FBTYPE, JOBD - INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDWORK, M, N, P - DOUBLE PRECISION ALPHA, RCOND -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), F(LDF,*) -C .. Local Scalars .. - LOGICAL LJOBD, OUTPF, UNITF - INTEGER I, IW, LDWN, LDWP - DOUBLE PRECISION ENORM -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEMV, DGETRF, - $ DGETRS, DLACPY, DLASCL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - UNITF = LSAME( FBTYPE, 'I' ) - OUTPF = LSAME( FBTYPE, 'O' ) - LJOBD = LSAME( JOBD, 'D' ) - LDWN = MAX( 1, N ) - LDWP = MAX( 1, P ) -C - INFO = 0 -C - IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN - INFO = -5 - ELSE IF( LDA.LT.LDWN ) THEN - INFO = -7 - ELSE IF( LDB.LT.LDWN ) THEN - INFO = -9 - ELSE IF( ( N.GT.0 .AND. LDC.LT.LDWP ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -11 - ELSE IF( ( LJOBD .AND. LDD.LT.LDWP ) .OR. - $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN - INFO = -13 - ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) - $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN - INFO = -16 - ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*P + 4*P ) ) .OR. - $ ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN - INFO = -20 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB05SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - RCOND = ONE - IF ( MAX( N, MIN( M, P ) ).EQ.0 .OR. ALPHA.EQ.ZERO ) - $ RETURN -C - IF (LJOBD) THEN - IW = P*P + 1 -C -C Compute I - alpha*D*F. -C - IF( UNITF) THEN - CALL DLACPY( 'F', P, P, D, LDD, DWORK, LDWP ) - IF ( ALPHA.NE.-ONE ) - $ CALL DLASCL( 'G', 0, 0, ONE, -ALPHA, P, P, DWORK, LDWP, - $ INFO ) - ELSE - CALL DGEMM( 'N', 'N', P, P, M, -ALPHA, D, LDD, F, LDF, ZERO, - $ DWORK, LDWP ) - END IF -C - DUMMY(1) = ONE - CALL DAXPY( P, ONE, DUMMY, 0, DWORK, P+1 ) -C -C Compute Cc = E*C, Dc = E*D, where E = (I - alpha*D*F)**-1. -C - ENORM = DLANGE( '1', P, P, DWORK, LDWP, DWORK(IW) ) - CALL DGETRF( P, P, DWORK, LDWP, IWORK, INFO ) - IF( INFO.GT.0 ) THEN -C -C Error return. -C - RCOND = ZERO - INFO = 1 - RETURN - END IF - CALL DGECON( '1', P, DWORK, LDWP, ENORM, RCOND, DWORK(IW), - $ IWORK(P+1), INFO ) - IF( RCOND.LE.DLAMCH('E') ) THEN -C -C Error return. -C - INFO = 1 - RETURN - END IF -C - IF( N.GT.0 ) - $ CALL DGETRS( 'N', P, N, DWORK, LDWP, IWORK, C, LDC, INFO ) - CALL DGETRS( 'N', P, M, DWORK, LDWP, IWORK, D, LDD, INFO ) - END IF -C - IF ( N.EQ.0 ) - $ RETURN -C -C Compute Ac = A + alpha*B*F*Cc and Bc = B + alpha*B*F*Dc. -C - IF( UNITF ) THEN - CALL DGEMM( 'N', 'N', N, N, M, ALPHA, B, LDB, C, LDC, ONE, A, - $ LDA ) - IF( LJOBD ) THEN -C - IF( LDWORK.LT.N*M ) THEN -C -C Not enough working space for using DGEMM. -C - DO 10 I = 1, N - CALL DCOPY( P, B(I,1), LDB, DWORK, 1 ) - CALL DGEMV( 'T', P, P, ALPHA, D, LDD, DWORK, 1, ONE, - $ B(I,1), LDB ) - 10 CONTINUE -C - ELSE - CALL DLACPY( 'F', N, M, B, LDB, DWORK, LDWN ) - CALL DGEMM( 'N', 'N', N, P, M, ALPHA, DWORK, LDWN, D, - $ LDD, ONE, B, LDB ) - END IF - END IF - ELSE -C - IF( LDWORK.LT.N*P ) THEN -C -C Not enough working space for using DGEMM. -C - DO 20 I = 1, N - CALL DGEMV( 'N', M, P, ALPHA, F, LDF, C(1,I), 1, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'N', N, M, ONE, B, LDB, DWORK, 1, ONE, - $ A(1,I), 1 ) - 20 CONTINUE -C - IF( LJOBD ) THEN -C - DO 30 I = 1, N - CALL DGEMV( 'T', M, P, ALPHA, F, LDF, B(I,1), LDB, - $ ZERO, DWORK, 1 ) - CALL DGEMV( 'T', P, M, ONE, D, LDD, DWORK, 1, ONE, - $ B(I,1), LDB ) - 30 CONTINUE -C - END IF - ELSE -C - CALL DGEMM( 'N', 'N', N, P, M, ALPHA, B, LDB, F, LDF, - $ ZERO, DWORK, LDWN ) - CALL DGEMM( 'N', 'N', N, N, P, ONE, DWORK, LDWN, C, LDC, - $ ONE, A, LDA ) - IF( LJOBD ) - $ CALL DGEMM( 'N', 'N', N, M, P, ONE, DWORK, LDWN, D, LDD, - $ ONE, B, LDB ) - END IF - END IF -C - RETURN -C *** Last line of AB05SD *** - END diff --git a/slycot/src/AB07MD.f b/slycot/src/AB07MD.f deleted file mode 100644 index da49e2df..00000000 --- a/slycot/src/AB07MD.f +++ /dev/null @@ -1,224 +0,0 @@ - SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the dual of a given state-space representation. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the dual state dynamics matrix A'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-P part of this array contains -C the dual input/state matrix C'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading M-by-N part of this array contains -C the dual state/output matrix B'. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,MAX(M,P)) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the original direct transmission -C matrix D. -C On exit, if JOBD = 'D', the leading M-by-P part of this -C array contains the dual direct transmission matrix D'. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,M,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If the given state-space representation is the M-input/P-output -C (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D'). -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine AB07AD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Dual system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOBD - INTEGER INFO, LDA, LDB, LDC, LDD, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*) -C .. Local Scalars .. - LOGICAL LJOBD - INTEGER J, MINMP, MPLIM -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL DCOPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LJOBD = LSAME( JOBD, 'D' ) - MPLIM = MAX( M, P ) - MINMP = MIN( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, MPLIM ) ) .OR. - $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN - INFO = -10 - ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, MPLIM ) ) .OR. - $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB07MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, MINMP ).EQ.0 ) - $ RETURN -C - IF ( N.GT.0 ) THEN -C -C Transpose A, if non-scalar. -C - DO 10 J = 1, N - 1 - CALL DSWAP( N-J, A(J+1,J), 1, A(J,J+1), LDA ) - 10 CONTINUE -C -C Replace B by C' and C by B'. -C - DO 20 J = 1, MPLIM - IF ( J.LE.MINMP ) THEN - CALL DSWAP( N, B(1,J), 1, C(J,1), LDC ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( N, B(1,J), 1, C(J,1), LDC ) - ELSE - CALL DCOPY( N, C(J,1), LDC, B(1,J), 1 ) - END IF - 20 CONTINUE -C - END IF -C - IF ( LJOBD .AND. MINMP.GT.0 ) THEN -C -C Transpose D, if non-scalar. -C - DO 30 J = 1, MPLIM - IF ( J.LT.MINMP ) THEN - CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) - ELSE IF ( J.GT.M ) THEN - CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) - END IF - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of AB07MD *** - END diff --git a/slycot/src/AB07ND.f b/slycot/src/AB07ND.f deleted file mode 100644 index 86b26d27..00000000 --- a/slycot/src/AB07ND.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs and outputs. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state matrix A of the original system. -C On exit, the leading N-by-N part of this array contains -C the state matrix Ai of the inverse system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the original system. -C On exit, the leading N-by-M part of this array contains -C the input matrix Bi of the inverse system. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the output matrix C of the original system. -C On exit, the leading M-by-N part of this array contains -C the output matrix Ci of the inverse system. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,M). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading M-by-M part of this array must -C contain the feedthrough matrix D of the original system. -C On exit, the leading M-by-M part of this array contains -C the feedthrough matrix Di of the inverse system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,M). -C -C RCOND (output) DOUBLE PRECISION -C The estimated reciprocal condition number of the -C feedthrough matrix D of the original system. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,4*M). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: the matrix D is exactly singular; the (i,i) diagonal -C element is zero, i <= M; RCOND was set to zero; -C = M+1: the matrix D is numerically singular, i.e., RCOND -C is less than the relative machine precision, EPS -C (see LAPACK Library routine DLAMCH). The -C calculations have been completed, but the results -C could be very inaccurate. -C -C METHOD -C -C The matrices of the inverse system are computed with the formulas: -C -1 -1 -1 -1 -C Ai = A - B*D *C, Bi = -B*D , Ci = D *C, Di = D . -C -C NUMERICAL ASPECTS -C -C The accuracy depends mainly on the condition number of the matrix -C D to be inverted. The estimated reciprocal condition number is -C returned in RCOND. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. -C D. Sima, University of Bucharest, April 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C Based on the routine SYSINV, A. Varga, 1992. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C -C KEYWORDS -C -C Inverse system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION RCOND - INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION DNORM - INTEGER BL, CHUNK, I, IERR, J, MAXWRK - LOGICAL BLAS3, BLOCK -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - INTEGER ILAENV - EXTERNAL DLAMCH, DLANGE, ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DGECON, DGEMM, DGEMV, DGETRF, DGETRI, - $ DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.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 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, 4*M ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB07ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) THEN - RCOND = ONE - DWORK(1) = ONE - RETURN - END IF -C -C Factorize D. -C - CALL DGETRF( M, M, D, LDD, IWORK, INFO ) - IF ( INFO.NE.0 ) THEN - RCOND = ZERO - RETURN - END IF -C -C Compute the reciprocal condition number of the matrix D. -C Workspace: need 4*M. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DNORM = DLANGE( '1-norm', M, M, D, LDD, DWORK ) - CALL DGECON( '1-norm', M, D, LDD, DNORM, RCOND, DWORK, IWORK(M+1), - $ IERR ) - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = M + 1 -C -1 -C Compute Di = D . -C Workspace: need M; -C prefer M*NB. -C - MAXWRK = MAX( 4*M, M*ILAENV( 1, 'DGETRI', ' ', M, -1, -1, -1 ) ) - CALL DGETRI( M, D, LDD, IWORK, DWORK, LDWORK, IERR ) - IF ( N.GT.0 ) THEN - CHUNK = LDWORK / M - BLAS3 = CHUNK.GE.N .AND. M.GT.1 - BLOCK = MIN( CHUNK, M ).GT.1 -C -1 -C Compute Bi = -B*D . -C - IF ( BLAS3 ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, M, -ONE, - $ DWORK, N, D, LDD, ZERO, B, LDB ) -C - ELSE IF( BLOCK ) THEN -C -C Use as many rows of B as possible. -C - DO 10 I = 1, N, CHUNK - BL = MIN( N-I+1, CHUNK ) - CALL DLACPY( 'Full', BL, M, B(I,1), LDB, DWORK, BL ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, -ONE, - $ DWORK, BL, D, LDD, ZERO, B(I,1), LDB ) - 10 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 20 I = 1, N - CALL DCOPY( M, B(I,1), LDB, DWORK, 1 ) - CALL DGEMV( 'Transpose', M, M, -ONE, D, LDD, DWORK, 1, - $ ZERO, B(I,1), LDB ) - 20 CONTINUE -C - END IF -C -C Compute Ai = A + Bi*C. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, LDB, - $ C, LDC, ONE, A, LDA ) -C -1 -C Compute C <-- D *C. -C - IF ( BLAS3 ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, - $ D, LDD, DWORK, M, ZERO, C, LDC ) -C - ELSE IF( BLOCK ) THEN -C -C Use as many columns of C as possible. -C - DO 30 J = 1, N, CHUNK - BL = MIN( N-J+1, CHUNK ) - CALL DLACPY( 'Full', M, BL, C(1,J), LDC, DWORK, M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, - $ D, LDD, DWORK, M, ZERO, C(1,J), LDC ) - 30 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 40 J = 1, N - CALL DCOPY( M, C(1,J), 1, DWORK, 1 ) - CALL DGEMV( 'NoTranspose', M, M, ONE, D, LDD, DWORK, 1, - $ ZERO, C(1,J), 1 ) - 40 CONTINUE -C - END IF - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK(1) = DBLE( MAX( MAXWRK, N*M ) ) - RETURN -C -C *** Last line of AB07ND *** - END diff --git a/slycot/src/AB08MD.f b/slycot/src/AB08MD.f deleted file mode 100644 index bd801a61..00000000 --- a/slycot/src/AB08MD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ RANK, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the normal rank of the transfer-function matrix of a -C state-space model (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C RANK (output) INTEGER -C The normal rank of the transfer-function matrix. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (N+P)*(N+M) + -C MAX( MIN(P,M) + MAX(3*M-1,N), 1, -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ) -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) -C (D C) -C -C to one with the same invariant zeros and with D of full row rank. -C The normal rank of the transfer-function matrix is the rank of D. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C Dec. 2003, Jan. 2009, Mar. 2009, Apr. 2009. -C -C KEYWORDS -C -C Multivariable system, orthogonal transformation, -C structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, - $ SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL AB08NX, DLACPY, TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - NP = N + P - NM = N + M - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LDWORK.EQ.-1 ) - WRKOPT = NP*NM -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE - KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, - $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) - IF( LQUERY ) THEN - SVLMAX = ZERO - NINFZ = 0 - CALL AB08NX( N, M, P, P, 0, SVLMAX, DWORK, MAX( 1, NP ), - $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, - $ DWORK, -1, INFO ) - WRKOPT = MAX( KW, WRKOPT + INT( DWORK(1) ) ) - ELSE IF( LDWORK.LT.KW ) THEN - INFO = -17 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08MD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, P ).EQ.0 ) THEN - RANK = 0 - DWORK(1) = ONE - RETURN - END IF -C - DO 10 I = 1, 2*N+1 - IWORK(I) = 0 - 10 CONTINUE -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C Workspace: need (N+P)*(N+M). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NP ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(N+1), NP ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(NP*M+1), NP ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(NP*M+N+1), NP ) -C -C If required, balance the compound matrix (default MAXRED). -C Workspace: need N. -C - KW = WRKOPT + 1 - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', N, M, P, MAXRED, DWORK(NP*M+1), NP, DWORK, - $ NP, DWORK(NP*M+N+1), NP, DWORK(KW), INFO ) - WRKOPT = WRKOPT + N - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = DLANGE( 'Frobenius', NP, NM, DWORK, NP, DWORK(KW) ) -C -C Reduce this system to one with the same invariant zeros and with -C D full row rank MU (the normal rank of the original system). -C Real workspace: need (N+P)*(N+M) + -C MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C Integer workspace: 2*N+MAX(M,P)+1. -C - RO = P - SIGMA = 0 - NINFZ = 0 - CALL AB08NX( N, M, P, RO, SIGMA, SVLMAX, DWORK, NP, NINFZ, IWORK, - $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), - $ DWORK(KW), LDWORK-KW+1, INFO ) - RANK = MU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - RETURN -C *** Last line of AB08MD *** - END diff --git a/slycot/src/AB08MZ.f b/slycot/src/AB08MZ.f deleted file mode 100644 index 89d8005e..00000000 --- a/slycot/src/AB08MZ.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the normal rank of the transfer-function matrix of a -C state-space model (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) COMPLEX*16 array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) COMPLEX*16 array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) COMPLEX*16 array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) COMPLEX*16 array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C RANK (output) INTEGER -C The normal rank of the transfer-function matrix. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) -C -C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1, -C MIN(P,N) + MAX(3*P-1,N+P,N+M)) -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) -C (D C) -C -C to one with the same invariant zeros and with D of full row rank. -C The normal rank of the transfer-function matrix is the rank of D. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Dec. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Multivariable system, unitary transformation, -C structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER INFO, LDA, LDB, LDC, LDD, LZWORK, M, N, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), ZWORK(*) - DOUBLE PRECISION DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, - $ SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZLACPY -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - NP = N + P - NM = N + M - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LZWORK.EQ.-1 ) - WRKOPT = NP*NM -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE - KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, - $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) - IF( LQUERY ) THEN - SVLMAX = ZERO - NINFZ = 0 - CALL AB8NXZ( N, M, P, P, 0, SVLMAX, ZWORK, MAX( 1, NP ), - $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, - $ DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( KW, WRKOPT + INT( ZWORK(1) ) ) - ELSE IF( LZWORK.LT.KW ) THEN - INFO = -17 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08MZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, P ).EQ.0 ) THEN - RANK = 0 - ZWORK(1) = ONE - RETURN - END IF -C - DO 10 I = 1, 2*N+1 - IWORK(I) = 0 - 10 CONTINUE -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C Complex workspace: need (N+P)*(N+M). -C - CALL ZLACPY( 'Full', N, M, B, LDB, ZWORK, NP ) - CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(N+1), NP ) - CALL ZLACPY( 'Full', N, N, A, LDA, ZWORK(NP*M+1), NP ) - CALL ZLACPY( 'Full', P, N, C, LDC, ZWORK(NP*M+N+1), NP ) -C -C If required, balance the compound matrix (default MAXRED). -C Real Workspace: need N. -C - KW = WRKOPT + 1 - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01IZ( 'A', N, M, P, MAXRED, ZWORK(NP*M+1), NP, ZWORK, - $ NP, ZWORK(NP*M+N+1), NP, DWORK, INFO ) - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = ZLANGE( 'Frobenius', NP, NM, ZWORK, NP, DWORK ) -C -C Reduce this system to one with the same invariant zeros and with -C D full row rank MU (the normal rank of the original system). -C Real workspace: need 2*MAX(M,P); -C Complex workspace: need (N+P)*(N+M) + -C MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C Integer workspace: 2*N+MAX(M,P)+1. -C - RO = P - SIGMA = 0 - NINFZ = 0 - CALL AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ZWORK, NP, NINFZ, IWORK, - $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), - $ DWORK, ZWORK(KW), LZWORK-KW+1, INFO ) - RANK = MU -C - ZWORK(1) = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - RETURN -C *** Last line of AB08MZ *** - END diff --git a/slycot/src/AB08ND.f b/slycot/src/AB08ND.f deleted file mode 100644 index 8fdb139d..00000000 --- a/slycot/src/AB08ND.f +++ /dev/null @@ -1,568 +0,0 @@ - SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, - $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a linear multivariable system described by a -C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which -C f f -C has the invariant zeros of the system as generalized eigenvalues. -C The routine also computes the orders of the infinite zeros and the -C right and left Kronecker indices of the system (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NU (output) INTEGER -C The number of (finite) invariant zeros. -C -C RANK (output) INTEGER -C The normal rank of the transfer function matrix. -C -C DINFZ (output) INTEGER -C The maximum degree of infinite elementary divisors. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors -C of degree i, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C AF (output) DOUBLE PRECISION array, dimension -C (LDAF,N+MIN(P,M)) -C The leading NU-by-NU part of this array contains the -C coefficient matrix A of the reduced pencil. The remainder -C f -C of the leading (N+M)-by-(N+MIN(P,M)) part is used as -C internal workspace. -C -C LDAF INTEGER -C The leading dimension of array AF. LDAF >= MAX(1,N+M). -C -C BF (output) DOUBLE PRECISION array, dimension (LDBF,N+M) -C The leading NU-by-NU part of this array contains the -C coefficient matrix B of the reduced pencil. The -C f -C remainder of the leading (N+P)-by-(N+M) part is used as -C internal workspace. -C -C LDBF INTEGER -C The leading dimension of array BF. LDBF >= MAX(1,N+P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M), -C MIN(M,N) + MAX(3*M-1,N+M) ). -C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with -C s = MAX(M,P). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a state-space -C system (A,B,C,D) a regular pencil A - lambda*B which has the -C f f -C invariant zeros of the system as generalized eigenvalues as -C follows: -C -C (a) construct the (N+P)-by-(N+M) compound matrix (B A); -C (D C) -C -C (b) reduce the above system to one with the same invariant -C zeros and with D of full row rank; -C -C (c) pertranspose the system; -C -C (d) reduce the system to one with the same invariant zeros and -C with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C (A - lambda*I B) in order to reduce it to -C ( C D) -C -C (A - lambda*B X) -C ( f f ), with Y and B square invertible; -C ( 0 Y) f -C -C (f) compute the right and left Kronecker indices of the system -C (A,B,C,D), which together with the orders of the infinite -C zeros (determined by steps (a) - (e)) constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C FURTHER COMMENTS -C -C In order to compute the invariant zeros of the system explicitly, -C a call to this routine may be followed by a call to the LAPACK -C Library routine DGGEV with A = A , B = B and N = NU. -C f f -C If RANK = 0, the routine DGEEV can be used (since B = I). -C f -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB08BD by F. Svaricek. -C -C REVISIONS -C -C Oct. 1997, Feb. 1998, Dec. 2003, March 2004, Jan. 2009, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, - $ LDWORK, M, N, NKROL, NKROR, NU, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) - DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), - $ C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, - $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL AB08NX, DCOPY, DLACPY, DLASET, DORMRZ, DTZRZF, - $ TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN - INFO = -22 - ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN - INFO = -24 - ELSE - II = MIN( P, M ) - I = MAX( II + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), - $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) - IF( LQUERY ) THEN - SVLMAX = ZERO - NINFZ = 0 - CALL AB08NX( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, -1, - $ INFO ) - WRKOPT = MAX( I, INT( DWORK(1) ) ) - CALL AB08NX( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, - $ -1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - NB = ILAENV( 1, 'DGERQF', ' ', II, N+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', N, N+II, II, -1 ) ) - WRKOPT = MAX( WRKOPT, II + N*NB ) - ELSE IF( LDWORK.LT.I ) THEN - INFO = -28 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08ND', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C - DINFZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( MIN( M, P ).EQ.0 ) THEN - NU = 0 - RANK = 0 - DWORK(1) = ONE - RETURN - END IF - END IF -C - MM = M - NN = N - PP = P -C - DO 20 I = 1, N - INFZ(I) = 0 - 20 CONTINUE -C - IF ( M.GT.0 ) THEN - DO 40 I = 1, N + 1 - KRONR(I) = 0 - 40 CONTINUE - END IF -C - IF ( P.GT.0 ) THEN - DO 60 I = 1, N + 1 - KRONL(I) = 0 - 60 CONTINUE - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - WRKOPT = 1 -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C - CALL DLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) - IF ( PP.GT.0 ) - $ CALL DLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) - IF ( NN.GT.0 ) THEN - CALL DLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) - IF ( PP.GT.0 ) - $ CALL DLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) - END IF -C -C If required, balance the compound matrix (default MAXRED). -C Workspace: need N. -C - IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, - $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) - WRKOPT = N - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) -C -C Reduce this system to one with the same invariant zeros and with -C D upper triangular of full row rank MU (the normal rank of the -C original system). -C Workspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C - RO = PP - SIGMA = 0 - NINFZ = 0 - CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, LDWORK, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - RANK = MU -C -C Pertranspose the system. -C - NUMU = NU + MU - IF ( NUMU.NE.0 ) THEN - MNU = MM + NU - NUMU1 = NUMU + 1 -C - DO 80 I = 1, NUMU - CALL DCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) - 80 CONTINUE -C - IF ( MU.NE.MM ) THEN -C -C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). -C - PP = MM - NN = NU - MM = MU -C -C Reduce the system to one with the same invariant zeros and -C with D square invertible. -C Workspace: need MAX( 1, MU + MAX(3*MU-1,N), -C MIN(M,N) + MAX(3*M-1,N+M) ); -C prefer larger. Note that MU <= MIN(P,M). -C - RO = PP - MM - SIGMA = MM - CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C - IF ( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( B A-lambda*I ) -C ( D C ) -C in order to reduce it to -C ( X AF-lambda*BF ) -C ( Y 0 ) -C with Y and BF square invertible. -C - CALL DLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) - CALL DLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) -C - IF ( RANK.NE.0 ) THEN - NU1 = NU + 1 - I1 = NU + MU -C -C Workspace: need 2*MIN(M,P); -C prefer MIN(M,P) + MIN(M,P)*NB. -C - CALL DTZRZF( MU, I1, AF(NU1,1), LDAF, DWORK, DWORK(MU+1), - $ LDWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) -C -C Workspace: need MIN(M,P) + N; -C prefer MIN(M,P) + N*NB. -C - CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, - $ AF(NU1,1), LDAF, DWORK, AF, LDAF, - $ DWORK(MU+1), LDWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) -C - CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, - $ AF(NU1,1), LDAF, DWORK, BF, LDBF, - $ DWORK(MU+1), LDWORK-MU, INFO ) -C - END IF -C -C Move AF and BF in the first columns. This assumes that -C DLACPY moves column by column. -C - CALL DLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) - IF ( RANK.NE.0 ) - $ CALL DLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) -C - END IF - END IF -C -C Set right Kronecker indices (column indices). -C - IF ( NKROR.GT.0 ) THEN - J = 1 -C - DO 120 I = 1, N + 1 -C - DO 100 II = J, J + KRONR(I) - 1 - IWORK(II) = I - 1 - 100 CONTINUE -C - J = J + KRONR(I) - KRONR(I) = 0 - 120 CONTINUE -C - NKROR = J - 1 -C - DO 140 I = 1, NKROR - KRONR(I) = IWORK(I) - 140 CONTINUE -C - END IF -C -C Set left Kronecker indices (row indices). -C - IF ( NKROL.GT.0 ) THEN - J = 1 -C - DO 180 I = 1, N + 1 -C - DO 160 II = J, J + KRONL(I) - 1 - IWORK(II) = I - 1 - 160 CONTINUE -C - J = J + KRONL(I) - KRONL(I) = 0 - 180 CONTINUE -C - NKROL = J - 1 -C - DO 200 I = 1, NKROL - KRONL(I) = IWORK(I) - 200 CONTINUE -C - END IF -C - IF ( N.GT.0 ) THEN - DINFZ = N -C - 220 CONTINUE - IF ( INFZ(DINFZ).EQ.0 ) THEN - DINFZ = DINFZ - 1 - IF ( DINFZ.GT.0 ) - $ GO TO 220 - END IF - END IF -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB08ND *** - END diff --git a/slycot/src/AB08NX.f b/slycot/src/AB08NX.f deleted file mode 100644 index ce7c9701..00000000 --- a/slycot/src/AB08NX.f +++ /dev/null @@ -1,447 +0,0 @@ - SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, - $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) system -C ( B A ) -C ( D C ) -C an (NU+MU)-by-(M+NU) "reduced" system -C ( B' A') -C ( D' C') -C having the same transmission zeros but with D' of full row rank. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C RO (input/output) INTEGER -C On entry, -C = P for the original system; -C = MAX(P-M, 0) for the pertransposed system. -C On exit, RO contains the last computed rank. -C -C SIGMA (input/output) INTEGER -C On entry, -C = 0 for the original system; -C = M for the pertransposed system. -C On exit, SIGMA contains the last computed value sigma in -C the algorithm. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) DOUBLE PRECISION array, dimension -C (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound input matrix of the system. -C On exit, the leading (NU+MU)-by-(M+NU) part of this array -C contains the reduced compound input matrix of the system. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C NINFZ (input/output) INTEGER -C On entry, the currently computed number of infinite zeros. -C It should be initialized to zero on the first call. -C NINFZ >= 0. -C On exit, the number of infinite zeros. -C -C INFZ (input/output) INTEGER array, dimension (N) -C On entry, INFZ(i) must contain the current number of -C infinite zeros of degree i, where i = 1,2,...,N, found in -C the previous call(s) of the routine. It should be -C initialized to zero on the first call. -C On exit, INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,N. -C -C KRONL (input/output) INTEGER array, dimension (N+1) -C On entry, this array must contain the currently computed -C left Kronecker (row) indices found in the previous call(s) -C of the routine. It should be initialized to zero on the -C first call. -C On exit, the leading NKROL elements of this array contain -C the left Kronecker (row) indices. -C -C MU (output) INTEGER -C The normal rank of the transfer function matrix of the -C original system. -C -C NU (output) INTEGER -C The dimension of the reduced system matrix and the number -C of (finite) invariant zeros if D' is invertible. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Supersedes Release 2.0 routine AB08BZ by F. Svaricek. -C -C REVISIONS -C -C V. Sima, Oct. 1997; Feb. 1998, Jan. 2009, Apr. 2009. -C A. Varga, May 1999; May 2001. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDABCD, LDWORK, M, MU, N, NINFZ, NKROL, - $ NU, P, RO, SIGMA - DOUBLE PRECISION SVLMAX, TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*) - DOUBLE PRECISION ABCD(LDABCD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, - $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT - DOUBLE PRECISION T -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DLAPMT, DLARFG, DLASET, SLCT_DLATZM, DORMQR, - $ DORMRQ, MB03OY, MB03PY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - NP = N + P - MPM = MIN( P, M ) - INFO = 0 - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN - INFO = -4 - ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN - INFO = -8 - ELSE IF( NINFZ.LT.0 ) THEN - INFO = -9 - ELSE - JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) - IF( LQUERY ) THEN - IF( M.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, MPM, - $ -1 ) ) - WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) - ELSE - WRKOPT = JWORK - END IF - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', NP, N, MIN( P, N ), - $ -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'LN', N, M+N, - $ MIN( P, N ), -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) - ELSE IF( LDWORK.LT.JWORK ) THEN - INFO = -18 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08NX', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C - MU = P - NU = N -C - IZ = 0 - IK = 1 - MM1 = M + 1 - ITAU = 1 - NKROL = 0 - WRKOPT = 1 -C -C Main reduction loop: -C -C M NU M NU -C NU [ B A ] NU [ B A ] -C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = -C TAU [ 0 C2 ] row size of RD) -C -C M NU-RO RO -C NU-RO [ B1 A11 A12 ] -C --> RO [ B2 A21 A22 ] (RO = rank(C2) = -C SIGMA [ RD C11 C12 ] col size of LC) -C TAU [ 0 0 LC ] -C -C M NU-RO -C NU-RO [ B1 A11 ] NU := NU - RO -C [----------] MU := RO + SIGMA -C --> RO [ B2 A21 ] D := [B2;RD] -C SIGMA [ RD C11 ] C := [A21;C11] -C - 20 IF ( MU.EQ.0 ) - $ GO TO 80 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - RO1 = RO - MNU = M + NU - IF ( M.GT.0 ) THEN - IF ( SIGMA.NE.0 ) THEN - IROW = NU + 1 -C -C Compress rows of D. First exploit triangular shape. -C Workspace: need M+N-1. -C - DO 40 I1 = 1, SIGMA - CALL DLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, T ) - CALL SLCT_DLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), - $ 1, T, - $ ABCD(IROW,I1+1), ABCD(IROW+1,I1+1), LDABCD, - $ DWORK ) - IROW = IROW + 1 - 40 CONTINUE - CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, - $ ABCD(NU+2,1), LDABCD ) - END IF -C -C Continue with Householder with column pivoting. -C -C The rank of D is the number of (estimated) singular values -C that are greater than TOL * MAX(SVLMAX,EMSV). This number -C includes the singular values of the first SIGMA columns. -C Integer workspace: need M; -C Workspace: need min(RO1,M) + 3*M - 1. RO1 <= P. -C - IF ( SIGMA.LT.M ) THEN - JWORK = ITAU + MIN( RO1, M ) - I1 = SIGMA + 1 - IROW = NU + I1 - CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, - $ SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), - $ DWORK(JWORK), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) -C -C Apply the column permutations to matrices B and part of D. -C - CALL DLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, - $ IWORK ) -C - IF ( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C Workspace: need min(RO1,M) + NU; -C prefer min(RO1,M) + NU*NB. -C - CALL DORMQR( 'Left', 'Transpose', RO1, NU, RANK, - $ ABCD(IROW,I1), LDABCD, DWORK(ITAU), - $ ABCD(IROW,MM1), LDABCD, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( RO1.GT.1 ) - $ CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, - $ ZERO, ABCD(IROW+1,I1), LDABCD ) - RO1 = RO1 - RANK - END IF - END IF - END IF -C - TAU = RO1 - SIGMA = MU - TAU -C -C Determination of the orders of the infinite zeros. -C - IF ( IZ.GT.0 ) THEN - INFZ(IZ) = INFZ(IZ) + RO - TAU - NINFZ = NINFZ + IZ*( RO - TAU ) - END IF - IF ( RO1.EQ.0 ) - $ GO TO 80 - IZ = IZ + 1 -C - IF ( NU.LE.0 ) THEN - MU = SIGMA - NU = 0 - RO = 0 - ELSE -C -C Compress the columns of C2 using RQ factorization with row -C pivoting, P * C2 = R * Q. -C - I1 = NU + SIGMA + 1 - MNTAU = MIN( TAU, NU ) - JWORK = ITAU + MNTAU -C -C The rank of C2 is the number of (estimated) singular values -C greater than TOL * MAX(SVLMAX,EMSV). -C Integer Workspace: need TAU; -C Workspace: need min(TAU,NU) + 3*TAU - 1. -C - CALL MB03PY( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, - $ SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) - IF ( RANK.GT.0 ) THEN - IROW = I1 + TAU - RANK -C -C Apply Q' to the first NU columns of [A; C1] from the right. -C Workspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; -C prefer min(TAU,NU) + (NU + SIGMA)*NB. -C - CALL DORMRQ( 'Right', 'Transpose', I1-1, NU, RANK, - $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), - $ ABCD(1,MM1), LDABCD, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Apply Q to the first NU rows and M + NU columns of [ B A ] -C from the left. -C Workspace: need min(TAU,NU) + M + NU; -C prefer min(TAU,NU) + (M + NU)*NB. -C - CALL DORMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, - $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), - $ ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - CALL DLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, - $ ABCD(IROW,MM1), LDABCD ) - IF ( RANK.GT.1 ) - $ CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, - $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) - END IF -C - RO = RANK - END IF -C -C Determine the left Kronecker indices (row indices). -C - KRONL(IK) = KRONL(IK) + TAU - RO - NKROL = NKROL + KRONL(IK) - IK = IK + 1 -C -C C and D are updated to [A21 ; C11] and [B2 ; RD]. -C - NU = NU - RO - MU = SIGMA + RO - IF ( RO.NE.0 ) - $ GO TO 20 -C - 80 CONTINUE - DWORK(1) = WRKOPT - RETURN -C *** Last line of AB08NX *** - END diff --git a/slycot/src/AB08NZ.f b/slycot/src/AB08NZ.f deleted file mode 100644 index 9638b4bb..00000000 --- a/slycot/src/AB08NZ.f +++ /dev/null @@ -1,576 +0,0 @@ - SUBROUTINE AB08NZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, - $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, - $ ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct for a linear multivariable system described by a -C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which -C f f -C has the invariant zeros of the system as generalized eigenvalues. -C The routine also computes the orders of the infinite zeros and the -C right and left Kronecker indices of the system (A,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the compound -C matrix (see METHOD) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables, i.e., the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) COMPLEX*16 array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) COMPLEX*16 array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) COMPLEX*16 array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) COMPLEX*16 array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NU (output) INTEGER -C The number of (finite) invariant zeros. -C -C RANK (output) INTEGER -C The normal rank of the transfer function matrix. -C -C DINFZ (output) INTEGER -C The maximum degree of infinite elementary divisors. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors -C of degree i, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C AF (output) COMPLEX*16 array, dimension (LDAF,N+MIN(P,M)) -C The leading NU-by-NU part of this array contains the -C coefficient matrix A of the reduced pencil. The remainder -C f -C of the leading (N+M)-by-(N+MIN(P,M)) part is used as -C internal workspace. -C -C LDAF INTEGER -C The leading dimension of array AF. LDAF >= MAX(1,N+M). -C -C BF (output) COMPLEX*16 array, dimension (LDBF,N+M) -C The leading NU-by-NU part of this array contains the -C coefficient matrix B of the reduced pencil. The -C f -C remainder of the leading (N+P)-by-(N+M) part is used as -C internal workspace. -C -C LDBF INTEGER -C The leading dimension of array BF. LDBF >= MAX(1,N+P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS -C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N,2*MAX(P,M))) -C -C ZWORK DOUBLE PRECISION array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M), -C MIN(M,N) + MAX(3*M-1,N+M) ). -C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with -C s = MAX(M,P). -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a state-space -C system (A,B,C,D) a regular pencil A - lambda*B which has the -C f f -C invariant zeros of the system as generalized eigenvalues as -C follows: -C -C (a) construct the (N+P)-by-(N+M) compound matrix (B A); -C (D C) -C -C (b) reduce the above system to one with the same invariant -C zeros and with D of full row rank; -C -C (c) pertranspose the system; -C -C (d) reduce the system to one with the same invariant zeros and -C with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C (A - lambda*I B) in order to reduce it to -C ( C D) -C -C (A - lambda*B X) -C ( f f ), with Y and B square invertible; -C ( 0 Y) f -C -C (f) compute the right and left Kronecker indices of the system -C (A,B,C,D), which together with the orders of the infinite -C zeros (determined by steps (a) - (e)) constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [2] and [1]). -C -C FURTHER COMMENTS -C -C In order to compute the invariant zeros of the system explicitly, -C a call to this routine may be followed by a call to the LAPACK -C Library routine ZGGEV with A = A , B = B and N = NU. -C f f -C If RANK = 0, the routine ZGEEV can be used (since B = I). -C f -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION DZERO - PARAMETER ( DZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, - $ LZWORK, M, N, NKROL, NKROR, NU, P, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) - COMPLEX*16 A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), - $ C(LDC,*), D(LDD,*), ZWORK(*) - DOUBLE PRECISION DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, - $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT - DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZCOPY, ZLACPY, ZLASET, - $ ZTZRZF, ZUNMRZ -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN - INFO = -22 - ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN - INFO = -24 - ELSE - II = MIN( P, M ) - I = MAX( II + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), - $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) - IF( LQUERY ) THEN - SVLMAX = DZERO - NINFZ = 0 - CALL AB8NXZ( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, - $ ZWORK, -1, INFO ) - WRKOPT = MAX( I, INT( ZWORK(1) ) ) - CALL AB8NXZ( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, - $ ZWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - NB = ILAENV( 1, 'ZGERQF', ' ', II, N+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N+II, II, -1 ) ) - WRKOPT = MAX( WRKOPT, II + N*NB ) - ELSE IF( LZWORK.LT.I ) THEN - INFO = -29 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB08NZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C - DINFZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( MIN( M, P ).EQ.0 ) THEN - NU = 0 - RANK = 0 - ZWORK(1) = ONE - RETURN - END IF - END IF -C - MM = M - NN = N - PP = P -C - DO 20 I = 1, N - INFZ(I) = 0 - 20 CONTINUE -C - IF ( M.GT.0 ) THEN - DO 40 I = 1, N + 1 - KRONR(I) = 0 - 40 CONTINUE - END IF -C - IF ( P.GT.0 ) THEN - DO 60 I = 1, N + 1 - KRONL(I) = 0 - 60 CONTINUE - END IF -C -C (Note: Comments in the code beginning "CWorkspace:" and -C "RWorkspace:" describe the minimal amount of complex and real -C workspace, respectively, needed at that point in the code, as -C well as the preferred amount for good performance.) -C - WRKOPT = 1 -C -C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). -C ( D C ) -C - CALL ZLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) - IF ( PP.GT.0 ) - $ CALL ZLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) - IF ( NN.GT.0 ) THEN - CALL ZLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) - IF ( PP.GT.0 ) - $ CALL ZLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) - END IF -C -C If required, balance the compound matrix (default MAXRED). -C RWorkspace: need N. -C - IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN - MAXRED = DZERO - CALL TB01IZ( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, - $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) - END IF -C -C If required, set tolerance. -C - THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) - TOLER = TOL - IF ( TOLER.LT.THRESH ) TOLER = THRESH - SVLMAX = ZLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) -C -C Reduce this system to one with the same invariant zeros and with -C D upper triangular of full row rank MU (the normal rank of the -C original system). -C RWorkspace: need 2*MAX(M,P); -C CWorkspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); -C prefer larger. -C - RO = PP - SIGMA = 0 - NINFZ = 0 - CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, - $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, ZWORK, - $ LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - RANK = MU -C -C Pertranspose the system. -C - NUMU = NU + MU - IF ( NUMU.NE.0 ) THEN - MNU = MM + NU - NUMU1 = NUMU + 1 -C - DO 80 I = 1, NUMU - CALL ZCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) - 80 CONTINUE -C - IF ( MU.NE.MM ) THEN -C -C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). -C - PP = MM - NN = NU - MM = MU -C -C Reduce the system to one with the same invariant zeros and -C with D square invertible. -C RWorkspace: need 2*M. -C CWorkspace: need MAX( 1, MU + MAX(3*MU-1,N), -C MIN(M,N) + MAX(3*M-1,N+M) ); -C prefer larger. Note that MU <= MIN(M,P). -C - RO = PP - MM - SIGMA = MM - CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, - $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, - $ DWORK, ZWORK, LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - END IF -C - IF ( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( B A-lambda*I ) -C ( D C ) -C in order to reduce it to -C ( X AF-lambda*BF ) -C ( Y 0 ) -C with Y and BF square invertible. -C - CALL ZLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) - CALL ZLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) -C - IF ( RANK.NE.0 ) THEN - NU1 = NU + 1 - I1 = NU + MU -C -C CWorkspace: need 2*MIN(M,P); -C prefer MIN(M,P) + MIN(M,P)*NB. -C - CALL ZTZRZF( MU, I1, AF(NU1,1), LDAF, ZWORK, ZWORK(MU+1), - $ LZWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) -C -C CWorkspace: need MIN(M,P) + N; -C prefer MIN(M,P) + N*NB. -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, - $ NU, AF(NU1,1), LDAF, ZWORK, AF, LDAF, - $ ZWORK(MU+1), LZWORK-MU, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, - $ NU, AF(NU1,1), LDAF, ZWORK, BF, LDBF, - $ ZWORK(MU+1), LZWORK-MU, INFO ) -C - END IF -C -C Move AF and BF in the first columns. This assumes that -C ZLACPY moves column by column. -C - CALL ZLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) - IF ( RANK.NE.0 ) - $ CALL ZLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) -C - END IF - END IF -C -C Set right Kronecker indices (column indices). -C - IF ( NKROR.GT.0 ) THEN - J = 1 -C - DO 120 I = 1, N + 1 -C - DO 100 II = J, J + KRONR(I) - 1 - IWORK(II) = I - 1 - 100 CONTINUE -C - J = J + KRONR(I) - KRONR(I) = 0 - 120 CONTINUE -C - NKROR = J - 1 -C - DO 140 I = 1, NKROR - KRONR(I) = IWORK(I) - 140 CONTINUE -C - END IF -C -C Set left Kronecker indices (row indices). -C - IF ( NKROL.GT.0 ) THEN - J = 1 -C - DO 180 I = 1, N + 1 -C - DO 160 II = J, J + KRONL(I) - 1 - IWORK(II) = I - 1 - 160 CONTINUE -C - J = J + KRONL(I) - KRONL(I) = 0 - 180 CONTINUE -C - NKROL = J - 1 -C - DO 200 I = 1, NKROL - KRONL(I) = IWORK(I) - 200 CONTINUE -C - END IF -C - IF ( N.GT.0 ) THEN - DINFZ = N -C - 220 CONTINUE - IF ( INFZ(DINFZ).EQ.0 ) THEN - DINFZ = DINFZ - 1 - IF ( DINFZ.GT.0 ) - $ GO TO 220 - END IF - END IF -C - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AB08NZ *** - END diff --git a/slycot/src/AB09AD.f b/slycot/src/AB09AD.f deleted file mode 100644 index 8d04fa63..00000000 --- a/slycot/src/AB09AD.f +++ /dev/null @@ -1,363 +0,0 @@ - SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, - $ B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for a stable original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate (B & T) -C model reduction method. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL <= 0 on entry. -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOB = 'B'; -C LIWORK = N, if JOB = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to the real Schur form failed; -C = 2: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09AD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the square-root Balance & Truncate method of [1] -C is used and, for DICO = 'C', the resulting model is balanced. -C By setting TOL <= 0, the routine can be used to compute balanced -C minimal state-space realizations of stable systems. -C -C If JOB = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used. -C By setting TOL <= 0, the routine can be used to compute minimal -C state-space realizations of stable systems. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routines SRBT and SRBFT. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, C100 - PARAMETER ( ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL FIXORD - INTEGER IERR, KI, KR, KT, KTI, KW, NN - DOUBLE PRECISION MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09AX, TB01ID, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -19 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Allocate working storage. -C - NN = N*N - KT = 1 - KR = KT + NN - KI = KR + N - KW = KI + N -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Reduce A to the real Schur form using an orthogonal similarity -C transformation A <- T'*A*T and apply the transformation to -C B and C: B <- T'*B and C <- C*T. -C - CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, - $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) - KTI = KT + NN - KW = KTI + NN -C - CALL AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, - $ LDC, HSV, DWORK(KT), N, DWORK(KTI), N, TOL, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C - RETURN -C *** Last line of AB09AD *** - END diff --git a/slycot/src/AB09AX.f b/slycot/src/AB09AX.f deleted file mode 100644 index 6d333337..00000000 --- a/slycot/src/AB09AX.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, HSV, T, LDT, TI, LDTI, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for a stable original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate model -C reduction method. The state dynamics matrix A of the original -C system is an upper quasi-triangular matrix in real Schur canonical -C form. The matrices of the reduced order system are computed using -C the truncation formulas: -C -C Ar = TI * A * T , Br = TI * B , Cr = C * T . -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C If INFO = 0 and NR > 0, the leading N-by-NR part of this -C array contains the right truncation matrix T. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) -C If INFO = 0 and NR > 0, the leading NR-by-N part of this -C array contains the left truncation matrix TI. -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL <= 0 on entry. -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOB = 'B', or -C LIWORK = N, if JOB = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09AX determines for -C the given system (1), the matrices of a reduced NR order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the square-root Balance & Truncate method of [1] -C is used and, for DICO = 'C', the resulting model is balanced. -C By setting TOL <= 0, the routine can be used to compute balanced -C minimal state-space realizations of stable systems. -C -C If JOB = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used. -C By setting TOL <= 0, the routine can be used to compute minimal -C state-space realizations of stable systems. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routines SRBT1 and SRBFT1. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C February 14, 1999, A. Varga, German Aerospace Center. -C February 22, 1999, V. Sima, Research Institute for Informatics. -C February 27, 2000, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDT, LDTI, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*), - $ T(LDT,*), TI(LDTI,*) -C .. Local Scalars .. - LOGICAL BAL, DISCR, FIXORD, PACKED - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, WRKOPT - DOUBLE PRECISION ATOL, RTOL, SCALEC, SCALEO, TEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, DLACPY, - $ DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, MA02AD, - $ MA02DD, MB03UD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BAL = LSAME( JOB, 'B' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -22 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09AX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) -C -C Allocate N*MAX(N,M,P) and N working storage for the matrices U -C and TAU, respectively. -C - KU = 1 - KTAU = KU + N*MAX( N, M, P ) - KW = KTAU + N - LDW = LDWORK - KW + 1 -C -C Copy B in U. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) -C -C If DISCR = .FALSE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . -C -C If DISCR = .TRUE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Copy C in U. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) -C -C If DISCR = .FALSE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . -C -C If DISCR = .TRUE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, - $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the -C matrix V, a packed (or unpacked) copy of Su, and save Su in V. -C (The locations for TAU are reused here.) -C - KV = KTAU - IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN - PACKED = .TRUE. - CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) - KW = KV + ( N*( N + 1 ) )/2 - ELSE - PACKED = .FALSE. - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) - KW = KV + N*N - END IF -C | x x | -C Compute Ru*Su in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition Ru*Su = V*S*UT -C of the upper triangular matrix Ru*Su, with UT in TI and V in U. -C -C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - ENDIF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Scale singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition S, U and V conformally as: -C -C S = diag(S1,S2), U = [U1,U2] (U' in TI) and V = [V1,V2] (in U). -C -C Compute the order of reduced system, as the order of S1. -C - ATOL = RTOL*HSV(1) - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( HSV(NR).LE.ATOL ) THEN - NR = 0 - IWARN = 1 - FIXORD = .FALSE. - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL, ATOL ) - NR = 0 - ENDIF - IF( .NOT.FIXORD ) THEN - DO 20 J = 1, N - IF( HSV(J).LE.ATOL ) GO TO 30 - NR = NR + 1 - 20 CONTINUE - 30 CONTINUE - ENDIF -C - IF( NR.EQ.0 ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute the truncation matrices. -C -C Compute TI' = Ru'*V1 in U. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NR, ONE, - $ T, LDT, DWORK(KU), N ) -C -C Compute T = Su*U1 (with Su packed, if not enough workspace). -C - CALL MA02AD( 'Full', NR, N, TI, LDTI, T, LDT ) - IF ( PACKED ) THEN - DO 40 J = 1, NR - CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), - $ T(1,J), 1 ) - 40 CONTINUE - ELSE - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, NR, - $ ONE, DWORK(KV), N, T, LDT ) - END IF -C - IF( BAL ) THEN - IJ = KU -C -C Square-Root B & T method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T*S1 and TI'*S1 -C - DO 50 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 50 CONTINUE - ELSE -C -C Balancing-Free B & T method. -C -C Compute orthogonal bases for the images of matrices T and TI'. -C -C Workspace: need N*MAX(N,M,P) + 2*NR; -C prefer N*MAX(N,M,P) + NR*(NB+1) -C (NB determined by ILAENV for DGEQRF). -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C -C Transpose TI' to obtain TI. -C - CALL MA02AD( 'Full', N, NR, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI*T) *TI in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) - END IF -C -C Compute TI*A*T (A is in RSF). -C - IJ = KU - DO 60 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NR, K, ONE, TI, LDTI, A(1,J), 1, - $ ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 60 CONTINUE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, - $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, N, ONE, TI, LDTI, - $ DWORK(KU), N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, N, ONE, - $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09AX *** - END diff --git a/slycot/src/AB09BD.f b/slycot/src/AB09BD.f deleted file mode 100644 index 0aa01b39..00000000 --- a/slycot/src/AB09BD.f +++ /dev/null @@ -1,385 +0,0 @@ - SUBROUTINE AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, - $ B, LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root Singular -C Perturbation Approximation (SPA) model reduction method. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root SPA method; -C = 'N': use the balancing-free square-root SPA method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to the real Schur form failed; -C = 2: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09BD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the balancing-based square-root SPA method of [1] -C is used and the resulting model is balanced. -C -C If JOB = 'N', the balancing-free square-root SPA method of [2] -C is used. -C By setting TOL1 = TOL2, the routine can be used to compute -C Balance & Truncate approximations. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems, -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRBFSP. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, singular perturbation approximation, -C state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL FIXORD - INTEGER IERR, KI, KR, KT, KTI, KW, NN - DOUBLE PRECISION MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09BX, TB01ID, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -22 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Allocate working storage. -C - NN = N*N - KT = 1 - KR = KT + NN - KI = KR + N - KW = KI + N -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Reduce A to the real Schur form using an orthogonal similarity -C transformation A <- T'*A*T and apply the transformation to -C B and C: B <- T'*B and C <- C*T. -C - CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, - $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - KTI = KT + NN - KW = KTI + NN - CALL AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, DWORK(KT), N, DWORK(KTI), N, - $ TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, - $ IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C - RETURN -C *** Last line of AB09BD *** - END diff --git a/slycot/src/AB09BX.f b/slycot/src/AB09BX.f deleted file mode 100644 index 438babc5..00000000 --- a/slycot/src/AB09BX.f +++ /dev/null @@ -1,662 +0,0 @@ - SUBROUTINE AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root -C Singular Perturbation Approximation (SPA) model reduction method. -C The state dynamics matrix A of the original system is an upper -C quasi-triangular matrix in real Schur canonical form. The matrices -C of a minimal realization are computed using the truncation -C formulas: -C -C Am = TI * A * T , Bm = TI * B , Cm = C * T . (1) -C -C Am, Bm, Cm and D serve further for computing the SPA of the given -C system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root SPA method; -C = 'N': use the balancing-free square-root SPA method. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C If INFO = 0 and NR > 0, the leading N-by-NR part of this -C array contains the right truncation matrix T in (1). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) -C If INFO = 0 and NR > 0, the leading NR-by-N part of this -C array contains the left truncation matrix TI in (1). -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (2) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09BX determines for -C the given system (1), the matrices of a reduced NR order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (3) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the balancing-based square-root SPA method of [1] -C is used and the resulting model is balanced. -C -C If JOB = 'N', the balancing-free square-root SPA method of [2] -C is used. -C By setting TOL1 = TOL2, the routine can be also used to compute -C Balance & Truncate approximations. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems, -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRBFP1. -C -C REVISIONS -C -C May 2, 1998. -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C February 14, 1999, A. Varga, German Aerospace Center. -C February 22, 1999, V. Sima, Research Institute for Informatics. -C February 27, 2000, V. Sima, Research Institute for Informatics. -C May 26, 2000, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Balancing, minimal state-space representation, model reduction, -C multivariable system, singular perturbation approximation, -C state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, - $ LDWORK, M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) -C .. Local Scalars .. - LOGICAL BAL, DISCR, FIXORD, PACKED - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, NMINR, - $ NR1, NS, WRKOPT - DOUBLE PRECISION ATOL, RCOND, RTOL, SCALEC, SCALEO, TEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, - $ DLACPY, DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, - $ MA02AD, MA02DD, MB03UD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BAL = LSAME( JOB, 'B' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -22 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09BX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) -C -C Allocate N*MAX(N,M,P) and N working storage for the matrices U -C and TAU, respectively. -C - KU = 1 - KTAU = KU + N*MAX( N, M, P ) - KW = KTAU + N - LDW = LDWORK - KW + 1 -C -C Copy B in U. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) -C -C If DISCR = .FALSE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . -C -C If DISCR = .TRUE., solve for Su the Lyapunov equation -C 2 -C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Copy C in U. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) -C -C If DISCR = .FALSE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . -C -C If DISCR = .TRUE., solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . -C -C Workspace: need N*(MAX(N,M,P) + 5); -C prefer larger. -C - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, - $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the -C matrix V, a packed (or unpacked) copy of Su, and save Su in V. -C (The locations for TAU are reused here.) -C - KV = KTAU - IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN - PACKED = .TRUE. - CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) - KW = KV + ( N*( N + 1 ) )/2 - ELSE - PACKED = .FALSE. - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) - KW = KV + N*N - END IF -C | x x | -C Compute Ru*Su in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition Ru*Su = V*S*UT -C of the upper triangular matrix Ru*Su, with UT in TI and V in U. -C -C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - ENDIF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Scale singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition S, U and V conformally as: -C -C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] -C (in U). -C -C Compute the order NR of reduced system, as the order of S1. -C - ATOL = RTOL*HSV(1) - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( HSV(NR).LE.ATOL ) THEN - NR = 0 - IWARN = 1 - FIXORD = .FALSE. - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL1, ATOL ) - NR = 0 - ENDIF - IF( .NOT.FIXORD ) THEN - DO 20 J = 1, N - IF( HSV(J).LE.ATOL ) GO TO 30 - NR = NR + 1 - 20 CONTINUE - 30 CONTINUE - ENDIF -C -C Finish if the order of the reduced model is zero. -C - IF( NR.EQ.0 ) THEN -C -C Compute only Dr using singular perturbation formulas. -C Workspace: need real 4*N; -C need integer 2*N. -C - CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, D, - $ LDD, RCOND, IWORK, DWORK, IERR ) - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute the order of minimal realization as the order of [S1 S2]. -C - NR1 = NR + 1 - NMINR = NR - IF( NR.LT.N ) THEN - ATOL = MAX( TOL2, RTOL*HSV(1) ) - DO 40 J = NR1, N - IF( HSV(J).LE.ATOL ) GO TO 50 - NMINR = NMINR + 1 - 40 CONTINUE - 50 CONTINUE - END IF -C -C Compute the order of S2. -C - NS = NMINR - NR -C -C Compute the truncation matrices. -C -C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, - $ ONE, T, LDT, DWORK(KU), N ) -C -C Compute T = | T1 T2 | = Su*| U1 U2 | -C (with Su packed, if not enough workspace). -C - CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) - IF ( PACKED ) THEN - DO 60 J = 1, NMINR - CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), - $ T(1,J), 1 ) - 60 CONTINUE - ELSE - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NMINR, ONE, DWORK(KV), N, T, LDT ) - END IF -C - IF( BAL ) THEN - IJ = KU -C -C Square-Root SPA method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T1*S1 and TI1'*S1 -C - DO 70 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 70 CONTINUE - ELSE -C -C Balancing-Free SPA method. -C -C Compute orthogonal bases for the images of matrices T1 and -C TI1'. -C -C Workspace: need N*MAX(N,M,P) + 2*NR; -C prefer N*MAX(N,M,P) + NR*(NB+1) -C (NB determined by ILAENV for DGEQRF). -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF - IF( NS.GT.0 ) THEN -C -C Compute orthogonal bases for the images of matrices T2 and -C TI2'. -C -C Workspace: need N*MAX(N,M,P) + 2*NS; -C prefer N*MAX(N,M,P) + NS*(NB+1) -C (NB determined by ILAENV for DGEQRF). - KW = KTAU + NS - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), - $ DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C -C Transpose TI' in TI. -C - CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI1*T1) *TI1 in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) -C - IF( NS.GT.0 ) THEN -C -1 -C Compute (TI2*T2) *TI2 in TI2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, - $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), - $ N ) - CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, - $ TI(NR1,1), LDTI, IERR ) - END IF - END IF -C -C Compute TI*A*T (A is in RSF). -C - IJ = KU - DO 80 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, - $ ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 80 CONTINUE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, - $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, - $ LDTI, DWORK(KU), N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, - $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) -C -C Compute the singular perturbation approximation if possible. -C Note that IERR = 1 on exit from AB09DD cannot appear here. -C -C Workspace: need real 4*(NMINR-NR); -C need integer 2*(NMINR-NR). -C - CALL AB09DD( DICO, NMINR, M, P, NR, A, LDA, B, LDB, C, LDC, D, - $ LDD, RCOND, IWORK, DWORK, IERR ) -C - IWORK(1) = NMINR - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09BX *** - END diff --git a/slycot/src/AB09CD.f b/slycot/src/AB09CD.f deleted file mode 100644 index 01567db2..00000000 --- a/slycot/src/AB09CD.f +++ /dev/null @@ -1,375 +0,0 @@ - SUBROUTINE AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, A, LDA, B, - $ LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using the -C optimal Hankel-norm approximation method in conjunction with -C square-root balancing. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), -C where KR is the multiplicity of the Hankel singular value -C HSV(NR+1), NR is the desired order on entry, and NMIN is -C the order of a minimal realization of the given system; -C NMIN is determined as the number of Hankel singular values -C greater than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M), if DICO = 'C'; -C LIWORK = MAX(1,N,M), if DICO = 'D'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2 ), where -C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is set -C automatically to a value corresponding to the order -C of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to the real Schur form failed; -C = 2: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed; -C = 4: the computation of stable projection failed; -C = 5: the order of computed stable projection differs -C from the order of Hankel-norm approximation. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09CD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The optimal Hankel-norm approximation method of [1], based on the -C square-root balancing projection formulas of [2], is employed. -C -C REFERENCES -C -C [1] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [2] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, April 1998. -C Based on the RASP routine OHNAP. -C -C REVISIONS -C -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C March 26, 2005, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, Hankel-norm approximation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL FIXORD - INTEGER IERR, KI, KL, KT, KW - DOUBLE PRECISION MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09CX, TB01ID, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2, - $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN - INFO = -21 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Reduce A to the real Schur form using an orthogonal similarity -C transformation A <- T'*A*T and apply the transformation to B -C and C: B <- T'*B and C <- C*T. -C - KT = 1 - KL = KT + N*N - KI = KL + N - KW = KI + N - CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, - $ DWORK(KL), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - CALL AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, LDC, - $ D, LDD, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ IWARN, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) -C - RETURN -C *** Last line of AB09CD *** - END diff --git a/slycot/src/AB09CX.f b/slycot/src/AB09CX.f deleted file mode 100644 index 7644d799..00000000 --- a/slycot/src/AB09CX.f +++ /dev/null @@ -1,558 +0,0 @@ - SUBROUTINE AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable -C original state-space representation (A,B,C,D) by using the optimal -C Hankel-norm approximation method in conjunction with square-root -C balancing. The state dynamics matrix A of the original system is -C an upper quasi-triangular matrix in real Schur canonical form. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), -C where KR is the multiplicity of the Hankel singular value -C HSV(NR+1), NR is the desired order on entry, and NMIN is -C the order of a minimal realization of the given system; -C NMIN is determined as the number of Hankel singular values -C greater than N*EPS*HNORM(A,B,C), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(A,B,C) is the Hankel norm of the system (computed -C in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values of -C the original system ordered decreasingly. HSV(1) is the -C Hankel norm of the system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(A,B,C), where c is a constant in the -C interval [0.00001,0.001], and HNORM(A,B,C) is the -C Hankel-norm of the given system (computed in HSV(1)). -C For computing a minimal realization, the recommended -C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH). -C This value is used by default if TOL1 <= 0 on entry. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the given system. The recommended value is -C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default -C if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M), if DICO = 'C'; -C LIWORK = MAX(1,N,M), if DICO = 'D'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1,LDW2 ), where -C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is set -C automatically to a value corresponding to the order -C of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed; -C = 3: the computation of stable projection failed; -C = 4: the order of computed stable projection differs -C from the order of Hankel-norm approximation. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09CX determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The optimal Hankel-norm approximation method of [1], based on the -C square-root balancing projection formulas of [2], is employed. -C -C REFERENCES -C -C [1] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [2] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, April 1998. -C Based on the RASP routine OHNAP1. -C -C REVISIONS -C -C November 11, 1998, V. Sima, Research Institute for Informatics, -C Bucharest. -C April 24, 2000, A. Varga, DLR Oberpfaffenhofen. -C April 8, 2001, A. Varga, DLR Oberpfaffenhofen. -C March 26, 2005, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, Hankel-norm approximation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars - LOGICAL DISCR, FIXORD - INTEGER I, I1, IERR, IRANK, J, KB1, KB2, KC1, KC2T, - $ KHSVP, KHSVP2, KR, KT, KTI, KU, KW, KW1, KW2, - $ LDB1, LDB2, LDC1, LDC2T, NA, NDIM, NKR1, NMINR, - $ NR1, NU, WRKOPT - DOUBLE PRECISION ATOL, RTOL, SKP, SKP2, SRRTOL -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB04MD, AB09AX, DAXPY, DCOPY, DGELSY, DGEMM, - $ DLACPY, DSWAP, MA02AD, MB01SD, TB01KD, TB01WD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2, - $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09CX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) - SRRTOL = SQRT( RTOL ) -C -C Allocate working storage. -C - KT = 1 - KTI = KT + N*N - KW = KTI + N*N -C -C Compute a minimal order balanced realization of the given system. -C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; -C prefer larger. -C - CALL AB09AX( DICO, 'Balanced', 'Automatic', N, M, P, NMINR, A, - $ LDA, B, LDB, C, LDC, HSV, DWORK(KT), N, DWORK(KTI), - $ N, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) -C - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute the order of reduced system. -C - ATOL = RTOL*HSV(1) - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( NR.GT.NMINR ) THEN - NR = NMINR - IWARN = 1 - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL1, ATOL ) - NR = 0 - DO 10 I = 1, NMINR - IF( HSV(I).LE.ATOL ) GO TO 20 - NR = NR + 1 - 10 CONTINUE - 20 CONTINUE - ENDIF -C - IF( NR.EQ.NMINR ) THEN - IWORK(1) = NMINR - DWORK(1) = WRKOPT - KW = N*(N+2)+1 -C -C Reduce Ar to a real Schur form. -C - CALL TB01WD( NMINR, M, P, A, LDA, B, LDB, C, LDC, - $ DWORK(2*N+1), N, DWORK, DWORK(N+1), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - RETURN - END IF - SKP = HSV(NR+1) -C -C If necessary, reduce the order such that HSV(NR) > HSV(NR+1). -C - 30 IF( NR.GT.0 ) THEN - IF( ABS( HSV(NR)-SKP ).LE.SRRTOL*SKP ) THEN - NR = NR - 1 - GO TO 30 - END IF - END IF -C -C Determine KR, the multiplicity of HSV(NR+1). -C - KR = 1 - DO 40 I = NR+2, NMINR - IF( ABS( HSV(I)-SKP ).GT.SRRTOL*SKP ) GO TO 50 - KR = KR + 1 - 40 CONTINUE - 50 CONTINUE -C -C For discrete-time case, apply the discrete-to-continuous bilinear -C transformation. -C - IF( DISCR ) THEN -C -C Workspace: need N; -C prefer larger. -C - CALL AB04MD( 'Discrete', NMINR, M, P, ONE, ONE, A, LDA, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C -C Define leading dimensions and offsets for temporary data. -C - NU = NMINR - NR - KR - NA = NR + NU - LDB1 = NA - LDC1 = P - LDB2 = KR - LDC2T = MAX( KR, M ) - NR1 = NR + 1 - NKR1 = MIN( NMINR, NR1 + KR ) -C - KHSVP = 1 - KHSVP2 = KHSVP + NA - KU = KHSVP2 + NA - KB1 = KU + P*M - KB2 = KB1 + LDB1*M - KC1 = KB2 + LDB2*M - KC2T = KC1 + LDC1*NA - KW = KC2T + LDC2T*P -C -C Save B2 and C2'. -C - CALL DLACPY( 'Full', KR, M, B(NR1,1), LDB, DWORK(KB2), LDB2 ) - CALL MA02AD( 'Full', P, KR, C(1,NR1), LDC, DWORK(KC2T), LDC2T ) - IF( NR.GT.0 ) THEN -C -C Permute the elements of HSV and of matrices A, B, C. -C - CALL DCOPY( NR, HSV(1), 1, DWORK(KHSVP), 1 ) - CALL DCOPY( NU, HSV(NKR1), 1, DWORK(KHSVP+NR), 1 ) - CALL DLACPY( 'Full', NMINR, NU, A(1,NKR1), LDA, A(1,NR1), LDA ) - CALL DLACPY( 'Full', NU, NA, A(NKR1,1), LDA, A(NR1,1), LDA ) - CALL DLACPY( 'Full', NU, M, B(NKR1,1), LDB, B(NR1,1), LDB ) - CALL DLACPY( 'Full', P, NU, C(1,NKR1), LDC, C(1,NR1), LDC ) -C -C Save B1 and C1. -C - CALL DLACPY( 'Full', NA, M, B, LDB, DWORK(KB1), LDB1 ) - CALL DLACPY( 'Full', P, NA, C, LDC, DWORK(KC1), LDC1 ) - END IF -C -C Compute U = C2*pinv(B2'). -C Workspace: need N*(M+P+2) + 2*M*P + -C max(min(KR,M)+3*M+1,2*min(KR,M)+P); -C prefer N*(M+P+2) + 2*M*P + -C max(min(KR,M)+2*M+(M+1)*NB,2*min(KR,M)+P*NB), -C where NB is the maximum of the block sizes for -C DGEQP3, DTZRZF, DTZRQF, DORMQR, and DORMRZ. -C - DO 55 J = 1, M - IWORK(J) = 0 - 55 CONTINUE - CALL DGELSY( KR, M, P, DWORK(KB2), LDB2, DWORK(KC2T), LDC2T, - $ IWORK, RTOL, IRANK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL MA02AD( 'Full', M, P, DWORK(KC2T), LDC2T, DWORK(KU), P ) -C -C Compute D <- D + HSV(NR+1)*U. -C - I = KU - DO 60 J = 1, M - CALL DAXPY( P, SKP, DWORK(I), 1, D(1,J), 1 ) - I = I + P - 60 CONTINUE -C - IF( NR.GT.0 ) THEN - SKP2 = SKP*SKP -C -C Compute G = inv(S1*S1-skp*skp*I), where S1 is the diagonal -C matrix of relevant singular values (of order NMINR - KR). -C - I1 = KHSVP2 - DO 70 I = KHSVP, KHSVP+NA-1 - DWORK(I1) = ONE / ( DWORK(I)*DWORK(I) - SKP2 ) - I1 = I1 + 1 - 70 CONTINUE -C -C Compute C <- C1*S1-skp*U*B1'. -C - CALL MB01SD( 'Column', P, NA, C, LDC, DWORK, DWORK(KHSVP) ) - CALL DGEMM( 'NoTranspose', 'Transpose', P, NA, M, -SKP, - $ DWORK(KU), P, DWORK(KB1), LDB1, ONE, C, LDC ) -C -C Compute B <- G*(S1*B1-skp*C1'*U). -C - CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP), DWORK ) - CALL DGEMM( 'Transpose', 'NoTranspose', NA, M, P, -SKP, - $ DWORK(KC1), LDC1, DWORK(KU), P, ONE, B, LDB ) - CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP2), DWORK ) -C -C Compute A <- -A1' - B*B1'. -C - DO 80 J = 2, NA - CALL DSWAP( J-1, A(1,J), 1, A(J,1), LDA ) - 80 CONTINUE - CALL DGEMM( 'NoTranspose', 'Transpose', NA, NA, M, -ONE, B, - $ LDB, DWORK(KB1), LDB1, -ONE, A, LDA ) -C -C Extract stable part. -C Workspace: need N*N+5*N; -C prefer larger. -C - KW1 = NA*NA + 1 - KW2 = KW1 + NA - KW = KW2 + NA - CALL TB01KD( 'Continuous', 'Stability', 'General', NA, M, P, - $ ZERO, A, LDA, B, LDB, C, LDC, NDIM, DWORK, NA, - $ DWORK(KW1), DWORK(KW2), DWORK(KW), LDWORK-KW+1, - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C - IF( NDIM.NE.NR ) THEN - INFO = 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C For discrete-time case, apply the continuous-to-discrete -C bilinear transformation. -C - IF( DISCR ) - $ CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, - $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, - $ INFO ) - END IF - IWORK(1) = NMINR - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09CX *** - END diff --git a/slycot/src/AB09DD.f b/slycot/src/AB09DD.f deleted file mode 100644 index 0ba78924..00000000 --- a/slycot/src/AB09DD.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, - $ D, LDD, RCOND, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model by using singular perturbation -C approximation formulas. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A; also the number of rows of matrix B and the -C number of columns of the matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows of -C matrices C and D. P >= 0. -C -C NR (input) INTEGER -C The order of the reduced order system. N >= NR >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix of the original system. -C On exit, the leading NR-by-NR part of this array contains -C the state dynamics matrix Ar of the reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix of the original system. -C On exit, the leading NR-by-M part of this array contains -C the input/state matrix Br of the reduced order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix of the original system. -C On exit, the leading P-by-NR part of this array contains -C the state/output matrix Cr of the reduced order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix of the original system. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix Dr of the reduced order system. -C If NR = 0 and the given system is stable, then D contains -C the steady state gain of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal condition number of the matrix A22-g*I -C (see METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*(N-NR) -C -C DWORK DOUBLE PRECISION array, dimension 4*(N-NR) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix A22-g*I (see METHOD) is numerically -C singular. -C -C METHOD -C -C Given the system (A,B,C,D), partition the system matrices as -C -C ( A11 A12 ) ( B1 ) -C A = ( ) , B = ( ) , C = ( C1 C2 ), -C ( A21 A22 ) ( B2 ) -C -C where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other -C submatrices have appropriate dimensions. -C -C The matrices of the reduced order system (Ar,Br,Cr,Dr) are -C computed according to the following residualization formulas: -C -1 -1 -C Ar = A11 + A12*(g*I-A22) *A21 , Br = B1 + A12*(g*I-A22) *B2 -C -1 -1 -C Cr = C1 + C2*(g*I-A22) *A21 , Dr = D + C2*(g*I-A22) *B2 -C -C where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRESID. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Model reduction, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, LDA, LDB, LDC, LDD, M, N, NR, P - DOUBLE PRECISION RCOND -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars - LOGICAL DISCR - INTEGER I, J, K, NS - DOUBLE PRECISION A22NRM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( NR.LT.0 .OR. NR.GT.N ) 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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( NR.EQ.N ) THEN - RCOND = ONE - RETURN - END IF -C - K = NR + 1 - NS = N - NR -C -C Compute: T = -A22 if DICO = 'C' and -C T = -A22+I if DICO = 'D'. -C - DO 20 J = K, N - DO 10 I = K, N - A(I,J) = -A(I,J) - 10 CONTINUE - IF( DISCR ) A(J,J) = A(J,J) + ONE - 20 CONTINUE -C -C Compute the LU decomposition of T. -C - A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK ) - CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO ) - IF( INFO.GT.0 ) THEN -C -C Error return. -C - RCOND = ZERO - INFO = 1 - RETURN - END IF - CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK, - $ IWORK(NS+1), INFO ) - IF( RCOND.LE.DLAMCH('E') ) THEN -C -C Error return. -C - INFO = 1 - RETURN - END IF -C -C Compute A21 <- INV(T)*A21. -C - CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1), - $ LDA, INFO ) -C -C Compute B2 <- INV(T)*B2. -C - CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1), - $ LDB, INFO ) -C -C Compute the residualized systems matrices. -C Ar = A11 + A12*INV(T)*A21. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K), - $ LDA, A(K,1), LDA, ONE, A, LDA ) -C -C Br = B1 + A12*INV(T)*B2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K), - $ LDA, B(K,1), LDB, ONE, B, LDB ) -C -C Cr = C1 + C2*INV(T)*A21. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K), - $ LDC, A(K,1), LDA, ONE, C, LDC ) -C -C Dr = D + C2*INV(T)*B2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K), - $ LDC, B(K,1), LDB, ONE, D, LDD ) -C - RETURN -C *** Last line of AB09DD *** - END diff --git a/slycot/src/AB09ED.f b/slycot/src/AB09ED.f deleted file mode 100644 index 7c3afb8e..00000000 --- a/slycot/src/AB09ED.f +++ /dev/null @@ -1,493 +0,0 @@ - SUBROUTINE AB09ED( DICO, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the optimal -C Hankel-norm approximation method in conjunction with square-root -C balancing for the ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the -C multiplicity of the Hankel singular value HSV(NR-NU+1), -C NR is the desired order on entry, and NMIN is the order -C of a minimal realization of the ALPHA-stable part of the -C given system; NMIN is determined as the number of Hankel -C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the -C ALPHA-stable part of the given system (computed in -C HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the given system -C (computed in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C This value is appropriate to compute a minimal realization -C of the ALPHA-stable part. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M), if DICO = 'C'; -C LIWORK = MAX(1,N,M), if DICO = 'D'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2 ), where -C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computed ALPHA-stable part is just stable, -C having stable eigenvalues very near to the imaginary -C axis (if DICO = 'C') or to the unit circle -C (if DICO = 'D'); -C = 4: the computation of Hankel singular values failed; -C = 5: the computation of stable projection in the -C Hankel-norm approximation algorithm failed; -C = 6: the order of computed stable projection in the -C Hankel-norm approximation algorithm differs -C from the order of Hankel-norm approximation. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09ED determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the ALPHA-stable part G1, the optimal Hankel-norm -C approximation method of [1], based on the square-root -C balancing projection formulas of [2], is employed. -C -C REFERENCES -C -C [1] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [2] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routines SADSDC and OHNAP. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. -C March 26, 2005, V. Sima, Research Institute for Informatics. -C -C KEYWORDS -C -C Balancing, Hankel-norm approximation, model reduction, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, NS, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD - INTEGER IERR, IWARNL, KI, KL, KU, KW, NRA, NU, NU1 - DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09CX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -20 - ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2, - $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + N*N - KI = KL + N - KW = KI + N -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Determine a reduced order approximation of the ALPHA-stable part. -C -C Workspace: need MAX( LDW1, LDW2 ), -C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ); -C prefer larger. -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 - CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) -C - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = IERR + 2 - RETURN - END IF -C - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) -C - RETURN -C *** Last line of AB09ED *** - END diff --git a/slycot/src/AB09FD.f b/slycot/src/AB09FD.f deleted file mode 100644 index cb954ba1..00000000 --- a/slycot/src/AB09FD.f +++ /dev/null @@ -1,649 +0,0 @@ - SUBROUTINE AB09FD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, - $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, NQ, HSV, - $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for an original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate (B & T) -C model reduction method in conjunction with stable coprime -C factorization techniques. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization is -C to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C FACT CHARACTER*1 -C Specifies the type of coprime factorization to be computed -C as follows: -C = 'S': compute a coprime factorization with prescribed -C stability degree ALPHA; -C = 'I': compute a coprime factorization with inner -C denominator. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR -C is the desired order on entry, NQ is the order of the -C computed coprime factorization of the given system, and -C NMIN is the order of a minimal realization of the extended -C system (see METHOD); NMIN is determined as the number of -C Hankel singular values greater than NQ*EPS*HNORM(Ge), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the -C extended system (computed in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). -C -C ALPHA (input) DOUBLE PRECISION -C If FACT = 'S', the desired stability degree for the -C factors of the coprime factorization (see SLICOT Library -C routines SB08ED/SB08FD). -C ALPHA < 0 for a continuous-time system (DICO = 'C'), and -C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). -C If FACT = 'I', ALPHA is not used. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the computed extended system Ge (see METHOD). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the NQ Hankel singular values of -C the extended system Ge ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced extended system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(Ge), where c is a constant in the -C interval [0.00001,0.001], and HNORM(Ge) is the -C Hankel-norm of the extended system (computed in HSV(1)). -C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if -C TOL1 <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B or C are considered zero (used for controllability or -C observability tests). -C If the user sets TOL2 <= 0, then an implicitly computed, -C default tolerance TOLDEF is used: -C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or -C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', -C where EPS is the machine precision, and NORM(.) denotes -C the 1-norm of a matrix. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = PM, if JOBMR = 'B', -C LIWORK = MAX(N,PM), if JOBMR = 'N', where -C PM = P, if JOBCF = 'L', -C PM = M, if JOBCF = 'R'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', -C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', -C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', -C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where -C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), -C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), -C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), -C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and -C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 10*K+I: -C I = 1: with ORDSEL = 'F', the selected order NR is -C greater than the order of the computed coprime -C factorization of the given system. In this case, -C the resulting NR is set automatically to a value -C corresponding to the order of a minimal -C realization of the system; -C K > 0: K violations of the numerical stability -C condition occured when computing the coprime -C factorization using pole assignment (see SLICOT -C Library routines SB08CD/SB08ED, SB08DD/SB08FD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT -C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); -C = 3: the matrix A has an observable or controllable -C eigenvalue on the imaginary axis if DICO = 'C' or -C on the unit circle if DICO = 'D'; -C = 4: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The subroutine AB09FD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C with the transfer-function matrix Gr, by using the -C balanced-truncation model reduction method in conjunction with -C a left coprime factorization (LCF) or a right coprime -C factorization (RCF) technique: -C -C 1. Compute the appropriate stable coprime factorization of G: -C -1 -1 -C G = R *Q (LCF) or G = Q*R (RCF). -C -C 2. Perform the model reduction algorithm on the extended system -C ( Q ) -C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) -C -C to obtain a reduced extended system with reduced factors -C ( Qr ) -C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). -C -C 3. Recover the reduced system from the reduced factors as -C -1 -1 -C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). -C -C The approximation error for the extended system satisfies -C -C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], -C -C where INFNORM(G) is the infinity-norm of G. -C -C If JOBMR = 'B', the square-root Balance & Truncate method of [1] -C is used for model reduction. -C If JOBMR = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used for model reduction. -C -C If FACT = 'S', the stable coprime factorization with prescribed -C stability degree ALPHA is computed by using the algorithm of [3]. -C If FACT = 'I', the stable coprime factorization with inner -C denominator is computed by using the algorithm of [4]. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, -C pp. 42-46, 1991. -C -C [3] Varga A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C [4] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, August 1998. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C -C KEYWORDS -C -C Balancing, coprime factorization, minimal realization, -C model reduction, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NQ, - $ NR, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD, LEFT, STABD - INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, - $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, - $ MAXMP, MP, NDR, PM, WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09AX, DLACPY, DLASET, SB08CD, SB08DD, SB08ED, - $ SB08FD, SB08GD, SB08HD, TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFT = LSAME( JOBCF, 'L' ) - STABD = LSAME( FACT, 'S' ) - MAXMP = MAX( M, P ) -C - LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 - LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) - LW2 = LW1 + - $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) - LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) - LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) - LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. - $ LSAME( JOBMR, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. - $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) - $ THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -11 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( ( LDWORK.LT.1 ) .OR. - $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. - $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. - $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. - $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Perform the coprime factor model reduction procedure. -C - KD = 1 - IF( LEFT ) THEN -C -1 -C Compute a LCF G = R *Q. -C - MP = M + P - KDR = KD + MAXMP*MAXMP - KC = KDR + MAXMP*P - KB = KC + MAXMP*N - KBR = KB + N*MAXMP - KW = KBR + N*P - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) - CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), MAXMP ) -C - IF( STABD ) THEN -C -C Compute a LCF with prescribed stability degree. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); -C prefer larger. -C - CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - ELSE -C -C Compute a LCF with inner denominator. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P + -C MAX(N*(N+5),P*(P+2),4*P,4*M). -C prefer larger; -C - CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - IF( MAXMP.GT.M ) THEN -C -C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive -C columns (see SLICOT Library routines SB08CD/SB08ED). -C - KBT = KBR - KBR = KB + N*M - KDT = KDR - KDR = KD + MAXMP*M - CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) - CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), - $ MAXMP ) - END IF -C -C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, - $ DWORK(KB), N, DWORK(KC), MAXMP, HSV, DWORK(KT), - $ N, DWORK(KTI), N, TOL1, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARNK, IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Rr *Qr. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need 4*P. -C - KW = KT - CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, - $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), - $ MAXMP, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Br and Cr to B and C. -C - CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) - CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) -C - ELSE -C -1 -C Compute a RCF G = Q*R . -C - PM = P + M - KDR = KD + P - KC = KD + PM*M - KCR = KC + P - KW = KC + PM*N - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) - CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), PM ) -C - IF( STABD ) THEN -C -C Compute a RCF with prescribed stability degree. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); -C prefer larger. -C - CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - ELSE -C -C Compute a RCF with inner denominator. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); -C prefer larger. -C - CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, - $ DWORK(KW), LWR, IWARN, INFO ) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C ( Q ) ( Qr ) -C Perform model reduction on ( R ) to determine ( Rr ). -C -C Workspace needed: (N+M)*(M+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, B, - $ LDB, DWORK(KC), PM, HSV, DWORK(KT), N, DWORK(KTI), - $ N, TOL1, IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, - $ IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Qr*Rr . -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need 4*M. -C - KW = KT - CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, - $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, - $ IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrix Cr to C. -C - CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09FD *** - END diff --git a/slycot/src/AB09GD.f b/slycot/src/AB09GD.f deleted file mode 100644 index c5516036..00000000 --- a/slycot/src/AB09GD.f +++ /dev/null @@ -1,681 +0,0 @@ - SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, - $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root Singular -C Perturbation Approximation (SPA) model reduction method in -C conjunction with stable coprime factorization techniques. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization is -C to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C FACT CHARACTER*1 -C Specifies the type of coprime factorization to be computed -C as follows: -C = 'S': compute a coprime factorization with prescribed -C stability degree ALPHA; -C = 'I': compute a coprime factorization with inner -C denominator. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR -C is the desired order on entry, NQ is the order of the -C computed coprime factorization of the given system, and -C NMIN is the order of a minimal realization of the extended -C system (see METHOD); NMIN is determined as the number of -C Hankel singular values greater than NQ*EPS*HNORM(Ge), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the -C extended system (computed in HSV(1)); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). -C -C ALPHA (input) DOUBLE PRECISION -C If FACT = 'S', the desired stability degree for the -C factors of the coprime factorization (see SLICOT Library -C routines SB08ED/SB08FD). -C ALPHA < 0 for a continuous-time system (DICO = 'C'), and -C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). -C If FACT = 'I', ALPHA is not used. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the computed extended system Ge (see METHOD). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the NQ Hankel singular values of -C the extended system Ge ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced extended system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(Ge), where c is a constant in the -C interval [0.00001,0.001], and HNORM(Ge) is the -C Hankel-norm of the extended system (computed in HSV(1)). -C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if -C TOL1 <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the extended system Ge (see METHOD). -C The recommended value is TOL2 = NQ*EPS*HNORM(Ge). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C TOL3 DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B or C are considered zero (used for controllability or -C observability tests by the coprime factorization method). -C If the user sets TOL3 <= 0, then an implicitly computed, -C default tolerance TOLDEF is used: -C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or -C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', -C where EPS is the machine precision, and NORM(.) denotes -C the 1-norm of a matrix. -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(1,2*N,PM)) -C where PM = P, if JOBCF = 'L', -C PM = M, if JOBCF = 'R'. -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', -C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', -C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', -C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where -C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), -C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + -C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), -C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), -C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and -C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 10*K+I: -C I = 1: with ORDSEL = 'F', the selected order NR is -C greater than the order of the computed coprime -C factorization of the given system. In this case, -C the resulting NR is set automatically to a value -C corresponding to the order of a minimal -C realization of the system; -C K > 0: K violations of the numerical stability -C condition occured when computing the coprime -C factorization using pole assignment (see SLICOT -C Library routines SB08CD/SB08ED, SB08DD/SB08FD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT -C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); -C = 3: the matrix A has an observable or controllable -C eigenvalue on the imaginary axis if DICO = 'C' or -C on the unit circle if DICO = 'D'; -C = 4: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The subroutine AB09GD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C with the transfer-function matrix Gr, by using the -C singular perturbation approximation (SPA) method in conjunction -C with a left coprime factorization (LCF) or a right coprime -C factorization (RCF) technique: -C -C 1. Compute the appropriate stable coprime factorization of G: -C -1 -1 -C G = R *Q (LCF) or G = Q*R (RCF). -C -C 2. Perform the model reduction algorithm on the extended system -C ( Q ) -C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) -C -C to obtain a reduced extended system with reduced factors -C ( Qr ) -C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). -C -C 3. Recover the reduced system from the reduced factors as -C -1 -1 -C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). -C -C The approximation error for the extended system satisfies -C -C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], -C -C where INFNORM(G) is the infinity-norm of G. -C -C If JOBMR = 'B', the balancing-based square-root SPA method of [1] -C is used for model reduction. -C If JOBMR = 'N', the balancing-free square-root SPA method of [2] -C is used for model reduction. -C By setting TOL1 = TOL2, the routine can be used to compute -C Balance & Truncate approximations. -C -C If FACT = 'S', the stable coprime factorization with prescribed -C stability degree ALPHA is computed by using the algorithm of [3]. -C If FACT = 'I', the stable coprime factorization with inner -C denominator is computed by using the algorithm of [4]. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems. -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, Vol. 2, -C pp. 1062-1065. -C -C [3] Varga A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C [4] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, August 1998. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C -C KEYWORDS -C -C Balancing, coprime factorization, minimal realization, -C model reduction, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, C100, ZERO - PARAMETER ( ONE = 1.0D0, C100 = 100.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, N, - $ NQ, NR, P - DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD, LEFT, STABD - INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, - $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, - $ MAXMP, MP, NDR, NMINR, PM, WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09BX, DLACPY, SB08CD, SB08DD, SB08ED, SB08FD, - $ SB08GD, SB08HD, TB01ID, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFT = LSAME( JOBCF, 'L' ) - STABD = LSAME( FACT, 'S' ) - MAXMP = MAX( M, P ) -C - LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 - LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) - LW2 = LW1 + - $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) - LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) - LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) - LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. - $ LSAME( JOBMR, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. - $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) - $ THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -11 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -23 - ELSE IF( ( LDWORK.LT.1 ) .OR. - $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. - $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. - $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. - $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN - INFO = -27 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09GD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NQ = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C - MAXRED = C100 - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Perform the coprime factor model reduction procedure. -C - KD = 1 - IF( LEFT ) THEN -C -1 -C Compute a LCF G = R *Q. -C - MP = M + P - KDR = KD + MAXMP*MAXMP - KC = KDR + MAXMP*P - KB = KC + MAXMP*N - KBR = KB + N*MAXMP - KW = KBR + N*P - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), MAXMP ) -C - IF( STABD ) THEN -C -C Compute a LCF with prescribed stability degree. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); -C prefer larger. -C - CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, - $ DWORK(KW), LWR, IWARN, INFO ) - ELSE -C -C Compute a LCF with inner denominator. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need N*P + -C MAX(N*(N+5),P*(P+2),4*P,4*M); -C prefer larger. -C - CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, - $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, - $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, - $ DWORK(KW), LWR, IWARN, INFO ) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - IF( MAXMP.GT.M ) THEN -C -C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive -C columns (see SLICOT Library routines SB08CD/SB08ED). -C - KBT = KBR - KBR = KB + N*M - KDT = KDR - KDR = KD + MAXMP*M - CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) - CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), - $ MAXMP ) - END IF -C -C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, - $ DWORK(KB), N, DWORK(KC), MAXMP, DWORK(KD), MAXMP, - $ HSV, DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - NMINR = IWORK(1) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Rr *Qr. -C -C Workspace needed: N*(2*MAX(M,P)+P) + -C MAX(M,P)*(MAX(M,P)+P); -C Additional workspace: need 4*P. -C - KW = KT - CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, - $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), - $ MAXMP, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Br, Cr, and Dr to B, C, and D, -C respectively. -C - CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) - CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) - CALL DLACPY( 'Full', P, M, DWORK(KD), MAXMP, D, LDD ) - ELSE -C -1 -C Compute a RCF G = Q*R . -C - PM = P + M - KDR = KD + P - KC = KD + PM*M - KCR = KC + P - KW = KC + PM*N - LWR = LDWORK - KW + 1 - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), PM ) -C - IF( STABD ) THEN -C -C Compute a RCF with prescribed stability degree. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); -C prefer larger. -C - CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, - $ DWORK(KW), LWR, IWARN, INFO) - ELSE -C -C Compute a RCF with inner denominator. -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); -C prefer larger. -C - CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, - $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, - $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, - $ DWORK(KW), LWR, IWARN, INFO) - END IF -C - IWARN = 10*IWARN - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IF( NQ.EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C ( Q ) ( Qr ) -C Perform model reduction on ( R ) to determine ( Rr ). -C -C Workspace needed: (N+M)*(M+P) + 2*N*N; -C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; -C prefer larger. -C - KT = KW - KTI = KT + NQ*NQ - KW = KTI + NQ*NQ - CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, - $ B, LDB, DWORK(KC), PM, DWORK(KD), PM, HSV, - $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) -C - IWARN = IWARN + IWARNK - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C - NMINR = IWORK(1) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -1 -C Compute the reduced order system Gr = Qr*Rr . -C -C Workspace needed: (N+M)*(M+P); -C Additional workspace: need 4*M. -C - KW = KT - CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, - $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, - $ IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Cr and Dr to C and D. -C - CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) - CALL DLACPY( 'Full', P, M, DWORK(KD), PM, D, LDD ) - END IF -C - IWORK(1) = NMINR - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09GD *** - END diff --git a/slycot/src/AB09HD.f b/slycot/src/AB09HD.f deleted file mode 100644 index 1468accc..00000000 --- a/slycot/src/AB09HD.f +++ /dev/null @@ -1,671 +0,0 @@ - SUBROUTINE AB09HD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ BETA, A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, - $ TOL1, TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the stochastic -C balancing approach in conjunction with the square-root or -C the balancing-free square-root Balance & Truncate (B&T) -C or Singular Perturbation Approximation (SPA) model reduction -C methods for the ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'F': use the balancing-free square-root -C Balance & Truncate method; -C = 'S': use the square-root Singular Perturbation -C Approximation method; -C = 'P': use the balancing-free square-root -C Singular Perturbation Approximation method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C P <= M if BETA = 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, and NMIN is the order of a minimal realization -C of the ALPHA-stable part of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than NS*EPS, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than MAX(TOL1,NS*EPS); -C NR can be further reduced to ensure that -C HSV(NR-NU) > HSV(NR+1-NU). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C BETA (input) DOUBLE PRECISION -C BETA > 0 specifies the absolute/relative error weighting -C parameter. A large positive value of BETA favours the -C minimization of the absolute approximation error, while a -C small value of BETA is appropriate for the minimization -C of the relative error. -C BETA = 0 means a pure relative error method and can be -C used only if rank(D) = P. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues in an -C upper real Schur form. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the phase system corresponding -C to the ALPHA-stable part of the original system. -C The Hankel singular values are ordered decreasingly. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value of TOL1 lies -C in the interval [0.00001,0.001]. -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS, where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C TOL1 < 1. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the phase system (see METHOD) corresponding -C to the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C TOL2 < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains RCOND, the reciprocal -C condition number of the U11 matrix from the expression -C used to compute the solution X = U21*inv(U11) of the -C Riccati equation for spectral factorization. -C A small value RCOND indicates possible ill-conditioning -C of the respective Riccati equation. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N*N + MB*(N+P) + MAX( 2, N*(MAX(N,MB,P)+5), -C 2*N*P+MAX(P*(MB+2),10*N*(N+1) ) ), -C where MB = M if BETA = 0 and MB = M+P if BETA > 0. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension 2*N -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system; in this case, the resulting NR is set equal -C to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NR corresponds -C to repeated singular values for the ALPHA-stable -C part, which are neither all included nor all -C excluded from the reduced model; in this case, the -C resulting NR is automatically decreased to exclude -C all repeated singular values; -C = 3: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system; in this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the reduction of the Hamiltonian matrix to real -C Schur form failed; -C = 3: the reordering of the real Schur form of the -C Hamiltonian matrix failed; -C = 4: the Hamiltonian matrix has less than N stable -C eigenvalues; -C = 5: the coefficient matrix U11 in the linear system -C X*U11 = U21 to determine X is singular to working -C precision; -C = 6: BETA = 0 and D has not a maximal row rank; -C = 7: the computation of Hankel singular values failed; -C = 8: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 9: the resulting order of reduced stable part is less -C than the number of unstable zeros of the stable -C part. -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09HD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that -C -C INFNORM[inv(conj(W))*(G-Gr)] <= -C (1+HSV(NR+NS-N+1)) / (1-HSV(NR+NS-N+1)) + ... -C + (1+HSV(NS)) / (1-HSV(NS)) - 1, -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, W is the right, minimum -C phase spectral factor satisfying -C -C G1*conj(G1) = conj(W)* W, (3) -C -C G1 is the NS-order ALPHA-stable part of G, and INFNORM(G) is the -C infinity-norm of G. HSV(1), ... , HSV(NS) are the Hankel-singular -C values of the stable part of the phase system (Ap,Bp,Cp) -C with the transfer-function matrix -C -C P = inv(conj(W))*G1. -C -C If BETA > 0, then the model reduction is performed on [G BETA*I] -C instead of G. This is the recommended approach to be used when D -C has not a maximal row rank or when a certain balance between -C relative and absolute approximation errors is desired. For -C increasingly large values of BETA, the obtained reduced system -C assymptotically approaches that computed by using the -C Balance & Truncate or Singular Perturbation Approximation methods. -C -C Note: conj(G) denotes either G'(-s) for a continuous-time system -C or G'(1/z) for a discrete-time system. -C inv(G) is the inverse of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2, -C -C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1 using the balancing stochastic method -C in conjunction with either the B&T [1,2] or SPA methods [3]. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C Note: The employed stochastic truncation algorithm [2,3] has the -C property that right half plane zeros of G1 remain as right half -C plane zeros of G1r. Thus, the order can not be chosen smaller than -C the sum of the number of unstable poles of G and the number of -C unstable zeros of G1. -C -C The reduction of the ALPHA-stable part G1 is done as follows. -C -C If JOB = 'B', the square-root stochastic Balance & Truncate -C method of [1] is used. -C For an ALPHA-stable continuous-time system (DICO = 'C'), -C the resulting reduced model is stochastically balanced. -C -C If JOB = 'F', the balancing-free square-root version of the -C stochastic Balance & Truncate method [1] is used to reduce -C the ALPHA-stable part G1. -C -C If JOB = 'S', the stochastic balancing method is used to reduce -C the ALPHA-stable part G1, in conjunction with the square-root -C version of the Singular Perturbation Approximation method [3,4]. -C -C If JOB = 'P', the stochastic balancing method is used to reduce -C the ALPHA-stable part G1, in conjunction with the balancing-free -C square-root version of the Singular Perturbation Approximation -C method [3,4]. -C -C REFERENCES -C -C [1] Varga A. and Fasol K.H. -C A new square-root balancing-free stochastic truncation model -C reduction algorithm. -C Proc. 12th IFAC World Congress, Sydney, 1993. -C -C [2] Safonov M. G. and Chiang R. Y. -C Model reduction for robust control: a Schur relative error -C method. -C Int. J. Adapt. Contr. Sign. Proc., vol. 2, pp. 259-272, 1988. -C -C [3] Green M. and Anderson B. D. O. -C Generalized balanced stochastic truncation. -C Proc. 29-th CDC, Honolulu, Hawaii, pp. 476-481, 1990. -C -C [4] Varga A. -C Balancing-free square-root algorithm for computing -C singular perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. The effectiveness of the -C accuracy enhancing technique depends on the accuracy of the -C solution of a Riccati equation. An ill-conditioned Riccati -C solution typically results when [D BETA*I] is nearly -C rank deficient. -C 3 -C The algorithm requires about 100N floating point operations. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Partly based on the RASP routine SRBFS, by A. Varga, 1992. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. -C Oct. 2001. -C -C KEYWORDS -C -C Minimal realization, model reduction, multivariable system, -C state-space model, state-space representation, -C stochastic balancing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, TWOBY3, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ TWOBY3 = TWO/3.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, NS, P - DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) - LOGICAL BWORK(*) -C .. Local Scalars .. - LOGICAL BTA, DISCR, FIXORD, LEQUIL, SPA - INTEGER IERR, IWARNL, KB, KD, KT, KTI, KU, KW, KWI, KWR, - $ LW, LWR, MB, N2, NMR, NN, NRA, NU, NU1, WRKOPT - DOUBLE PRECISION EPSM, MAXRED, RICOND, SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB04MD, AB09HY, AB09IX, DLACPY, DLASET, TB01ID, - $ TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEQUIL = LSAME( EQUIL, 'S' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - MB = M - IF( BETA.GT.ZERO ) MB = M + P - LW = 2*N*N + MB*(N+P) + MAX( 2, N*(MAX( N, MB, P )+5), - $ 2*N*P+MAX( P*(MB+2), 10*N*(N+1) ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 .OR. ( BETA.EQ.ZERO .AND. P.GT.M ) ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -9 - ELSE IF( BETA.LT.ZERO ) THEN - INFO = -10 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( TOL1.GE.ONE ) THEN - INFO = -21 - ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) - $ .OR. TOL2.GE.ONE ) THEN - INFO = -22 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. - $ ( BTA .AND. FIXORD .AND. NR.EQ.0 ) ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C - IF( LEQUIL ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Allocate working storage. -C - NN = N*N - KU = 1 - KWR = KU + NN - KWI = KWR + N - KW = KWI + N - LWR = LDWORK - KW + 1 -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPHA, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LWR, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 8 - END IF - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 3 - ELSE - NRA = 0 - END IF -C -C Finish if the system is completely unstable. -C - IF( NS.EQ.0 ) THEN - NR = NU - IWORK(1) = NS - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - N2 = N + N - KB = 1 - KD = KB + N*MB - KT = KD + P*MB - KTI = KT + N*N - KW = KTI + N*N -C -C Form [B 0] and [D BETA*I]. -C - CALL DLACPY( 'F', NS, M, B(NU1,1), LDB, DWORK(KB), N ) - CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) - IF( BETA.GT.ZERO ) THEN - CALL DLASET( 'F', NS, P, ZERO, ZERO, DWORK(KB+N*M), N ) - CALL DLASET( 'F', P, P, ZERO, BETA, DWORK(KD+P*M), P ) - END IF -C -C For discrete-time case, apply the discrete-to-continuous bilinear -C transformation to the stable part. -C - IF( DISCR ) THEN -C -C Real workspace: need N, prefer larger; -C Integer workspace: need N. -C - CALL AB04MD( 'Discrete', NS, MB, P, ONE, ONE, A(NU1,NU1), LDA, - $ DWORK(KB), N, C(1,NU1), LDC, DWORK(KD), P, - $ IWORK, DWORK(KT), LDWORK-KT+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KT) ) + KT - 1 ) - END IF -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R -C of the controllability and observability Grammians, respectively. -C Real workspace: need 2*N*N + MB*(N+P)+ -C MAX( 2, N*(MAX(N,MB,P)+5), -C 2*N*P+MAX(P*(MB+2), 10*N*(N+1) ) ); -C prefer larger. -C Integer workspace: need 2*N. -C - CALL AB09HY( NS, MB, P, A(NU1,NU1), LDA, DWORK(KB), N, - $ C(1,NU1), LDC, DWORK(KD), P, SCALEC, SCALEO, - $ DWORK(KTI), N, DWORK(KT), N, IWORK, DWORK(KW), - $ LDWORK-KW+1, BWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - RICOND = DWORK(KW+1) -C -C Compute a BTA or SPA of the stable part. -C Real workspace: need 2*N*N + MB*(N+P)+ -C MAX( 1, 2*N*N+5*N, N*MAX(MB,P) ). -C - EPSM = DLAMCH( 'Epsilon' ) - CALL AB09IX( 'C', JOB, 'Schur', ORDSEL, NS, MB, P, NRA, SCALEC, - $ SCALEO, A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, - $ DWORK(KD), P, DWORK(KTI), N, DWORK(KT), N, NMR, HSV, - $ MAX( TOL1, N*EPSM ), TOL2, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = 7 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Check if the resulting order is greater than the number of -C unstable zeros (this check is implicit by looking at Hankel -C singular values equal to 1). -C - IF( NRA.LT.NS .AND. HSV(NRA+1).GE.ONE-EPSM**TWOBY3 ) THEN - INFO = 9 - RETURN - END IF -C -C For discrete-time case, apply the continuous-to-discrete -C bilinear transformation. -C - IF( DISCR ) THEN - CALL AB04MD( 'Continuous', NRA, MB, P, ONE, ONE, - $ A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, - $ DWORK(KD), P, IWORK, DWORK, LDWORK, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C - CALL DLACPY( 'F', NRA, M, DWORK(KB), N, B(NU1,1), LDB ) - CALL DLACPY( 'F', P, M, DWORK(KD), P, D, LDD ) -C - NR = NRA + NU -C - IWORK(1) = NMR - DWORK(1) = WRKOPT - DWORK(2) = RICOND -C - RETURN -C *** Last line of AB09HD *** - END diff --git a/slycot/src/AB09HX.f b/slycot/src/AB09HX.f deleted file mode 100644 index 4bba6fe3..00000000 --- a/slycot/src/AB09HX.f +++ /dev/null @@ -1,690 +0,0 @@ - SUBROUTINE AB09HX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C stable state-space representation (A,B,C,D) by using the -C stochastic balancing approach in conjunction with the square-root -C or the balancing-free square-root Balance & Truncate (B&T) or -C Singular Perturbation Approximation (SPA) model reduction methods. -C The state dynamics matrix A of the original system is an upper -C quasi-triangular matrix in real Schur canonical form and D must be -C full row rank. -C -C For the B&T approach, the matrices of the reduced order system -C are computed using the truncation formulas: -C -C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) -C -C For the SPA approach, the matrices of a minimal realization -C (Am,Bm,Cm) are computed using the truncation formulas: -C -C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) -C -C Am, Bm, Cm and D serve further for computing the SPA of the given -C system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'F': use the balancing-free square-root -C Balance & Truncate method; -C = 'S': use the square-root Singular Perturbation -C Approximation method; -C = 'P': use the balancing-free square-root -C Singular Perturbation Approximation method. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. M >= P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR -C is the desired order on entry and NMIN is the order of a -C minimal realization of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than N*EPS, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A in a real Schur -C canonical form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values, -C ordered decreasingly, of the phase system. All singular -C values are less than or equal to 1. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C If INFO = 0 and NR > 0, the leading N-by-NR part of this -C array contains the right truncation matrix T in (1), for -C the B&T approach, or in (2), for the SPA approach. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) -C If INFO = 0 and NR > 0, the leading NR-by-N part of this -C array contains the left truncation matrix TI in (1), for -C the B&T approach, or in (2), for the SPA approach. -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value lies in the -C interval [0.00001,0.001]. -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = N*EPS, where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the phase system (see METHOD) corresponding -C to the given system. -C The recommended value is TOL2 = N*EPS. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit with INFO = 0, IWORK(1) contains the order of the -C minimal realization of the system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains RCOND, the reciprocal -C condition number of the U11 matrix from the expression -C used to compute the solution X = U21*inv(U11) of the -C Riccati equation for spectral factorization. -C A small value RCOND indicates possible ill-conditioning -C of the respective Riccati equation. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), -C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension 2*N -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than the order of a minimal realization of the -C given system. In this case, the resulting NR is -C set automatically to a value corresponding to the -C order of a minimal realization of the system. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'), or it is not in -C a real Schur form; -C = 2: the reduction of Hamiltonian matrix to real -C Schur form failed; -C = 3: the reordering of the real Schur form of the -C Hamiltonian matrix failed; -C = 4: the Hamiltonian matrix has less than N stable -C eigenvalues; -C = 5: the coefficient matrix U11 in the linear system -C X*U11 = U21, used to determine X, is singular to -C working precision; -C = 6: the feedthrough matrix D has not a full row rank P; -C = 7: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (3) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09HX determines for -C the given system (3), the matrices of a reduced NR-rder system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (4) -C -C such that -C -C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C If JOB = 'B', the square-root stochastic Balance & Truncate -C method of [1] is used and the resulting model is balanced. -C -C If JOB = 'F', the balancing-free square-root version of the -C stochastic Balance & Truncate method [1] is used. -C -C If JOB = 'S', the stochastic balancing method, in conjunction -C with the square-root version of the Singular Perturbation -C Approximation method [2,3] is used. -C -C If JOB = 'P', the stochastic balancing method, in conjunction -C with the balancing-free square-root version of the Singular -C Perturbation Approximation method [2,3] is used. -C -C By setting TOL1 = TOL2, the routine can be also used to compute -C Balance & Truncate approximations. -C -C REFERENCES -C -C [1] Varga A. and Fasol K.H. -C A new square-root balancing-free stochastic truncation -C model reduction algorithm. -C Proc. of 12th IFAC World Congress, Sydney, 1993. -C -C [2] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of balanced systems. -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [3] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on accuracy enhancing square-root -C or balancing-free square-root methods. The effectiveness of the -C accuracy enhancing technique depends on the accuracy of the -C solution of a Riccati equation. Ill-conditioned Riccati solution -C typically results when D is nearly rank deficient. -C 3 -C The algorithm requires about 100N floating point operations. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Partly based on the RASP routine SRBFS1, by A. Varga, 1992. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. -C -C KEYWORDS -C -C Balance and truncate, minimal state-space representation, -C model reduction, multivariable system, -C singular perturbation approximation, state-space model, -C stochastic balancing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, - $ LDWORK, M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) - LOGICAL BWORK(*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, SPA - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, - $ NMINR, NR1, NS, WRKOPT - DOUBLE PRECISION ATOL, RCOND, RICOND, SCALEC, SCALEO, TEMP, - $ TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB04MD, AB09DD, AB09HY, DGEMM, DGEMV, DGEQRF, - $ DGETRF, DGETRS, DLACPY, DORGQR, DSCAL, DTRMM, - $ DTRMV, MA02AD, MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LW = MAX( 2, N*(MAX( N, M, P )+5), - $ 2*N*P+MAX( P*(M+2), 10*N*(N+1) ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 .OR. P.GT.M ) THEN - INFO = -6 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -22 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09HX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C For discrete-time case, apply the discrete-to-continuous bilinear -C transformation. -C - IF( DISCR ) THEN -C -C Real workspace: need N, prefer larger; -C Integer workspace: need N. -C - CALL AB04MD( 'Discrete', N, M, P, ONE, ONE, A, LDA, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( N, INT( DWORK(1) ) ) - ELSE - WRKOPT = 0 - END IF -C -C Compute in TI and T the Cholesky factors Su and Ru of the -C controllability and observability Grammians, respectively. -C Real workspace: need MAX( 2, N*(MAX(N,M,P)+5), -C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ); -C prefer larger. -C Integer workspace: need 2*N. -C - CALL AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ SCALEC, SCALEO, TI, LDTI, T, LDT, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) - IF( INFO.NE.0) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - RICOND = DWORK(2) -C -C Save Su in V. -C - KU = 1 - KV = KU + N*N - KW = KV + N*N - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) -C | x x | -C Compute Ru*Su in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition Ru*Su = V*S*UT -C of the upper triangular matrix Ru*Su, with UT in TI and V in U. -C -C Workspace: need 2*N*N + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 7 - RETURN - ENDIF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Scale the singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition S, U and V conformally as: -C -C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] -C (in U). -C -C Compute the order NR of reduced system, as the order of S1. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ATOL = TOLDEF - IF( FIXORD ) THEN - IF( NR.GT.0 ) THEN - IF( HSV(NR).LE.ATOL ) THEN - NR = 0 - IWARN = 1 - FIXORD = .FALSE. - ENDIF - ENDIF - ELSE - ATOL = MAX( TOL1, ATOL ) - NR = 0 - ENDIF - IF( .NOT.FIXORD ) THEN - DO 20 J = 1, N - IF( HSV(J).LE.ATOL ) GO TO 30 - NR = NR + 1 - 20 CONTINUE - 30 CONTINUE - ENDIF -C -C Compute the order of minimal realization as the order of [S1 S2]. -C - NR1 = NR + 1 - NMINR = NR - IF( NR.LT.N ) THEN - IF( SPA ) ATOL = MAX( TOL2, TOLDEF ) - DO 40 J = NR1, N - IF( HSV(J).LE.ATOL ) GO TO 50 - NMINR = NMINR + 1 - 40 CONTINUE - 50 CONTINUE - END IF -C -C Finish if the order is zero. -C - IF( NR.EQ.0 ) THEN - IF( SPA ) THEN - CALL AB09DD( 'Continuous', N, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) - IWORK(1) = NMINR - ELSE - IWORK(1) = 0 - END IF - DWORK(1) = WRKOPT - DWORK(2) = RICOND - RETURN - END IF -C -C Compute NS, the order of S2. -C Note: For BTA, NS is always zero, because NMINR = NR. -C - NS = NMINR - NR -C -C Compute the truncation matrices. -C -C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, - $ ONE, T, LDT, DWORK(KU), N ) -C -C Compute T = | T1 T2 | = Su*| U1 U2 | . -C - CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NMINR, ONE, DWORK(KV), N, T, LDT ) - KTAU = KV -C - IF( BAL ) THEN - IJ = KU -C -C Square-Root B&T/SPA method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T1*S1 and TI1'*S1 . -C - DO 70 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 70 CONTINUE - ELSE -C -C Balancing-Free B&T/SPA method. -C -C Compute orthogonal bases for the images of matrices T1 and -C TI1'. -C -C Workspace: need N*MAX(N,M,P) + 2*NR; -C prefer N*MAX(N,M,P) + NR*(NB+1) -C (NB determined by ILAENV for DGEQRF). -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF - IF( NS.GT.0 ) THEN -C -C Compute orthogonal bases for the images of matrices T2 and -C TI2'. -C -C Workspace: need N*MAX(N,M,P) + 2*NS; -C prefer N*MAX(N,M,P) + NS*(NB+1) -C (NB determined by ILAENV for DGEQRF). - KW = KTAU + NS - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), - $ DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C -C Transpose TI' in TI. -C - CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI1*T1) *TI1 in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) -C - IF( NS.GT.0 ) THEN -C -1 -C Compute (TI2*T2) *TI2 in TI2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, - $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), - $ N ) - CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, - $ TI(NR1,1), LDTI, IERR ) - END IF - END IF -C -C Compute TI*A*T (A is in RSF). -C - IJ = KU - DO 80 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, - $ ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 80 CONTINUE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, - $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, - $ LDTI, DWORK(KU), N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, - $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) -C -C Compute the singular perturbation approximation if possible. -C Note that IERR = 1 on exit from AB09DD cannot appear here. -C -C Workspace: need real 4*(NMINR-NR); -C need integer 2*(NMINR-NR). -C - CALL AB09DD( 'Continuous', NMINR, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) -C -C For discrete-time case, apply the continuous-to-discrete -C bilinear transformation. -C - IF( DISCR ) THEN - CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF - IWORK(1) = NMINR - DWORK(1) = WRKOPT - DWORK(2) = RICOND -C - RETURN -C *** Last line of AB09HX *** - END diff --git a/slycot/src/AB09HY.f b/slycot/src/AB09HY.f deleted file mode 100644 index 78a1093e..00000000 --- a/slycot/src/AB09HY.f +++ /dev/null @@ -1,396 +0,0 @@ - SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ SCALEC, SCALEO, S, LDS, R, LDR, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factors Su and Ru of the controllability -C Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru, -C respectively, satisfying -C -C A*P + P*A' + scalec^2*B*B' = 0, (1) -C -C A'*Q + Q*A + scaleo^2*Cw'*Cw = 0, (2) -C -C where -C Cw = Hw - Bw'*X, -C Hw = inv(Dw)*C, -C Bw = (B*D' + P*C')*inv(Dw'), -C D*D' = Dw*Dw' (Dw upper triangular), -C -C and, with Aw = A - Bw*Hw, X is the stabilizing solution of the -C Riccati equation -C -C Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0. (3) -C -C The P-by-M matrix D must have full row rank. Matrix A must be -C stable and in a real Schur form. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of state-space representation, i.e., -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. M >= P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C stable state dynamics matrix A in a real Schur canonical -C form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B, corresponding to the Schur matrix A. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C, corresponding to the Schur -C matrix A. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must -C contain the full row rank input/output matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian in (1). -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian in (2). -C -C S (output) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Su of the cotrollability -C Grammian P = Su*Su' satisfying (1). -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Ru of the observability -C Grammian Q = Ru'*Ru satisfying (2). -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*N -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains RCOND, the reciprocal -C condition number of the U11 matrix from the expression -C used to compute X = U21*inv(U11). A small value RCOND -C indicates possible ill-conditioning of the Riccati -C equation (3). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), -C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension 2*N -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable or is not in a -C real Schur form; -C = 2: the reduction of Hamiltonian matrix to real Schur -C form failed; -C = 3: the reordering of the real Schur form of the -C Hamiltonian matrix failed; -C = 4: the Hamiltonian matrix has less than N stable -C eigenvalues; -C = 5: the coefficient matrix U11 in the linear system -C X*U11 = U21, used to determine X, is singular to -C working precision; -C = 6: the feedthrough matrix D has not a full row rank P. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. -C -C KEYWORDS -C -C Minimal realization, model reduction, multivariable system, -C state-space model, state-space representation, -C stochastic balancing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N, - $ P - DOUBLE PRECISION SCALEC, SCALEO -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), R(LDR,*), S(LDS,*) - LOGICAL BWORK(*) -C .. Local Scalars .. - INTEGER I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU, - $ KW, KWI, KWR, LW, N2, WRKOPT - DOUBLE PRECISION RCOND, RTOL -C .. External Functions .. - DOUBLE PRECISION DLANGE, DLAMCH - EXTERNAL DLANGE, DLAMCH -C .. External Subroutines .. - EXTERNAL DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM, - $ DTRSM, SB02MD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LW = MAX( 2, N*( MAX( N, M, P ) + 5 ), - $ 2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) ) -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 .OR. P.GT.M ) 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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09HY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALEC = ONE - SCALEO = ONE - IF( MIN( N, M, P ).EQ.0 ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C Solve for Su the Lyapunov equation -C 2 -C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . -C -C Workspace: need N*(MAX(N,M) + 5); -C prefer larger. -C - KU = 1 - KTAU = KU + N*MAX( N, M ) - KW = KTAU + N -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), - $ LDWORK - KW + 1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M), -C where Q2 = inv(Dw)*D. -C Workspace: need 2*N*P + P*M. -C - KBW = 1 - KCW = KBW + P*N - KD = KCW + P*N - KDW = KD + P*(M - P) - KTAU = KD + P*M - KW = KTAU + P -C -C Compute an upper-triangular Dw such that D*D' = Dw*Dw', using -C the RQ-decomposition of D: D = [0 Dw]*( Q1 ). -C ( Q2 ) -C Additional workspace: need 2*P; prefer P + P*NB. -C - CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) - CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW), - $ LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Check the full row rank of D. -C - RTOL = DBLE( M ) * DLAMCH( 'E' ) * - $ DLANGE( '1', P, M, D, LDD, DWORK ) - DO 10 I = KDW, KDW+P*P-1, P+1 - IF( ABS( DWORK(I) ).LE.RTOL ) THEN - INFO = 6 - RETURN - END IF - 10 CONTINUE -C -1 -C Compute Hw = Dw *C. -C - CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P ) - CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N, - $ ONE, DWORK(KDW), P, DWORK(KCW), P ) -C -C Compute Bw' = inv(Dw)*(D*B' + C*Su*Su'). -C -C Compute first Hw*Su*Su' in Bw'. -C - CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P ) - CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N, - $ ONE, S, LDS, DWORK(KBW), P ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N, - $ ONE, S, LDS, DWORK(KBW), P ) -C -C Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal -C matrix ( Q1 ) from the RQ decomposition of D. -C ( Q2 ) -C Additional workspace: need P; prefer P*NB. -C - CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW), - $ LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute Bw' <- Bw' + Q2*B'. -C - CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE, - $ DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P ) -C -C Compute Aw = A - Bw*Hw in R. -C - CALL DLACPY( 'F', N, N, A, LDA, R, LDR ) - CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE, - $ DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR ) -C -C Allocate storage to solve the Riccati equation (3) for -C G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N). -C - N2 = N + N - KG = KD - KQ = KG + N*N - KWR = KQ + N*N - KWI = KWR + N2 - KS = KWI + N2 - KU = KS + N2*N2 - KW = KU + N2*N2 -C -C Compute G = -Bw*Bw'. -C - CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO, - $ DWORK(KG), N ) -C -C Compute Q = Hw'*Hw. -C - CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO, - $ DWORK(KQ), N ) -C -C Solve -C -C Aw'*X + X*Aw + Q - X*G*X = 0, -C -C with Q = Hw'*Hw and G = -Bw*Bw'. -C Additional workspace: need 6*N; -C prefer larger. -C - CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable', - $ N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND, - $ DWORK(KWR), DWORK(KWI), DWORK(KS), N2, - $ DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1, - $ BWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute Cw = Hw - Bw'*X. -C - CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE, - $ DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P ) -C -C Solve for Ru the Lyapunov equation -C 2 -C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * Cw'*Cw = 0 . -C -C Workspace: need N*(MAX(N,P) + 5); -C prefer larger. -C - KTAU = KCW + N*MAX( N, P ) - KW = KTAU + N -C - CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P, - $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), - $ LDWORK - KW + 1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Save optimal workspace and RCOND. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of AB09HY *** - END diff --git a/slycot/src/AB09ID.f b/slycot/src/AB09ID.f deleted file mode 100644 index 2448d466..00000000 --- a/slycot/src/AB09ID.f +++ /dev/null @@ -1,1048 +0,0 @@ - SUBROUTINE AB09ID( DICO, JOBC, JOBO, JOB, WEIGHT, EQUIL, ORDSEL, - $ N, M, P, NV, PV, NW, MW, NR, ALPHA, ALPHAC, - $ ALPHAO, A, LDA, B, LDB, C, LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the frequency -C weighted square-root or balancing-free square-root -C Balance & Truncate (B&T) or Singular Perturbation Approximation -C (SPA) model reduction methods. The algorithm tries to minimize -C the norm of the frequency-weighted error -C -C ||V*(G-Gr)*W|| -C -C where G and Gr are the transfer-function matrices of the original -C and reduced order models, respectively, and V and W are -C frequency-weighting transfer-function matrices. V and W must not -C have poles on the imaginary axis for a continuous-time -C system or on the unit circle for a discrete-time system. -C If G is unstable, only the ALPHA-stable part of G is reduced. -C In case of possible pole-zero cancellations in V*G and/or G*W, -C the absolute values of parameters ALPHAO and/or ALPHAC must be -C different from 1. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'F': use the balancing-free square-root -C Balance & Truncate method; -C = 'S': use the square-root Singular Perturbation -C Approximation method; -C = 'P': use the balancing-free square-root -C Singular Perturbation Approximation method. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NV (input) INTEGER -C The order of the matrix AV. Also the number of rows of -C the matrix BV and the number of columns of the matrix CV. -C NV represents the dimension of the state vector of the -C system with the transfer-function matrix V. NV >= 0. -C -C PV (input) INTEGER -C The number of rows of the matrices CV and DV. PV >= 0. -C PV represents the dimension of the output vector of the -C system with the transfer-function matrix V. -C -C NW (input) INTEGER -C The order of the matrix AW. Also the number of rows of -C the matrix BW and the number of columns of the matrix CW. -C NW represents the dimension of the state vector of the -C system with the transfer-function matrix W. NW >= 0. -C -C MW (input) INTEGER -C The number of columns of the matrices BW and DW. MW >= 0. -C MW represents the dimension of the input vector of the -C system with the transfer-function matrix W. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, NMIN is the number of frequency-weighted Hankel -C singular values greater than NS*EPS*S1, EPS is the -C machine precision (see LAPACK Library Routine DLAMCH) -C and S1 is the largest Hankel singular value (computed -C in HSV(1)); NR can be further reduced to ensure -C HSV(NR-NU) > HSV(NR+1-NU); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than MAX(TOL1,NS*EPS*S1). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C ALPHAC (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted controllability Grammian (see METHOD); -C ABS(ALPHAC) <= 1. -C -C ALPHAO (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted observability Grammian (see METHOD); -C ABS(ALPHAO) <= 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV -C part of this array must contain the state matrix AV of -C the system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NVR-by-NVR part of this array -C contains the state matrix of a minimal realization of V -C in a real Schur form. NVR is returned in IWORK(2). -C AV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDAV INTEGER -C The leading dimension of array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part -C of this array must contain the input matrix BV of the -C system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NVR-by-P part of this array contains -C the input matrix of a minimal realization of V. -C BV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDBV INTEGER -C The leading dimension of array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading PV-by-NV -C part of this array must contain the output matrix CV of -C the system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading PV-by-NVR part of this array -C contains the output matrix of a minimal realization of V. -C CV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDCV INTEGER -C The leading dimension of array CV. -C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this -C array must contain the feedthrough matrix DV of the system -C with the transfer-function matrix V. -C DV is not referenced if WEIGHT = 'R' or 'N', -C or MIN(N,M,P) = 0. -C -C LDDV INTEGER -C The leading dimension of array DV. -C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW -C part of this array must contain the state matrix AW of -C the system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NWR-by-NWR part of this array -C contains the state matrix of a minimal realization of W -C in a real Schur form. NWR is returned in IWORK(3). -C AW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDAW INTEGER -C The leading dimension of array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,MW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-MW -C part of this array must contain the input matrix BW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading NWR-by-MW part of this array -C contains the input matrix of a minimal realization of W. -C BW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDBW INTEGER -C The leading dimension of array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part -C of this array must contain the output matrix CW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and -C INFO = 0, the leading M-by-NWR part of this array contains -C the output matrix of a minimal realization of W. -C CW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDCW INTEGER -C The leading dimension of array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) -C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this -C array must contain the feedthrough matrix DW of the system -C with the transfer-function matrix W. -C DW is not referenced if WEIGHT = 'L' or 'N', -C or MIN(N,M,P) = 0. -C -C LDDW INTEGER -C The leading dimension of array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of this array contain -C the frequency-weighted Hankel singular values, ordered -C decreasingly, of the ALPHA-stable part of the original -C system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*S1, where c is a constant in the -C interval [0.00001,0.001], and S1 is the largest -C frequency-weighted Hankel singular value of the -C ALPHA-stable part of the original system (computed -C in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*S1, where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*S1. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension -C ( MAX( 3, LIWRK1, LIWRK2, LIWRK3 ) ), where -C LIWRK1 = 0, if JOB = 'B'; -C LIWRK1 = N, if JOB = 'F'; -C LIWRK1 = 2*N, if JOB = 'S' or 'P'; -C LIWRK2 = 0, if WEIGHT = 'R' or 'N' or NV = 0; -C LIWRK2 = NV+MAX(P,PV), if WEIGHT = 'L' or 'B' and NV > 0; -C LIWRK3 = 0, if WEIGHT = 'L' or 'N' or NW = 0; -C LIWRK3 = NW+MAX(M,MW), if WEIGHT = 'R' or 'B' and NW > 0. -C On exit, if INFO = 0, IWORK(1) contains the order of a -C minimal realization of the stable part of the system, -C IWORK(2) and IWORK(3) contain the actual orders -C of the state space realizations of V and W, respectively. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LMINL, LMINR, LRCF, -C 2*N*N + MAX( 1, LLEFT, LRIGHT, 2*N*N+5*N, -C N*MAX(M,P) ) ), -C where -C LMINL = 0, if WEIGHT = 'R' or 'N' or NV = 0; otherwise, -C LMINL = MAX(LLCF,NV+MAX(NV,3*P)) if P = PV; -C LMINL = MAX(P,PV)*(2*NV+MAX(P,PV))+ -C MAX(LLCF,NV+MAX(NV,3*P,3*PV)) if P <> PV; -C LRCF = 0, and -C LMINR = 0, if WEIGHT = 'L' or 'N' or NW = 0; otherwise, -C LMINR = NW+MAX(NW,3*M) if M = MW; -C LMINR = 2*NW*MAX(M,MW)+NW+MAX(NW,3*M,3*MW) if M <> MW; -C LLCF = PV*(NV+PV)+PV*NV+MAX(NV*(NV+5), PV*(PV+2), -C 4*PV, 4*P); -C LRCF = MW*(NW+MW)+MAX(NW*(NW+5),MW*(MW+2),4*MW,4*M) -C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) -C if WEIGHT = 'L' or 'B' and PV > 0; -C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; -C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) -C if WEIGHT = 'R' or 'B' and MW > 0; -C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system; in this case, the resulting NR is set equal -C to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NR corresponds -C to repeated singular values for the ALPHA-stable -C part, which are neither all included nor all -C excluded from the reduced model; in this case, the -C resulting NR is automatically decreased to exclude -C all repeated singular values; -C = 3: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system; in this case NR is set equal to the -C order of the ALPHA-unstable part. -C = 10+K: K violations of the numerical stability condition -C occured during the assignment of eigenvalues in the -C SLICOT Library routines SB08CD and/or SB08DD. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 3: the reduction to a real Schur form of the state -C matrix of a minimal realization of V failed; -C = 4: a failure was detected during the ordering of the -C real Schur form of the state matrix of a minimal -C realization of V or in the iterative process to -C compute a left coprime factorization with inner -C denominator; -C = 5: if DICO = 'C' and the matrix AV has an observable -C eigenvalue on the imaginary axis, or DICO = 'D' and -C AV has an observable eigenvalue on the unit circle; -C = 6: the reduction to a real Schur form of the state -C matrix of a minimal realization of W failed; -C = 7: a failure was detected during the ordering of the -C real Schur form of the state matrix of a minimal -C realization of W or in the iterative process to -C compute a right coprime factorization with inner -C denominator; -C = 8: if DICO = 'C' and the matrix AW has a controllable -C eigenvalue on the imaginary axis, or DICO = 'D' and -C AW has a controllable eigenvalue on the unit circle; -C = 9: the computation of eigenvalues failed; -C = 10: the computation of Hankel singular values failed. -C -C METHOD -C -C Let G be the transfer-function matrix of the original -C linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09ID determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that the corresponding transfer-function matrix Gr minimizes -C the norm of the frequency-weighted error -C -C V*(G-Gr)*W, (3) -C -C where V and W are transfer-function matrices without poles on the -C imaginary axis in continuous-time case or on the unit circle in -C discrete-time case. -C -C The following procedure is used to reduce G: -C -C 1) Decompose additively G, of order N, as -C -C G = G1 + G2, -C -C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and -C G2 = (A2,B2,C2,0), of order NU, has only ALPHA-unstable poles. -C -C 2) Compute for G1 a B&T or SPA frequency-weighted approximation -C G1r of order NR-NU using the combination method or the -C modified combination method of [4]. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C For the frequency-weighted reduction of the ALPHA-stable part, -C several methods described in [4] can be employed in conjunction -C with the combination method and modified combination method -C proposed in [4]. -C -C If JOB = 'B', the square-root B&T method is used. -C If JOB = 'F', the balancing-free square-root version of the -C B&T method is used. -C If JOB = 'S', the square-root version of the SPA method is used. -C If JOB = 'P', the balancing-free square-root version of the -C SPA method is used. -C -C For each of these methods, left and right truncation matrices -C are determined using the Cholesky factors of an input -C frequency-weighted controllability Grammian P and an output -C frequency-weighted observability Grammian Q. -C P and Q are computed from the controllability Grammian Pi of G*W -C and the observability Grammian Qo of V*G. Using special -C realizations of G*W and V*G, Pi and Qo are computed in the -C partitioned forms -C -C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , -C ( P12' P22 ) ( Q12' Q22 ) -C -C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, -C respectively. Let P0 and Q0 be non-negative definite matrices -C defined below -C -1 -C P0 = P11 - ALPHAC**2*P12*P22 *P21 , -C -1 -C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. -C -C The frequency-weighted controllability and observability -C Grammians, P and Q, respectively, are defined as follows: -C P = P0 if JOBC = 'S' (standard combination method [4]); -C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability -C Grammian defined to enforce stability for a modified combination -C method of [4]; -C Q = Q0 if JOBO = 'S' (standard combination method [4]); -C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability -C Grammian defined to enforce stability for a modified combination -C method of [4]. -C -C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of -C Grammians corresponds to the method of Enns [1], while if -C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds -C to the method of Lin and Chiu [2,3]. -C -C If JOBC = 'S' and ALPHAC = 1, no pole-zero cancellations must -C occur in G*W. If JOBO = 'S' and ALPHAO = 1, no pole-zero -C cancellations must occur in V*G. The presence of pole-zero -C cancellations leads to meaningless results and must be avoided. -C -C The frequency-weighted Hankel singular values HSV(1), ...., -C HSV(N) are computed as the square roots of the eigenvalues -C of the product P*Q. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Lin, C.-A. and Chiu, T.-Y. -C Model reduction via frequency-weighted balanced realization. -C Control Theory and Advanced Technology, vol. 8, -C pp. 341-351, 1992. -C -C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. -C New results on frequency weighted balanced reduction -C technique. -C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. -C -C [4] Varga, A. and Anderson, B.D.O. -C Square-root balancing-free methods for the frequency-weighted -C balancing related model reduction. -C (report in preparation) -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root -C techniques. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Sep. 2001. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, MW, - $ N, NR, NS, NV, NW, P, PV - DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), - $ HSV(*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW, - $ SCALE, SPA - INTEGER IERR, IWARNL, KBR, KBV, KBW, KCR, KCV, KCW, KDR, - $ KDV, KI, KL, KT, KTI, KU, KW, LCF, LDW, LW, NMR, - $ NN, NNQ, NNR, NNV, NNW, NRA, NU, NU1, NVR, NWR, - $ PPV, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09IX, AB09IY, DLACPY, SB08CD, SB08DD, TB01ID, - $ TB01KD, TB01PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) - SCALE = LSAME( EQUIL, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - LW = 1 - NN = N*N - NNV = N + NV - NNW = N + NW - PPV = MAX( P, PV ) -C - IF( LEFTW .AND. PV.GT.0 ) THEN - LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) - ELSE - LW = MAX( LW, N*( P + 5 ) ) - END IF -C - IF( RIGHTW .AND. MW.GT.0 ) THEN - LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) - ELSE - LW = MAX( LW, N*( M + 5 ) ) - END IF - LW = 2*NN + MAX( LW, 2*NN + 5*N, N*MAX( M, P ) ) -C - IF( LEFTW .AND. NV.GT.0 ) THEN - LCF = PV*( NV + PV ) + PV*NV + - $ MAX( NV*( NV + 5 ), PV*( PV + 2 ), 4*PPV ) - IF( PV.EQ.P ) THEN - LW = MAX( LW, LCF, NV + MAX( NV, 3*P ) ) - ELSE - LW = MAX( LW, PPV*( 2*NV + PPV ) + - $ MAX( LCF, NV + MAX( NV, 3*PPV ) ) ) - END IF - END IF -C - IF( RIGHTW .AND. NW.GT.0 ) THEN - IF( MW.EQ.M ) THEN - LW = MAX( LW, NW + MAX( NW, 3*M ) ) - ELSE - LW = MAX( LW, 2*NW*MAX( M, MW ) + - $ NW + MAX( NW, 3*M, 3*MW ) ) - END IF - LW = MAX( LW, MW*( NW + MW ) + - $ MAX( NW*( NW + 5 ), MW*( MW + 2 ), 4*MW, 4*M ) ) - END IF -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( SCALE .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( NV.LT.0 ) THEN - INFO = -11 - ELSE IF( PV.LT.0 ) THEN - INFO = -12 - ELSE IF( NW.LT.0 ) THEN - INFO = -13 - ELSE IF( MW.LT.0 ) THEN - INFO = -14 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -15 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -16 - ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN - INFO = -17 - ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN - INFO = -18 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -24 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -26 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -28 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -30 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN - INFO = -32 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN - INFO = -34 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -36 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -38 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -40 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -42 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -46 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -49 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09ID', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - IWORK(2) = NV - IWORK(3) = NW - DWORK(1) = ONE - RETURN - END IF -C - IF( SCALE ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + NN - KI = KL + N - KW = KI + N -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation, A <- inv(T)*A*T, and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Determine NRA, the desired order for the reduction of stable part. -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 3 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - IWORK(1) = 0 - IWORK(2) = NV - IWORK(3) = NW - RETURN - END IF -C - NVR = NV - IF( LEFTW .AND. NV.GT.0 ) THEN -C -C Compute a left-coprime factorization with inner denominator -C of a minimal realization of V. The resulting AV is in -C real Schur form. -C Workspace needed: real LV+MAX( 1, LCF, -C NV + MAX( NV, 3*P, 3*PV ) ), -C where -C LV = 0 if P = PV and -C LV = MAX(P,PV)*(2*NV+MAX(P,PV)) -C otherwise; -C LCF = PV*(NV+PV) + -C MAX( 1, PV*NV + MAX( NV*(NV+5), -C PV*(PV+2),4*PV,4*P ) ); -C prefer larger; -C integer NV + MAX(P,PV). -C - IF( P.EQ.PV ) THEN - KW = 1 - CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, - $ BV, LDBV, CV, LDCV, NVR, ZERO, - $ IWORK, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - KBR = 1 - KDR = KBR + PV*NVR - KW = KDR + PV*PV - CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, - $ DV, LDDV, NNQ, NNR, DWORK(KBR), MAX( 1, NVR ), - $ DWORK(KDR), PV, ZERO, DWORK(KW), LDWORK-KW+1, - $ IWARN, IERR ) - ELSE - LDW = MAX( P, PV ) - KBV = 1 - KCV = KBV + NV*LDW - KW = KCV + NV*LDW - CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KBV), NV ) - CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KCV), LDW ) - CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, - $ DWORK(KBV), NV, DWORK(KCV), LDW, NVR, ZERO, - $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) - KDV = KW - KBR = KDV + LDW*LDW - KDR = KBR + PV*NVR - KW = KDR + PV*PV - CALL DLACPY( 'Full', PV, P, DV, LDDV, DWORK(KDV), LDW ) - CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, DWORK(KBV), NV, - $ DWORK(KCV), LDW, DWORK(KDV), LDW, NNQ, NNR, - $ DWORK(KBR), MAX( 1, NVR ), DWORK(KDR), PV, - $ ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - CALL DLACPY( 'Full', NVR, P, DWORK(KBV), NV, BV, LDBV ) - CALL DLACPY( 'Full', PV, NVR, DWORK(KCV), LDW, CV, LDCV ) - CALL DLACPY( 'Full', PV, P, DWORK(KDV), LDW, DV, LDDV ) - END IF - IF( IERR.NE.0 ) THEN - INFO = IERR + 2 - RETURN - END IF - NVR = NNQ - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IF( IWARN.GT.0 ) - $ IWARN = 10 + IWARN - END IF -C - NWR = NW - IF( RIGHTW .AND. NW.GT.0 ) THEN -C -C Compute a minimal realization of W. -C Workspace needed: real LW+MAX(1, NW + MAX(NW, 3*M, 3*MW)); -C where -C LW = 0, if M = MW and -C LW = 2*NW*MAX(M,MW), otherwise; -C prefer larger; -C integer NW + MAX(M,MW). -C - IF( M.EQ.MW ) THEN - KW = 1 - CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, - $ BW, LDBW, CW, LDCW, NWR, ZERO, IWORK, DWORK, - $ LDWORK, INFO ) - ELSE - LDW = MAX( M, MW ) - KBW = 1 - KCW = KBW + NW*LDW - KW = KCW + NW*LDW - CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KBW), NW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KCW), LDW ) - CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, - $ DWORK(KBW), NW, DWORK(KCW), LDW, NWR, ZERO, - $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) - CALL DLACPY( 'Full', NWR, MW, DWORK(KBW), NW, BW, LDBW ) - CALL DLACPY( 'Full', M, NWR, DWORK(KCW), LDW, CW, LDCW ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - IF( RIGHTW .AND. NWR.GT.0 ) THEN -C -C Compute a right-coprime factorization with inner denominator -C of the minimal realization of W. The resulting AW is in -C real Schur form. -C -C Workspace needed: MW*(NW+MW) + -C MAX( 1, NW*(NW+5), MW*(MW+2), 4*MW, 4*M ); -C prefer larger. -C - LDW = MAX( 1, MW ) - KCR = 1 - KDR = KCR + NWR*LDW - KW = KDR + MW*LDW - CALL SB08DD( DICO, NWR, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DW, LDDW, NNQ, NNR, DWORK(KCR), LDW, DWORK(KDR), - $ LDW, ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IF( IERR.NE.0 ) THEN - INFO = IERR + 5 - RETURN - END IF - NWR = NNQ - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IF( IWARN.GT.0 ) - $ IWARN = 10 + IWARN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NN - KW = KTI + NN -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R -C of the controllability and observability Grammians, respectively. -C Real workspace: need 2*N*N + MAX( 1, LLEFT, LRIGHT ), -C where -C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) -C if WEIGHT = 'L' or 'B' and PV > 0; -C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; -C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) -C if WEIGHT = 'R' or 'B' and MW > 0; -C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. -C prefer larger. -C - CALL AB09IY( DICO, JOBC, JOBO, WEIGHT, NS, M, P, NVR, PV, NWR, - $ MW, ALPHAC, ALPHAO, A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, AV, LDAV, BV, LDBV, CV, LDCV, - $ DV, LDDV, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ SCALEC, SCALEO, DWORK(KTI), N, DWORK(KT), N, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 9 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute a BTA or SPA of the stable part. -C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ). -C - CALL AB09IX( DICO, JOB, 'Schur', ORDSEL, NS, M, P, NRA, - $ SCALEC, SCALEO, A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KTI), N, DWORK(KT), N, - $ NMR, HSV, TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, - $ IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = 10 - RETURN - END IF - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IWORK(1) = NMR - IWORK(2) = NVR - IWORK(3) = NWR -C - RETURN -C *** Last line of AB09ID *** - END diff --git a/slycot/src/AB09IX.f b/slycot/src/AB09IX.f deleted file mode 100644 index f3ad3b39..00000000 --- a/slycot/src/AB09IX.f +++ /dev/null @@ -1,695 +0,0 @@ - SUBROUTINE AB09IX( DICO, JOB, FACT, ORDSEL, N, M, P, NR, - $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, - $ TI, LDTI, T, LDT, NMINR, HSV, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the square-root or -C balancing-free square-root Balance & Truncate (B&T) or -C Singular Perturbation Approximation (SPA) model reduction methods. -C The computation of truncation matrices TI and T is based on -C the Cholesky factor S of a controllability Grammian P = S*S' -C and the Cholesky factor R of an observability Grammian Q = R'*R, -C where S and R are given upper triangular matrices. -C -C For the B&T approach, the matrices of the reduced order system -C are computed using the truncation formulas: -C -C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) -C -C For the SPA approach, the matrices of a minimal realization -C (Am,Bm,Cm) are computed using the truncation formulas: -C -C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) -C -C Am, Bm, Cm and D serve further for computing the SPA of the given -C system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method; -C = 'S': use the square-root SPA method; -C = 'P': use the balancing-free square-root SPA method. -C -C FACT CHARACTER*1 -C Specifies whether or not, on entry, the matrix A is in a -C real Schur form, as follows: -C = 'S': A is in a real Schur form; -C = 'N': A is a general dense square matrix. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. NR is set as follows: -C if ORDSEL = 'F', NR is equal to MIN(NR,NMINR), where NR -C is the desired order on entry and NMINR is the number of -C the Hankel singular values greater than N*EPS*S1, where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and S1 is the largest Hankel singular value -C (computed in HSV(1)); -C NR can be further reduced to ensure HSV(NR) > HSV(NR+1); -C if ORDSEL = 'A', NR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*S1). -C -C SCALEC (input) DOUBLE PRECISION -C Scaling factor for the Cholesky factor S of the -C controllability Grammian, i.e., S/SCALEC is used to -C compute the Hankel singular values. SCALEC > 0. -C -C SCALEO (input) DOUBLE PRECISION -C Scaling factor for the Cholesky factor R of the -C observability Grammian, i.e., R/SCALEO is used to -C compute the Hankel singular values. SCALEO > 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. If FACT = 'S', -C A is in a real Schur form. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOB = 'S' or JOB = 'P', the leading P-by-M -C part of this array must contain the original input/output -C matrix D. -C On exit, if INFO = 0 and JOB = 'S' or JOB = 'P', the -C leading P-by-M part of this array contains the -C input/output matrix Dr of the reduced order system. -C If JOB = 'B' or JOB = 'F', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= 1, if JOB = 'B' or JOB = 'F'; -C LDD >= MAX(1,P), if JOB = 'S' or JOB = 'P'. -C -C TI (input/output) DOUBLE PRECISION array, dimension (LDTI,N) -C On entry, the leading N-by-N upper triangular part of -C this array must contain the Cholesky factor S of a -C controllability Grammian P = S*S'. -C On exit, if INFO = 0, and NR > 0, the leading NMINR-by-N -C part of this array contains the left truncation matrix -C TI in (1), for the B&T approach, or in (2), for the -C SPA approach. -C -C LDTI INTEGER -C The leading dimension of array TI. LDTI >= MAX(1,N). -C -C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) -C On entry, the leading N-by-N upper triangular part of -C this array must contain the Cholesky factor R of an -C observability Grammian Q = R'*R. -C On exit, if INFO = 0, and NR > 0, the leading N-by-NMINR -C part of this array contains the right truncation matrix -C T in (1), for the B&T approach, or in (2), for the -C SPA approach. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C NMINR (output) INTEGER -C The number of Hankel singular values greater than -C MAX(TOL2,N*EPS*S1). -C Note: If S and R are the Cholesky factors of the -C controllability and observability Grammians of the -C original system (A,B,C,D), respectively, then NMINR is -C the order of a minimal realization of the original system. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the Hankel singular values, -C ordered decreasingly. The Hankel singular values are -C singular values of the product R*S. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of the reduced system. -C For model reduction, the recommended value lies in the -C interval [0.00001,0.001]. -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = N*EPS*S1, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH) and S1 is the largest -C Hankel singular value (computed in HSV(1)). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the system. -C The recommended value is TOL2 = N*EPS*S1. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension LIWORK, where -C LIWORK = 0, if JOB = 'B'; -C LIWORK = N, if JOB = 'F'; -C LIWORK = 2*N, if JOB = 'S' or 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 2*N*N + 5*N, N*MAX(M,P) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NMINR, the order of a minimal realization of -C the given system; in this case, the resulting NR is -C set automatically to NMINR; -C = 2: with ORDSEL = 'F', the selected order NR corresponds -C to repeated singular values, which are neither all -C included nor all excluded from the reduced model; -C in this case, the resulting NR is set automatically -C to the largest value such that HSV(NR) > HSV(NR+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (3) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09IX determines for -C the given system (3), the matrices of a reduced NR order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (4) -C -C by using the square-root or balancing-free square-root -C Balance & Truncate (B&T) or Singular Perturbation Approximation -C (SPA) model reduction methods. -C -C The projection matrices TI and T are determined using the -C Cholesky factors S and R of a controllability Grammian P and an -C observability Grammian Q. -C The Hankel singular values HSV(1), ...., HSV(N) are computed as -C singular values of the product R*S. -C -C If JOB = 'B', the square-root Balance & Truncate technique -C of [1] is used. -C -C If JOB = 'F', the balancing-free square-root version of the -C Balance & Truncate technique [2] is used. -C -C If JOB = 'S', the square-root version of the Singular Perturbation -C Approximation method [3,4] is used. -C -C If JOB = 'P', the balancing-free square-root version of the -C Singular Perturbation Approximation method [3,4] is used. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudni, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C [3] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of balanced systems. -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [4] Varga A. -C Balancing-free square-root algorithm for computing singular -C perturbation approximations. -C Proc. 30-th CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on accuracy enhancing square-root -C or balancing-free square-root methods. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Sep. 2001. -C -C KEYWORDS -C -C Balance and truncate, minimal state-space representation, -C model reduction, multivariable system, -C singular perturbation approximation, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, - $ LDWORK, M, N, NMINR, NR, P - DOUBLE PRECISION SCALEC, SCALEO, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, RSF, SPA - INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, - $ NRED, NR1, NS, WRKOPT - DOUBLE PRECISION ATOL, RCOND, SKP, TEMP, TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, - $ DLACPY, DORGQR, DSCAL, DTRMM, DTRMV, MA02AD, - $ MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) - SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) - BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) - RSF = LSAME( FACT, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C - LW = MAX( 1, 2*N*N + 5*N, N*MAX( M, P ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( RSF .OR. LSAME( FACT, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( SCALEC.LE.ZERO ) THEN - INFO = -9 - ELSE IF( SCALEO.LE.ZERO ) THEN - INFO = -10 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( SPA .AND. LDD.LT.P ) ) THEN - INFO = -18 - ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -26 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -29 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09IX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NMINR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Save S in DWORK(KV). -C - KV = 1 - KU = KV + N*N - KW = KU + N*N - CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) -C | x x | -C Compute R*S in the form | 0 x | in TI. -C - DO 10 J = 1, N - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, - $ TI(1,J), 1 ) - 10 CONTINUE -C -C Compute the singular value decomposition R*S = V*Sigma*UT of the -C upper triangular matrix R*S, with UT in TI and V in DWORK(KU). -C -C Workspace: need 2*N*N + 5*N; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Scale the singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) -C -C Partition Sigma, U and V conformally as: -C -C Sigma = diag(Sigma1,Sigma2,Sigma3), U = [U1,U2,U3] (U' in TI) and -C V = [V1,V2,V3] (in DWORK(KU)). -C -C Compute NMINR, the order of a minimal realization, as the order -C of [Sigma1 Sigma2]. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ATOL = MAX( TOL2, TOLDEF*HSV(1) ) - NMINR = N - 20 IF( NMINR.GT.0 ) THEN - IF( HSV(NMINR).LE.ATOL ) THEN - NMINR = NMINR - 1 - GO TO 20 - END IF - END IF -C -C Compute the order NR of reduced system, as the order of Sigma1. -C - IF( FIXORD ) THEN -C -C Check if the desired order is less than the order of a minimal -C realization. -C - IF( NR.GT.NMINR ) THEN -C -C Reduce the order to NMINR. -C - NR = NMINR - IWARN = 1 - END IF -C -C Check for singular value multiplicity at cut-off point. -C - IF( NR.GT.0 .AND. NR.LT.NMINR ) THEN - SKP = HSV(NR) - IF( SKP-HSV(NR+1).LE.TOLDEF*SKP ) THEN - IWARN = 2 -C -C Reduce the order such that HSV(NR) > HSV(NR+1). -C - 30 NR = NR - 1 - IF( NR.GT.0 ) THEN - IF( HSV(NR)-SKP.LE.TOLDEF*SKP ) GO TO 30 - END IF - END IF - END IF - ELSE -C -C The order is given as the number of singular values -C exceeding MAX( TOL1, N*EPS*HSV(1) ). -C - ATOL = MAX( TOL1, ATOL ) - NR = 0 - DO 40 J = 1, NMINR - IF( HSV(J).LE.ATOL ) GO TO 50 - NR = NR + 1 - 40 CONTINUE - 50 CONTINUE - ENDIF -C -C Finish if the order is zero. -C - IF( NR.EQ.0 ) THEN - IF( SPA ) - $ CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, - $ D, LDD, RCOND, IWORK, DWORK, IERR ) - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute NS, the order of Sigma2. For BTA, NS = 0. -C - IF( SPA ) THEN - NRED = NMINR - ELSE - NRED = NR - END IF - NS = NRED - NR -C -C Compute the truncation matrices. -C -C Compute TI' = | TI1' TI2' | = R'*| V1 V2 | in DWORK(KU). -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NRED, - $ ONE, T, LDT, DWORK(KU), N ) -C -C Compute T = | T1 T2 | = S*| U1 U2 | . -C - CALL MA02AD( 'Full', NRED, N, TI, LDTI, T, LDT ) - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NRED, ONE, DWORK(KV), N, T, LDT ) -C - KTAU = KW - IF( BAL ) THEN - IJ = KU -C -C Square-Root B&T/SPA method. -C -C Compute the truncation matrices for balancing -C -1/2 -1/2 -C T1*Sigma1 and TI1'*Sigma1 . -C - DO 60 J = 1, NR - TEMP = ONE/SQRT( HSV(J) ) - CALL DSCAL( N, TEMP, T(1,J), 1 ) - CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) - IJ = IJ + N - 60 CONTINUE -C - ELSE -C -C Balancing-Free B&T/SPA method. -C -C Compute orthogonal bases for the images of matrices T1 and -C TI1'. -C -C Workspace: need 2*N*N + 2*N; -C prefer larger. -C - KW = KTAU + NR - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) - CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C - IF( NS.GT.0 ) THEN -C -C Compute orthogonal bases for the images of matrices T2 and -C TI2'. -C -C Workspace: need 2*N*N + 2*N; -C prefer larger. -C - NR1 = NR + 1 - KW = KTAU + NS - LDW = LDWORK - KW + 1 - CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, - $ IERR ) - CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), - $ LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), - $ DWORK(KW), LDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - ENDIF -C -C Transpose TI' in TI. -C - CALL MA02AD( 'Full', N, NRED, DWORK(KU), N, TI, LDTI ) -C - IF( .NOT.BAL ) THEN -C -1 -C Compute (TI1*T1) *TI1 in TI. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, - $ LDTI, T, LDT, ZERO, DWORK(KU), N ) - CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, - $ LDTI, IERR ) -C - IF( NS.GT.0 ) THEN -C -1 -C Compute (TI2*T2) *TI2 in TI2. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, - $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), - $ N ) - CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) - CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, - $ TI(NR1,1), LDTI, IERR ) - END IF - END IF -C -C Compute TI*A*T. Exploit RSF of A if possible. -C Workspace: need N*N. -C - IF( RSF ) THEN - IJ = 1 - DO 80 J = 1, N - K = MIN( J+1, N ) - CALL DGEMV( 'NoTranspose', NRED, K, ONE, TI, LDTI, - $ A(1,J), 1, ZERO, DWORK(IJ), 1 ) - IJ = IJ + N - 80 CONTINUE - ELSE - CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, N, N, ONE, - $ TI, LDTI, A, LDA, ZERO, DWORK, N ) - END IF - CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, NRED, N, ONE, - $ DWORK, N, T, LDT, ZERO, A, LDA ) -C -C Compute TI*B and C*T. -C Workspace: need N*MAX(M,P). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, M, N, ONE, TI, - $ LDTI, DWORK, N, ZERO, B, LDB ) -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NRED, N, ONE, - $ DWORK, P, T, LDT, ZERO, C, LDC ) -C -C Compute the singular perturbation approximation if possible. -C Note that IERR = 1 on exit from AB09DD cannot appear here. -C -C Workspace: need real 4*(NMINR-NR); -C need integer 2*(NMINR-NR). -C - IF( SPA) THEN - CALL AB09DD( DICO, NRED, M, P, NR, A, LDA, B, LDB, - $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) - ELSE - NMINR = NR - END IF - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09IX *** - END diff --git a/slycot/src/AB09IY.f b/slycot/src/AB09IY.f deleted file mode 100644 index 47550521..00000000 --- a/slycot/src/AB09IY.f +++ /dev/null @@ -1,859 +0,0 @@ - SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV, - $ NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ SCALEC, SCALEO, S, LDS, R, LDR, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for given state-space representations -C (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the -C transfer-function matrices G, V and W, respectively, -C the Cholesky factors of the frequency-weighted -C controllability and observability Grammians corresponding -C to a frequency-weighted model reduction problem. -C G, V and W must be stable transfer-function matrices with -C the state matrices A, AV, and AW in real Schur form. -C It is assumed that the state space realizations (AV,BV,CV,DV) -C and (AW,BW,CW,DW) are minimal. In case of possible pole-zero -C cancellations in forming V*G and/or G*W, the parameters for the -C choice of frequency-weighted Grammians ALPHAO and/or ALPHAC, -C respectively, must be different from 1. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G, V and W are continuous-time systems; -C = 'D': G, V and W are discrete-time systems. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to a combination method [4] -C of the approaches of Enns [1] and Lin-Chiu [2,3]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [4]. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation of G, i.e., -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix B and -C the number of rows of the matrices CW and DW. M >= 0. -C M represents the dimension of the input vector of the -C system with the transfer-function matrix G and -C also the dimension of the output vector of the system -C with the transfer-function matrix W. -C -C P (input) INTEGER -C The number of rows of the matrix C and the -C number of columns of the matrices BV and DV. P >= 0. -C P represents the dimension of the output vector of the -C system with the transfer-function matrix G and -C also the dimension of the input vector of the system -C with the transfer-function matrix V. -C -C NV (input) INTEGER -C The order of the matrix AV. Also the number of rows of -C the matrix BV and the number of columns of the matrix CV. -C NV represents the dimension of the state vector of the -C system with the transfer-function matrix V. NV >= 0. -C -C PV (input) INTEGER -C The number of rows of the matrices CV and DV. PV >= 0. -C PV represents the dimension of the output vector of the -C system with the transfer-function matrix V. -C -C NW (input) INTEGER -C The order of the matrix AW. Also the number of rows of -C the matrix BW and the number of columns of the matrix CW. -C NW represents the dimension of the state vector of the -C system with the transfer-function matrix W. NW >= 0. -C -C MW (input) INTEGER -C The number of columns of the matrices BW and DW. MW >= 0. -C MW represents the dimension of the input vector of the -C system with the transfer-function matrix W. -C -C ALPHAC (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted controllability Grammian (see METHOD); -C ABS(ALPHAC) <= 1. -C -C ALPHAO (input) DOUBLE PRECISION -C Combination method parameter for defining the -C frequency-weighted observability Grammian (see METHOD); -C ABS(ALPHAO) <= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must -C contain the state matrix A (of the system with the -C transfer-function matrix G) in a real Schur form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C AV (input) DOUBLE PRECISION array, dimension (LDAV,NV) -C If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this -C array must contain the state matrix AV (of the system with -C the transfer-function matrix V) in a real Schur form. -C AV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDAV INTEGER -C The leading dimension of array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input) DOUBLE PRECISION array, dimension (LDBV,P) -C If WEIGHT = 'L' or 'B', the leading NV-by-P part of this -C array must contain the input matrix BV of the system with -C the transfer-function matrix V. -C BV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDBV INTEGER -C The leading dimension of array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input) DOUBLE PRECISION array, dimension (LDCV,NV) -C If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this -C array must contain the output matrix CV of the system with -C the transfer-function matrix V. -C CV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDCV INTEGER -C The leading dimension of array CV. -C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this -C array must contain the feedthrough matrix DV of the system -C with the transfer-function matrix V. -C DV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDDV INTEGER -C The leading dimension of array DV. -C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input) DOUBLE PRECISION array, dimension (LDAW,NW) -C If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this -C array must contain the state matrix AW (of the system with -C the transfer-function matrix W) in a real Schur form. -C AW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDAW INTEGER -C The leading dimension of array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input) DOUBLE PRECISION array, dimension (LDBW,MW) -C If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this -C array must contain the input matrix BW of the system with -C the transfer-function matrix W. -C BW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDBW INTEGER -C The leading dimension of array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input) DOUBLE PRECISION array, dimension (LDCW,NW) -C If WEIGHT = 'R' or 'B', the leading M-by-NW part of this -C array must contain the output matrix CW of the system with -C the transfer-function matrix W. -C CW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDCW INTEGER -C The leading dimension of array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) -C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this -C array must contain the feedthrough matrix DW of the system -C with the transfer-function matrix W. -C DW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDDW INTEGER -C The leading dimension of array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian in (1) -C or (3). See METHOD. -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian in (2) -C or (4). See METHOD. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor S of the frequency-weighted -C cotrollability Grammian P = S*S'. See METHOD. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor R of the frequency-weighted -C observability Grammian Q = R'*R. See METHOD. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, LLEFT, LRIGHT ), -C where -C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) -C if WEIGHT = 'L' or 'B' and PV > 0; -C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; -C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) -C if WEIGHT = 'R' or 'B' and MW > 0; -C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the state matrices A and/or AV are not stable or -C not in a real Schur form; -C = 2: if the state matrices A and/or AW are not stable or -C not in a real Schur form; -C = 3: eigenvalues computation failure. -C -C METHOD -C -C Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored -C controllability and observability Grammians satisfying -C in the continuous-time case -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, (1) -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, (2) -C -C and in the discrete-time case -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, (3) -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, (4) -C -C where -C -C Ai = ( A B*Cw ) , Bi = ( B*Dw ) , -C ( 0 Aw ) ( Bw ) -C -C Ao = ( A 0 ) , Co = ( Dv*C Cv ) . -C ( Bv*C Av ) -C -C Consider the partitioned Grammians -C -C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , -C ( P12' P22 ) ( Q12' Q22 ) -C -C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, -C respectively, and let P0 and Q0 be non-negative definite matrices -C defined in the combination method [4] -C -1 -C P0 = P11 - ALPHAC**2*P12*P22 *P21 , -C -1 -C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. -C -C The frequency-weighted controllability and observability -C Grammians, P and Q, respectively, are defined as follows: -C P = P0 if JOBC = 'S' (standard combination method [4]); -C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability -C Grammian defined to enforce stability for a modified combination -C method of [4]; -C Q = Q0 if JOBO = 'S' (standard combination method [4]); -C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability -C Grammian defined to enforce stability for a modified combination -C method of [4]. -C -C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of -C Grammians corresponds to the method of Enns [1], while if -C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the -C method of Lin and Chiu [2,3]. -C -C The routine computes directly the Cholesky factors S and R -C such that P = S*S' and Q = R'*R according to formulas -C developed in [4]. No matrix inversions are involved. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Lin, C.-A. and Chiu, T.-Y. -C Model reduction via frequency-weighted balanced realization. -C Control Theory and Advanced Technology, vol. 8, -C pp. 341-351, 1992. -C -C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. -C New results on frequency weighted balanced reduction -C technique. -C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. -C -C [4] Varga, A. and Anderson, B.D.O. -C Square-root balancing-free methods for the frequency-weighted -C balancing related model reduction. -C (report in preparation) -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2001. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBC, JOBO, WEIGHT - INTEGER INFO, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDDV, LDDW, LDR, LDS, LDWORK, - $ M, MW, N, NV, NW, P, PV - DOUBLE PRECISION ALPHAC, ALPHAO, SCALEC, SCALEO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ DV(LDDV,*), DW(LDDW,*), - $ DWORK(*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL DISCR, FRWGHT, LEFTW, RIGHTW - INTEGER I, IERR, J, KAW, KTAU, KU, KW, LDU, LW, MBBAR, - $ NNV, NNW, PCBAR - DOUBLE PRECISION T, TOL, WORK -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSCAL, DSYEV, - $ MB01WD, MB04ND, MB04OD, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - INFO = 0 - LW = 1 - NNV = N + NV - NNW = N + NW - IF( LEFTW .AND. PV.GT.0 ) THEN - LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) - ELSE - LW = MAX( LW, N*( P + 5 ) ) - END IF - IF( RIGHTW .AND. MW.GT.0 ) THEN - LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) - ELSE - LW = MAX( LW, N*( M + 5 ) ) - END IF -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NV.LT.0 ) THEN - INFO = -8 - ELSE IF( PV.LT.0 ) THEN - INFO = -9 - ELSE IF( NW.LT.0 ) THEN - INFO = -10 - ELSE IF( MW.LT.0 ) THEN - INFO = -11 - ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN - INFO = -12 - ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN - INFO = -13 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -21 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -23 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN - INFO = -25 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN - INFO = -27 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -29 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -31 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -33 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -35 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -39 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -41 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -43 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09IY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALEC = ONE - SCALEO = ONE - IF( MIN( N, M, P ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WORK = 1 - IF( LEFTW .AND. PV.GT.0 ) THEN -C -C Build the extended permuted matrices -C -C Ao = ( Av Bv*C ) , Co = ( Cv Dv*C ) . -C ( 0 A ) -C - KAW = 1 - KU = KAW + NNV*NNV - LDU = MAX( NNV, PV ) - CALL DLACPY( 'Full', NV, NV, AV, LDAV, DWORK(KAW), NNV ) - CALL DLASET( 'Full', N, NV, ZERO, ZERO, DWORK(KAW+NV), NNV ) - CALL DGEMM( 'No-transpose', 'No-transpose', NV, N, P, ONE, - $ BV, LDBV, C, LDC, ZERO, DWORK(KAW+NNV*NV), NNV ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW+NNV*NV+NV), NNV ) -C - CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KU), LDU ) - CALL DGEMM( 'No-transpose', 'No-transpose', PV, N, P, ONE, - $ DV, LDDV, C, LDC, ZERO, DWORK(KU+LDU*NV), LDU ) -C -C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. -C -C Workspace: need (N+NV)*(N+NV+MAX(N+NV,PV)+5); -C prefer larger. -C - KTAU = KU + LDU*NNV - KW = KTAU + NNV -C - CALL SB03OU( DISCR, .FALSE., NNV, PV, DWORK(KAW), NNV, - $ DWORK(KU), LDU, DWORK(KTAU), DWORK(KU), LDU, - $ SCALEO, DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Partition Ro as Ro = ( R11 R12 ) and compute R such that -C ( 0 R22 ) -C -C R'*R = R22'*R22 + (1-ALPHAO**2)*R12'*R12. -C - KW = KU + LDU*NV + NV - CALL DLACPY( 'Upper', N, N, DWORK(KW), LDU, R, LDR ) - IF( ALPHAO.NE.ZERO ) THEN - T = SQRT( ONE - ALPHAO*ALPHAO ) - DO 10 J = KU + LDU*NV, KU + LDU*(NNV-1), LDU - CALL DSCAL( NV, T, DWORK(J), 1 ) - 10 CONTINUE - END IF - IF( ALPHAO.LT.ONE .AND. NV.GT.0 ) THEN - KTAU = 1 - CALL MB04OD( 'Full', N, 0, NV, R, LDR, DWORK(KU+LDU*NV), - $ LDU, DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) -C - DO 30 J = 1, N - DWORK(J) = R(J,J) - DO 20 I = 1, J - IF ( DWORK(I).LT.ZERO ) R(I,J) = -R(I,J) - 20 CONTINUE - 30 CONTINUE -C - END IF -C - IF( LSAME( JOBO, 'E' ) .AND. ALPHAO.LT.ONE ) THEN -C -C Form Y = -A'*(R'*R)-(R'*R)*A if DICO = 'C', or -C Y = -A'*(R'*R)*A+(R'*R) if DICO = 'D'. -C - CALL DLACPY( 'Upper', N, N, R, LDR, DWORK(KU), N ) - CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', N, - $ -ONE, ZERO, R, LDR, DWORK(KAW+NNV*NV+NV), NNV, - $ DWORK(KU), N, IERR ) -C -C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. -C - KU = N + 1 - CALL DSYEV( 'Vectors', 'Upper', N, R, LDR, DWORK, DWORK(KU), - $ LDWORK-N, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 <= 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form C = [ sqrt(Sigma2)*Z2' ] -C - PCBAR = 0 - DO 40 J = 1, N - IF( DWORK(J).GT.TOL ) THEN - CALL DSCAL( N, SQRT( DWORK(J) ), R(1,J), 1 ) - CALL DCOPY( N, R(1,J), 1, DWORK(KU+PCBAR), N ) - PCBAR = PCBAR + 1 - END IF - 40 CONTINUE -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C A'*Q + Q*A + t^2*C'*C = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C A'*Q*A - Q + t^2*C'*C = 0. -C -C Workspace: need N*(N + 6); -C prefer larger. -C - KTAU = KU + N*N - KW = KTAU + N -C - CALL SB03OU( DISCR, .FALSE., N, PCBAR, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), R, LDR, T, DWORK(KW), LDWORK-KW+1, - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - SCALEO = SCALEO*T - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C - ELSE -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C A'*Q + Q*A + scaleo^2*C'*C = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C A'*Q*A - Q + scaleo^2*C'*C = 0. -C -C Workspace: need N*(P + 5); -C prefer larger. -C - KU = 1 - KTAU = KU + P*N - KW = KTAU + N -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, - $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C - IF( RIGHTW .AND. MW.GT.0 ) THEN -C -C Build the extended matrices -C -C Ai = ( A B*Cw ) , Bi = ( B*Dw ) . -C ( 0 Aw ) ( Bw ) -C - KAW = 1 - KU = KAW + NNW*NNW - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), NNW ) - CALL DLASET( 'Full', NW, N, ZERO, ZERO, DWORK(KAW+N), NNW ) - CALL DGEMM( 'No-transpose', 'No-transpose', N, NW, M, ONE, - $ B, LDB, CW, LDCW, ZERO, DWORK(KAW+NNW*N), NNW ) - CALL DLACPY( 'Full', NW, NW, AW, LDAW, - $ DWORK(KAW+NNW*N+N), NNW ) -C - CALL DGEMM( 'No-transpose', 'No-transpose', N, MW, M, ONE, - $ B, LDB, DW, LDDW, ZERO, DWORK(KU), NNW ) - CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KU+N), NNW ) -C -C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. -C -C Workspace: need (N+NW)*(N+NW+MAX(N+NW,MW)+5); -C prefer larger. -C - KTAU = KU + NNW*MAX( NNW, MW ) - KW = KTAU + NNW -C - CALL SB03OU( DISCR, .TRUE., NNW, MW, DWORK(KAW), NNW, - $ DWORK(KU), NNW, DWORK(KTAU), DWORK(KU), NNW, - $ SCALEC, DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Partition Si as Si = ( S11 S12 ) and compute S such that -C ( 0 S22 ) -C -C S*S' = S11*S11' + (1-ALPHAC**2)*S12*S12'. -C - CALL DLACPY( 'Upper', N, N, DWORK(KU), NNW, S, LDS ) - IF( ALPHAC.NE.ZERO ) THEN - T = SQRT( ONE - ALPHAC*ALPHAC ) - DO 50 J = KU + NNW*N, KU + NNW*(NNW-1), NNW - CALL DSCAL( N, T, DWORK(J), 1 ) - 50 CONTINUE - END IF - IF( ALPHAC.LT.ONE .AND. NW.GT.0 ) THEN - KTAU = N*NNW + 1 - KW = KTAU + N - CALL MB04ND( 'Full', N, 0, NW, S, LDS, DWORK(KU+NNW*N), NNW, - $ DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) -C - DO 70 J = 1, N - IF ( S(J,J).LT.ZERO ) THEN - DO 60 I = 1, J - S(I,J) = -S(I,J) - 60 CONTINUE - END IF - 70 CONTINUE - END IF -C - IF( LSAME( JOBC, 'E' ) .AND. ALPHAC.LT.ONE ) THEN -C -C Form X = -A*(S*S')-(S*S')*A' if DICO = 'C', or -C X = -A*(S*S')*A'+(S*S') if DICO = 'D'. -C - CALL DLACPY( 'Upper', N, N, S, LDS, DWORK(KU), N ) - CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', N, - $ -ONE, ZERO, S, LDS, DWORK(KAW), NNW, DWORK(KU), - $ N, IERR ) -C -C Compute the eigendecomposition of X as X = Z*Sigma*Z'. -C - KU = N + 1 - CALL DSYEV( 'Vectors', 'Upper', N, S, LDS, DWORK, DWORK(KU), - $ LDWORK-N, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 =< 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form B = [ Z2*sqrt(Sigma2) ] -C - MBBAR = 0 - I = KU - DO 80 J = 1, N - IF( DWORK(J).GT.TOL ) THEN - MBBAR = MBBAR + 1 - CALL DSCAL( N, SQRT( DWORK(J) ), S(1,J), 1 ) - CALL DCOPY( N, S(1,J), 1, DWORK(I), 1 ) - I = I + N - END IF - 80 CONTINUE -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C A*P + P*A' + t^2*B*B' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C A*P*A' - P + t^2*B*B' = 0. -C -C Workspace: need maximum N*(N + 6); -C prefer larger. -C - KTAU = KU + MBBAR*N - KW = KTAU + N -C - CALL SB03OU( DISCR, .TRUE., N, MBBAR, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), S, LDS, T, DWORK(KW), LDWORK-KW+1, - $ IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - SCALEC = SCALEC*T - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C - ELSE -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C A*P + P*A' + scalec^2*B*B' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C A*P*A' - P + scalec^2*B*B' = 0. -C -C Workspace: need N*(M+5); -C prefer larger. -C - KU = 1 - KTAU = KU + N*M - KW = KTAU + N -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, - $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) - END IF -C -C Save optimal workspace. -C - DWORK(1) = WORK -C - RETURN -C *** Last line of AB09IY *** - END diff --git a/slycot/src/AB09JD.f b/slycot/src/AB09JD.f deleted file mode 100644 index 8729aa4e..00000000 --- a/slycot/src/AB09JD.f +++ /dev/null @@ -1,1482 +0,0 @@ - SUBROUTINE AB09JD( JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL, - $ N, NV, NW, M, P, NR, ALPHA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AV, LDAV, BV, LDBV, - $ CV, LDCV, DV, LDDV, AW, LDAW, BW, LDBW, - $ CW, LDCW, DW, LDDW, NS, HSV, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the frequency -C weighted optimal Hankel-norm approximation method. -C The Hankel norm of the weighted error -C -C op(V)*(G-Gr)*op(W) -C -C is minimized, where G and Gr are the transfer-function matrices -C of the original and reduced systems, respectively, V and W are -C invertible transfer-function matrices representing the left and -C right frequency weights, and op(X) denotes X, inv(X), conj(X) or -C conj(inv(X)). V and W are specified by their state space -C realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively. -C When minimizing ||V*(G-Gr)*W||, V and W must be antistable. -C When minimizing inv(V)*(G-Gr)*inv(W), V and W must have only -C antistable zeros. -C When minimizing conj(V)*(G-Gr)*conj(W), V and W must be stable. -C When minimizing conj(inv(V))*(G-Gr)*conj(inv(W)), V and W must -C be minimum-phase. -C If the original system is unstable, then the frequency weighted -C Hankel-norm approximation is computed only for the -C ALPHA-stable part of the system. -C -C For a transfer-function matrix G, conj(G) denotes the conjugate -C of G given by G'(-s) for a continuous-time system or G'(1/z) -C for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBV CHARACTER*1 -C Specifies the left frequency-weighting as follows: -C = 'N': V = I; -C = 'V': op(V) = V; -C = 'I': op(V) = inv(V); -C = 'C': op(V) = conj(V); -C = 'R': op(V) = conj(inv(V)). -C -C JOBW CHARACTER*1 -C Specifies the right frequency-weighting as follows: -C = 'N': W = I; -C = 'W': op(W) = W; -C = 'I': op(W) = inv(W); -C = 'C': op(W) = conj(W); -C = 'R': op(W) = conj(inv(W)). -C -C JOBINV CHARACTER*1 -C Specifies the computational approach to be used as -C follows: -C = 'N': use the inverse free descriptor system approach; -C = 'I': use the inversion based standard approach; -C = 'A': switch automatically to the inverse free -C descriptor approach in case of badly conditioned -C feedthrough matrices in V or W (see METHOD). -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C NV (input) INTEGER -C The order of the realization of the left frequency -C weighting V, i.e., the order of the matrix AV. NV >= 0. -C -C NW (input) INTEGER -C The order of the realization of the right frequency -C weighting W, i.e., the order of the matrix AW. NW >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the -C multiplicity of the Hankel singular value HSV(NR-NU+1), -C NR is the desired order on entry, and NMIN is the order -C of a minimal realization of the ALPHA-stable part of the -C given system; NMIN is determined as the number of Hankel -C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the -C ALPHA-stable part of the weighted system (computed in -C HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if JOBV <> 'N', the leading NV-by-NV part of -C this array must contain the state matrix AV of a state -C space realization of the left frequency weighting V. -C On exit, if JOBV <> 'N', and INFO = 0, the leading -C NV-by-NV part of this array contains the real Schur form -C of AV. -C AV is not referenced if JOBV = 'N'. -C -C LDAV INTEGER -C The leading dimension of the array AV. -C LDAV >= MAX(1,NV), if JOBV <> 'N'; -C LDAV >= 1, if JOBV = 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if JOBV <> 'N', the leading NV-by-P part of -C this array must contain the input matrix BV of a state -C space realization of the left frequency weighting V. -C On exit, if JOBV <> 'N', and INFO = 0, the leading -C NV-by-P part of this array contains the transformed -C input matrix BV corresponding to the transformed AV. -C BV is not referenced if JOBV = 'N'. -C -C LDBV INTEGER -C The leading dimension of the array BV. -C LDBV >= MAX(1,NV), if JOBV <> 'N'; -C LDBV >= 1, if JOBV = 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if JOBV <> 'N', the leading P-by-NV part of -C this array must contain the output matrix CV of a state -C space realization of the left frequency weighting V. -C On exit, if JOBV <> 'N', and INFO = 0, the leading -C P-by-NV part of this array contains the transformed output -C matrix CV corresponding to the transformed AV. -C CV is not referenced if JOBV = 'N'. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,P), if JOBV <> 'N'; -C LDCV >= 1, if JOBV = 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If JOBV <> 'N', the leading P-by-P part of this array -C must contain the feedthrough matrix DV of a state space -C realization of the left frequency weighting V. -C DV is not referenced if JOBV = 'N'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,P), if JOBV <> 'N'; -C LDDV >= 1, if JOBV = 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if JOBW <> 'N', the leading NW-by-NW part of -C this array must contain the state matrix AW of a state -C space realization of the right frequency weighting W. -C On exit, if JOBW <> 'N', and INFO = 0, the leading -C NW-by-NW part of this array contains the real Schur form -C of AW. -C AW is not referenced if JOBW = 'N'. -C -C LDAW INTEGER -C The leading dimension of the array AW. -C LDAW >= MAX(1,NW), if JOBW <> 'N'; -C LDAW >= 1, if JOBW = 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) -C On entry, if JOBW <> 'N', the leading NW-by-M part of -C this array must contain the input matrix BW of a state -C space realization of the right frequency weighting W. -C On exit, if JOBW <> 'N', and INFO = 0, the leading -C NW-by-M part of this array contains the transformed -C input matrix BW corresponding to the transformed AW. -C BW is not referenced if JOBW = 'N'. -C -C LDBW INTEGER -C The leading dimension of the array BW. -C LDBW >= MAX(1,NW), if JOBW <> 'N'; -C LDBW >= 1, if JOBW = 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if JOBW <> 'N', the leading M-by-NW part of -C this array must contain the output matrix CW of a state -C space realization of the right frequency weighting W. -C On exit, if JOBW <> 'N', and INFO = 0, the leading -C M-by-NW part of this array contains the transformed output -C matrix CW corresponding to the transformed AW. -C CW is not referenced if JOBW = 'N'. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,M), if JOBW <> 'N'; -C LDCW >= 1, if JOBW = 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) -C If JOBW <> 'N', the leading M-by-M part of this array -C must contain the feedthrough matrix DW of a state space -C realization of the right frequency weighting W. -C DW is not referenced if JOBW = 'N'. -C -C LDDW INTEGER -C The leading dimension of the array DW. -C LDDW >= MAX(1,M), if JOBW <> 'N'; -C LDDW >= 1, if JOBW = 'N'. -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of this array contain -C the Hankel singular values, ordered decreasingly, of the -C projection G1s of op(V)*G1*op(W) (see METHOD), where G1 -C is the ALPHA-stable part of the original system. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(G1s), where c is a constant in the -C interval [0.00001,0.001], and HNORM(G1s) is the -C Hankel-norm of the projection G1s of op(V)*G1*op(W) -C (see METHOD), computed in HSV(1). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(G1s), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C TOL1 < 1. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(G1s). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C TOL2 < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M,c,d), if DICO = 'C', -C LIWORK = MAX(1,N,M,c,d), if DICO = 'D', where -C c = 0, if JOBV = 'N', -C c = MAX(2*P,NV+P+N+6,2*NV+P+2), if JOBV <> 'N', -C d = 0, if JOBW = 'N', -C d = MAX(2*M,NW+M+N+6,2*NW+M+2), if JOBW <> 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where -C for NVP = NV+P and NWM = NW+M we have -C LDW1 = 0 if JOBV = 'N' and -C LDW1 = 2*NVP*(NVP+P) + P*P + -C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), -C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) -C if JOBV <> 'N', -C LDW2 = 0 if JOBW = 'N' and -C LDW2 = 2*NWM*(NWM+M) + M*M + -C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), -C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) -C if JOBW <> 'N', -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 3: the reduction of AV to a real Schur form failed; -C = 4: the reduction of AW to a real Schur form failed; -C = 5: the reduction to generalized Schur form of the -C descriptor pair corresponding to the inverse of V -C failed; -C = 6: the reduction to generalized Schur form of the -C descriptor pair corresponding to the inverse of W -C failed; -C = 7: the computation of Hankel singular values failed; -C = 8: the computation of stable projection in the -C Hankel-norm approximation algorithm failed; -C = 9: the order of computed stable projection in the -C Hankel-norm approximation algorithm differs -C from the order of Hankel-norm approximation; -C = 10: the reduction of AV-BV*inv(DV)*CV to a -C real Schur form failed; -C = 11: the reduction of AW-BW*inv(DW)*CW to a -C real Schur form failed; -C = 12: the solution of the Sylvester equation failed -C because the poles of V (if JOBV = 'V') or of -C conj(V) (if JOBV = 'C') are not distinct from -C the poles of G1 (see METHOD); -C = 13: the solution of the Sylvester equation failed -C because the poles of W (if JOBW = 'W') or of -C conj(W) (if JOBW = 'C') are not distinct from -C the poles of G1 (see METHOD); -C = 14: the solution of the Sylvester equation failed -C because the zeros of V (if JOBV = 'I') or of -C conj(V) (if JOBV = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 15: the solution of the Sylvester equation failed -C because the zeros of W (if JOBW = 'I') or of -C conj(W) (if JOBW = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 16: the solution of the generalized Sylvester system -C failed because the zeros of V (if JOBV = 'I') or -C of conj(V) (if JOBV = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 17: the solution of the generalized Sylvester system -C failed because the zeros of W (if JOBW = 'I') or -C of conj(W) (if JOBW = 'R') are not distinct from -C the poles of G1sr (see METHOD); -C = 18: op(V) is not antistable; -C = 19: op(W) is not antistable; -C = 20: V is not invertible; -C = 21: W is not invertible. -C -C METHOD -C -C Let G be the transfer-function matrix of the original -C linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09JD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that the corresponding transfer-function matrix Gr minimizes -C the Hankel-norm of the frequency-weighted error -C -C op(V)*(G-Gr)*op(W). (3) -C -C For minimizing (3) with op(V) = V and op(W) = W, V and W are -C assumed to have poles distinct from those of G, while with -C op(V) = conj(V) and op(W) = conj(W), conj(V) and conj(W) are -C assumed to have poles distinct from those of G. For minimizing (3) -C with op(V) = inv(V) and op(W) = inv(W), V and W are assumed to -C have zeros distinct from the poles of G, while with -C op(V) = conj(inv(V)) and op(W) = conj(inv(W)), conj(V) and conj(W) -C are assumed to have zeros distinct from the poles of G. -C -C Note: conj(G) = G'(-s) for a continuous-time system and -C conj(G) = G'(1/z) for a discrete-time system. -C -C The following procedure is used to reduce G (see [1]): -C -C 1) Decompose additively G as -C -C G = G1 + G2, -C -C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and -C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. -C -C 2) Compute G1s, the projection of op(V)*G1*op(W) containing the -C poles of G1, using explicit formulas [4] or the inverse-free -C descriptor system formulas of [5]. -C -C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s, -C of order r. -C -C 4) Compute G1r, the projection of inv(op(V))*G1sr*inv(op(W)) -C containing the poles of G1sr, using explicit formulas [4] -C or the inverse-free descriptor system formulas of [5]. -C -C 5) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the weighted ALPHA-stable part G1s at step 3, the -C optimal Hankel-norm approximation method of [2], based on the -C square-root balancing projection formulas of [3], is employed. -C -C The optimal weighted approximation error satisfies -C -C HNORM[op(V)*(G-Gr)*op(W)] >= S(r+1), -C -C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the -C transfer-function matrix computed at step 2 of the above -C procedure, and HNORM(.) denotes the Hankel-norm. -C -C REFERENCES -C -C [1] Latham, G.A. and Anderson, B.D.O. -C Frequency-weighted optimal Hankel-norm approximation of stable -C transfer functions. -C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. -C -C [2] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [3] Tombs, M.S. and Postlethwaite, I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [4] Varga, A. -C Explicit formulas for an efficient implementation -C of the frequency-weighting model reduction approach. -C Proc. 1993 European Control Conference, Groningen, NL, -C pp. 693-696, 1993. -C -C [5] Varga, A. -C Efficient and numerically reliable implementation of the -C frequency-weighted Hankel-norm approximation model reduction -C approach. -C Proc. 2001 ECC, Porto, Portugal, 2001. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2001. -C D. Sima, University of Bucharest, April 2001. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C March 2005. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, P0001, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, P0001 = 0.0001D0, - $ ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, - $ NR, NS, NV, NW, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), - $ HSV(*) -C .. Local Scalars .. - CHARACTER JOBVL, JOBWL - LOGICAL AUTOM, CONJV, CONJW, DISCR, FIXORD, FRWGHT, - $ INVFR, LEFTI, LEFTW, RIGHTI, RIGHTW - INTEGER IERR, IWARNL, KAV, KAW, KBV, KBW, KCV, KCW, KDV, - $ KDW, KEV, KEW, KI, KL, KU, KW, LDABV, LDABW, - $ LDCDV, LDCDW, LW, NRA, NU, NU1, NVP, NWM, RANK - DOUBLE PRECISION ALPWRK, MAXRED, RCOND, SQREPS, TOL, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION TEMP(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB07ND, AB08MD, AB09CX, AB09JV, AB09JW, AG07BD, - $ DLACPY, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFTI = LSAME( JOBV, 'I' ) .OR. LSAME( JOBV, 'R' ) - LEFTW = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'C' ) .OR. LEFTI - CONJV = LSAME( JOBV, 'C' ) .OR. LSAME( JOBV, 'R' ) - RIGHTI = LSAME( JOBW, 'I' ) .OR. LSAME( JOBW, 'R' ) - RIGHTW = LSAME( JOBW, 'W' ) .OR. LSAME( JOBW, 'C' ) .OR. RIGHTI - CONJW = LSAME( JOBW, 'C' ) .OR. LSAME( JOBW, 'R' ) - FRWGHT = LEFTW .OR. RIGHTW - INVFR = LSAME( JOBINV, 'N' ) - AUTOM = LSAME( JOBINV, 'A' ) -C - LW = 1 - IF( LEFTW ) THEN - NVP = NV + P - LW = MAX( LW, 2*NVP*( NVP + P ) + P*P + - $ MAX( 2*NVP*NVP + MAX( 11*NVP + 16, P*NVP ), - $ NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) ) - END IF - IF( RIGHTW ) THEN - NWM = NW + M - LW = MAX( LW, 2*NWM*( NWM + M ) + M*M + - $ MAX( 2*NWM*NWM + MAX( 11*NWM + 16, M*NWM ), - $ NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) ) - END IF - LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) - LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( JOBV, 'N' ) .OR. LEFTW ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOBW, 'N' ) .OR. RIGHTW ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( INVFR .OR. AUTOM .OR. LSAME( JOBINV, 'I' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( N.LT.0 ) THEN - INFO = -7 - ELSE IF( NV.LT.0 ) THEN - INFO = -8 - ELSE IF( NW.LT.0 ) THEN - INFO = -9 - ELSE IF( M.LT.0 ) THEN - INFO = -10 - ELSE IF( P.LT.0 ) THEN - INFO = -11 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -12 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -13 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -21 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -23 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -25 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN - INFO = -27 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN - INFO = -29 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -31 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -33 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -35 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -37 - ELSE IF( TOL1.GE.ONE ) THEN - INFO = -40 - ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) - $ .OR. TOL2.GE.ONE ) THEN - INFO = -41 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -44 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - SQREPS = SQRT( DLAMCH( 'E' ) ) - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQREPS - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQREPS - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + N*N - KI = KL + N - KW = KI + N -C -C Compute an additive decomposition G = G1 + G2, where G1 -C is the ALPHA-stable projection of G. -C -C Reduce A to a block-diagonal real Schur form, with the NU-th order -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) - IWARNL = 0 -C - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 - IF( CONJV ) THEN - JOBVL = 'C' - ELSE - JOBVL = 'V' - END IF - IF( CONJW ) THEN - JOBWL = 'C' - ELSE - JOBWL = 'W' - END IF - IF( LEFTW ) THEN -C -C Check if V is invertible. -C Real workspace: need (NV+P)**2 + MAX( P + MAX(3*P,NV), -C MIN(P+1,NV) + MAX(3*(P+1),NV+P) ); -C prefer larger. -C Integer workspace: need 2*NV+P+2. -C - TOL = ZERO - CALL AB08MD( 'S', NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, - $ DV, LDDV, RANK, TOL, IWORK, DWORK, LDWORK, - $ IERR ) - IF( RANK.NE.P ) THEN - INFO = 20 - RETURN - END IF - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF( LEFTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of V. -C Workspace: need NV*(NV+2*P) + P*P. -C - KAV = 1 - KBV = KAV + NV*NV - KCV = KBV + NV*P - KDV = KCV + P*NV - KW = KDV + P*P -C - LDABV = MAX( NV, 1 ) - LDCDV = P - CALL DLACPY( 'Full', NV, NV, AV, LDAV, - $ DWORK(KAV), LDABV ) - CALL DLACPY( 'Full', NV, P, BV, LDBV, - $ DWORK(KBV), LDABV ) - CALL DLACPY( 'Full', P, NV, CV, LDCV, - $ DWORK(KCV), LDCDV ) - CALL DLACPY( 'Full', P, P, DV, LDDV, - $ DWORK(KDV), LDCDV ) -C -C Compute the standard inverse of V. -C Additional real workspace: need MAX(1,4*P); -C prefer larger. -C Integer workspace: need 2*P. -C - CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN - INFO = 20 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of V. -C - KAV = 1 - KEV = KAV + NVP*NVP - KBV = KEV + NVP*NVP - KCV = KBV + NVP*P - KDV = KCV + P*NVP - KW = KDV + P*P -C - LDABV = MAX( NVP, 1 ) - LDCDV = P -C -C DV is singular or ill-conditioned. -C Form a descriptor inverse of V. -C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. -C - CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, - $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, - $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of V -C of order NVP = NV + P. -C Additional real workspace: need -C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), -C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); -C prefer larger. -C Integer workspace: need NVP+N+6. -C - CALL AB09JV( JOBVL, DICO, 'G', 'C', NS, M, P, NVP, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, - $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, - $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, - $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 5 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 16 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 18 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of V. -C Additional real workspace: need -C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, - $ TEMP, 1, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 10 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 14 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 18 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection of V*G1 or conj(V)*G1 containing the -C poles of G. -C -C Workspace need: -C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, AV, LDAV, - $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, - $ DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 3 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 12 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 18 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - IF( RIGHTW ) THEN -C -C Check if W is invertible. -C Real workspace: need (NW+M)**2 + MAX( M + MAX(3*M,NW), -C MIN(M+1,NW) + MAX(3*(M+1),NW+M) ); -C prefer larger. -C Integer workspace: need 2*NW+M+2. -C - TOL = ZERO - CALL AB08MD( 'S', NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DW, LDDW, RANK, TOL, IWORK, DWORK, LDWORK, - $ IERR ) - IF( RANK.NE.M ) THEN - INFO = 21 - RETURN - END IF - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF( RIGHTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of W. -C Workspace: need NW*(NW+2*M) + M*M. -C - KAW = 1 - KBW = KAW + NW*NW - KCW = KBW + NW*M - KDW = KCW + M*NW - KW = KDW + M*M -C - LDABW = MAX( NW, 1 ) - LDCDW = M - CALL DLACPY( 'Full', NW, NW, AW, LDAW, - $ DWORK(KAW), LDABW ) - CALL DLACPY( 'Full', NW, M, BW, LDBW, - $ DWORK(KBW), LDABW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, - $ DWORK(KCW), LDCDW ) - CALL DLACPY( 'Full', M, M, DW, LDDW, - $ DWORK(KDW), LDCDW ) -C -C Compute the standard inverse of W. -C Additional real workspace: need MAX(1,4*M); -C prefer larger. -C Integer workspace: need 2*M. -C - CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN - INFO = 21 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of W. -C - KAW = 1 - KEW = KAW + NWM*NWM - KBW = KEW + NWM*NWM - KCW = KBW + NWM*M - KDW = KCW + M*NWM - KW = KDW + M*M -C - LDABW = MAX( NWM, 1 ) - LDCDW = M -C -C DW is singular or ill-conditioned. -C Form the descriptor inverse of W. -C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. -C - CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, - $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of W -C of order NWM = NW + M. -C Additional real workspace: need -C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), -C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); -C prefer larger. -C Integer workspace: need NWM+N+6. -C - CALL AB09JW( JOBWL, DICO, 'G', 'C', NS, M, P, NWM, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 6 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 17 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 19 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of W. -C Additional real workspace: need -C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBWL = 'W', -C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ TEMP, 1, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 11 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 15 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 19 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection G1s of V*G1*W or conj(V)*G1*conj(W) -C containing the poles of G. -C -C Workspace need: -C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C b = 0, if DICO = 'C' or JOBWL = 'W', -C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, - $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, - $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 4 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 13 - ELSE IF( IERR.EQ.4 ) THEN - INFO = 19 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C -C Determine a reduced order approximation G1sr of G1s using the -C Hankel-norm approximation method. The resulting A(NU1:N,NU1:N) -C is further in a real Schur form. -C -C Workspace: need MAX( LDW3, LDW4 ), -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ); -C prefer larger. -C - CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) -C - IF( IERR.NE.0 ) THEN -C -C Set INFO = 7, 8 or 9. -C - INFO = IERR + 5 - RETURN - END IF -C - IWARN = MAX( IWARNL, IWARN ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF( LEFTW ) THEN - IF( .NOT.LEFTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of V. -C Workspace: need NV*(NV+2*P) + P*P. -C - KAV = 1 - KBV = KAV + NV*NV - KCV = KBV + NV*P - KDV = KCV + P*NV - KW = KDV + P*P -C - LDABV = MAX( NV, 1 ) - LDCDV = P - CALL DLACPY( 'Full', NV, NV, AV, LDAV, - $ DWORK(KAV), LDABV ) - CALL DLACPY( 'Full', NV, P, BV, LDBV, - $ DWORK(KBV), LDABV ) - CALL DLACPY( 'Full', P, NV, CV, LDCV, - $ DWORK(KCV), LDCDV ) - CALL DLACPY( 'Full', P, P, DV, LDDV, - $ DWORK(KDV), LDCDV ) -C -C Compute the standard inverse of V. -C Additional real workspace: need MAX(1,4*P); -C prefer larger. -C Integer workspace: need 2*P. -C - CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN - INFO = 20 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of V. -C - KAV = 1 - KEV = KAV + NVP*NVP - KBV = KEV + NVP*NVP - KCV = KBV + NVP*P - KDV = KCV + P*NVP - KW = KDV + P*P -C - LDABV = MAX( NVP, 1 ) - LDCDV = P -C -C DV is singular or ill-conditioned. -C Form a descriptor inverse of V. -C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. -C - CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, - $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, - $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of V -C of order NVP = NV + P. -C Additional real workspace: need -C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), -C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); -C prefer larger. -C Integer workspace: need NVP+N+6. -C - CALL AB09JV( JOBVL, DICO, 'G', 'N', NRA, M, P, NVP, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, - $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, - $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, - $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 5 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 16 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of V. -C Additional real workspace: need -C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, - $ TEMP, 1, DWORK(KBV), LDABV, - $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 10 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 14 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection of V*G1sr or conj(V)*G1sr containing -C the poles of G. -C -C Workspace need: -C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBVL = 'V', -C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; -C prefer larger. -C - CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, AV, LDAV, - $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, - $ DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 3 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 12 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - IF( RIGHTW ) THEN - IF( .NOT.RIGHTI ) THEN - IF( INVFR ) THEN - IERR = 1 - ELSE -C -C Allocate storage for a standard inverse of W. -C Workspace: need NW*(NW+2*M) + M*M. -C - KAW = 1 - KBW = KAW + NW*NW - KCW = KBW + NW*M - KDW = KCW + M*NW - KW = KDW + M*M -C - LDABW = MAX( NW, 1 ) - LDCDW = M - CALL DLACPY( 'Full', NW, NW, AW, LDAW, - $ DWORK(KAW), LDABW ) - CALL DLACPY( 'Full', NW, M, BW, LDBW, - $ DWORK(KBW), LDABW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, - $ DWORK(KCW), LDCDW ) - CALL DLACPY( 'Full', M, M, DW, LDDW, - $ DWORK(KDW), LDCDW ) -C -C Compute the standard inverse of W. -C Additional real workspace: need MAX(1,4*M); -C prefer larger. -C Integer workspace: need 2*M. -C - CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C Check if inversion is accurate. -C - IF( AUTOM ) THEN - IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 - ELSE - IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 - END IF - IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN - INFO = 21 - RETURN - END IF - END IF -C - IF( IERR.NE.0 ) THEN -C -C Allocate storage for a descriptor inverse of W. -C - KAW = 1 - KEW = KAW + NWM*NWM - KBW = KEW + NWM*NWM - KCW = KBW + NWM*M - KDW = KCW + M*NWM - KW = KDW + M*M -C - LDABW = MAX( NWM, 1 ) - LDCDW = M -C -C DW is singular or ill-conditioned. -C Form the descriptor inverse of W. -C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. -C - CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, - $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using descriptor inverse of W -C of order NWM = NW + M. -C Additional real workspace: need -C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), -C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); -C prefer larger. -C Integer workspace: need NWM+N+6. -C - CALL AB09JW( JOBWL, DICO, 'G', 'N', NRA, M, P, NWM, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 6 - ELSE IF( IERR.EQ.2 ) THEN - INFO = 17 - END IF - RETURN - END IF - ELSE -C -C Compute the projection containing the poles of weighted -C reduced ALPHA-stable part using explicit inverse of W. -C Additional real workspace: need -C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) -C a = 0, if DICO = 'C' or JOBWL = 'W', -C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, - $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, - $ TEMP, 1, DWORK(KBW), LDABW, - $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 11 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 15 - END IF - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) - ELSE -C -C Compute the projection G1r of V*G1sr*W or -C conj(V)*G1sr*conj(W) containing the poles of G. -C -C Workspace need: -C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C b = 0, if DICO = 'C' or JOBWL = 'W', -C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; -C prefer larger. -C - CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, - $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, - $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, - $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.1 ) THEN - INFO = 4 - ELSE IF( IERR.EQ.3 ) THEN - INFO = 13 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - NR = NRA + NU - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB09JD *** - END diff --git a/slycot/src/AB09JV.f b/slycot/src/AB09JV.f deleted file mode 100644 index 5a7d08ab..00000000 --- a/slycot/src/AB09JV.f +++ /dev/null @@ -1,958 +0,0 @@ - SUBROUTINE AB09JV( JOB, DICO, JOBEV, STBCHK, N, M, P, NV, PV, - $ A, LDA, B, LDB, C, LDC, D, LDD, AV, LDAV, - $ EV, LDEV, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a state-space representation (A,BS,CS,DS) of the -C projection of V*G or conj(V)*G containing the poles of G, from the -C state-space representations (A,B,C,D) and (AV-lambda*EV,BV,CV,DV), -C of the transfer-function matrices G and V, respectively. -C G is assumed to be a stable transfer-function matrix and -C the state matrix A must be in a real Schur form. -C When computing the stable projection of V*G, it is assumed -C that G and V have completely distinct poles. -C When computing the stable projection of conj(V)*G, it is assumed -C that G and conj(V) have completely distinct poles. -C -C Note: For a transfer-function matrix G, conj(G) denotes the -C conjugate of G given by G'(-s) for a continuous-time system or -C G'(1/z) for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the projection to be computed as follows: -C = 'V': compute the projection of V*G containing -C the poles of G; -C = 'C': compute the projection of conj(V)*G containing -C the poles of G. -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G and V are continuous-time systems; -C = 'D': G and V are discrete-time systems. -C -C JOBEV CHARACTER*1 -C Specifies whether EV is a general square or an identity -C matrix as follows: -C = 'G': EV is a general square matrix; -C = 'I': EV is the identity matrix. -C -C STBCHK CHARACTER*1 -C Specifies whether stability/antistability of V is to be -C checked as follows: -C = 'C': check stability if JOB = 'C' or antistability if -C JOB = 'V'; -C = 'N': do not check stability or antistability. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector of the system with -C the transfer-function matrix G. N >= 0. -C -C M (input) INTEGER -C The dimension of the input vector of the system with -C the transfer-function matrix G. M >= 0. -C -C P (input) INTEGER -C The dimension of the output vector of the system with the -C transfer-function matrix G, and also the dimension of -C the input vector if JOB = 'V', or of the output vector -C if JOB = 'C', of the system with the transfer-function -C matrix V. P >= 0. -C -C NV (input) INTEGER -C The dimension of the state vector of the system with -C the transfer-function matrix V. NV >= 0. -C -C PV (input) INTEGER -C The dimension of the output vector, if JOB = 'V', or -C of the input vector, if JOB = 'C', of the system with -C the transfer-function matrix V. PV >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system with the transfer-function -C matrix G in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain -C the input/state matrix B of the system with the -C transfer-function matrix G. The matrix BS is equal to B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading PV-by-N part of this -C array contains the output matrix CS of the projection of -C V*G, if JOB = 'V', or of conj(V)*G, if JOB = 'C'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P,PV). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the feedthrough matrix D of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading PV-by-M part of -C this array contains the feedthrough matrix DS of the -C projection of V*G, if JOB = 'V', or of conj(V)*G, -C if JOB = 'C'. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,P,PV). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, the leading NV-by-NV part of this array must -C contain the state matrix AV of the system with the -C transfer-function matrix V. -C On exit, if INFO = 0, the leading NV-by-NV part of this -C array contains a condensed matrix as follows: -C if JOBEV = 'I', it contains the real Schur form of AV; -C if JOBEV = 'G' and JOB = 'V', it contains a quasi-upper -C triangular matrix representing the real Schur matrix -C in the real generalized Schur form of the pair (AV,EV); -C if JOBEV = 'G', JOB = 'C' and DICO = 'C', it contains a -C quasi-upper triangular matrix corresponding to the -C generalized real Schur form of the pair (AV',EV'); -C if JOBEV = 'G', JOB = 'C' and DICO = 'D', it contains an -C upper triangular matrix corresponding to the generalized -C real Schur form of the pair (EV',AV'). -C -C LDAV INTEGER -C The leading dimension of the array AV. LDAV >= MAX(1,NV). -C -C EV (input/output) DOUBLE PRECISION array, dimension (LDEV,NV) -C On entry, if JOBEV = 'G', the leading NV-by-NV part of -C this array must contain the descriptor matrix EV of the -C system with the transfer-function matrix V. -C If JOBEV = 'I', EV is assumed to be an identity matrix -C and is not referenced. -C On exit, if INFO = 0 and JOBEV = 'G', the leading NV-by-NV -C part of this array contains a condensed matrix as follows: -C if JOB = 'V', it contains an upper triangular matrix -C corresponding to the real generalized Schur form of the -C pair (AV,EV); -C if JOB = 'C' and DICO = 'C', it contains an upper -C triangular matrix corresponding to the generalized real -C Schur form of the pair (AV',EV'); -C if JOB = 'C' and DICO = 'D', it contains a quasi-upper -C triangular matrix corresponding to the generalized -C real Schur form of the pair (EV',AV'). -C -C LDEV INTEGER -C The leading dimension of the array EV. -C LDEV >= MAX(1,NV), if JOBEV = 'G'; -C LDEV >= 1, if JOBEV = 'I'. -C -C BV (input/output) DOUBLE PRECISION array, -C dimension (LDBV,MBV), where MBV = P, if JOB = 'V', and -C MBV = PV, if JOB = 'C'. -C On entry, the leading NV-by-MBV part of this array must -C contain the input matrix BV of the system with the -C transfer-function matrix V. -C On exit, if INFO = 0, the leading NV-by-MBV part of this -C array contains Q'*BV, where Q is the orthogonal matrix -C that reduces AV to the real Schur form or the left -C orthogonal matrix used to reduce the pair (AV,EV), -C (AV',EV') or (EV',AV') to the generalized real Schur form. -C -C LDBV INTEGER -C The leading dimension of the array BV. LDBV >= MAX(1,NV). -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, the leading PCV-by-NV part of this array must -C contain the output matrix CV of the system with the -C transfer-function matrix V, where PCV = PV, if JOB = 'V', -C or PCV = P, if JOB = 'C'. -C On exit, if INFO = 0, the leading PCV-by-NV part of this -C array contains CV*Q, where Q is the orthogonal matrix that -C reduces AV to the real Schur form, or CV*Z, where Z is the -C right orthogonal matrix used to reduce the pair (AV,EV), -C (AV',EV') or (EV',AV') to the generalized real Schur form. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,PV) if JOB = 'V'; -C LDCV >= MAX(1,P) if JOB = 'C'. -C -C DV (input) DOUBLE PRECISION array, -C dimension (LDDV,MBV), where MBV = P, if JOB = 'V', and -C MBV = PV, if JOB = 'C'. -C The leading PCV-by-MBV part of this array must contain -C the feedthrough matrix DV of the system with the -C transfer-function matrix V, where PCV = PV, if JOB = 'V', -C or PCV = P, if JOB = 'C'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,PV) if JOB = 'V'; -C LDDV >= MAX(1,P) if JOB = 'C'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOBEV = 'I'; -C LIWORK = NV+N+6, if JOBEV = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= LW1, if JOBEV = 'I', -C LDWORK >= LW2, if JOBEV = 'G', where -C LW1 = MAX( 1, NV*(NV+5), NV*N + MAX( a, PV*N, PV*M ) ) -C a = 0, if DICO = 'C' or JOB = 'V', -C a = 2*NV, if DICO = 'D' and JOB = 'C'; -C LW2 = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), -C NV*N + MAX( NV*N+N*N, PV*N, PV*M ) ). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of the pair (AV,EV) to the real -C generalized Schur form failed (JOBEV = 'G'), -C or the reduction of the matrix AV to the real -C Schur form failed (JOBEV = 'I); -C = 2: the solution of the Sylvester equation failed -C because the matrix A and the pencil AV-lambda*EV -C have common eigenvalues (if JOB = 'V'), or the -C pencil -AV-lambda*EV and A have common eigenvalues -C (if JOB = 'C' and DICO = 'C'), or the pencil -C AV-lambda*EV has an eigenvalue which is the -C reciprocal of one of eigenvalues of A -C (if JOB = 'C' and DICO = 'D'); -C = 3: the solution of the Sylvester equation failed -C because the matrices A and AV have common -C eigenvalues (if JOB = 'V'), or the matrices A -C and -AV have common eigenvalues (if JOB = 'C' and -C DICO = 'C'), or the matrix A has an eigenvalue -C which is the reciprocal of one of eigenvalues of AV -C (if JOB = 'C' and DICO = 'D'); -C = 4: JOB = 'V' and the pair (AV,EV) has not completely -C unstable generalized eigenvalues, or JOB = 'C' and -C the pair (AV,EV) has not completely stable -C generalized eigenvalues. -C -C METHOD -C -C If JOB = 'V', the matrices of the stable projection of V*G are -C computed as -C -C BS = B, CS = CV*X + DV*C, DS = DV*D, -C -C where X satisfies the generalized Sylvester equation -C -C AV*X - EV*X*A + BV*C = 0. -C -C If JOB = 'C', the matrices of the stable projection of conj(V)*G -C are computed using the following formulas: -C -C - for a continuous-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B, CS = BV'*X + DV'*C, DS = DV'*D, -C -C where X satisfies the generalized Sylvester equation -C -C AV'*X + EV'*X*A + CV'*C = 0. -C -C - for a discrete-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B, CS = BV'*X*A + DV'*C, DS = DV'*D + BV'*X*B, -C -C where X satisfies the generalized Sylvester equation -C -C EV'*X - AV'*X*A = CV'*C. -C -C REFERENCES -C -C [1] Varga, A. -C Efficient and numerically reliable implementation of the -C frequency-weighted Hankel-norm approximation model reduction -C approach. -C Proc. 2001 ECC, Porto, Portugal, 2001. -C -C [2] Zhou, K. -C Frequency-weighted H-infinity norm and optimal Hankel norm -C model reduction. -C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on numerically stable algorithms. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C D. Sima, University of Bucharest, March 2001. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, JOBEV, STBCHK - INTEGER INFO, LDA, LDAV, LDB, LDBV, LDC, LDCV, - $ LDD, LDDV, LDEV, LDWORK, M, N, NV, P, PV -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), B(LDB,*), BV(LDBV,*), - $ C(LDC,*), CV(LDCV,*), D(LDD,*), DV(LDDV,*), - $ DWORK(*), EV(LDEV,*) -C .. Local Scalars .. - CHARACTER*1 EVTYPE, STDOM - LOGICAL CONJS, DISCR, STABCK, UNITEV - DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK - INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, - $ KZ, LDW, LDWN, LW, SDIM -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL DELCTG, LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, - $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -C -C .. Executable Statements .. -C - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - UNITEV = LSAME( JOBEV, 'I' ) - STABCK = LSAME( STBCHK, 'C' ) -C - INFO = 0 - IF( UNITEV ) THEN - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NV - ELSE - IA = 0 - END IF - LW = MAX( 1, NV*( NV + 5 ), NV*N + MAX( IA, PV*N, PV*M ) ) - ELSE - LW = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), - $ NV*N + MAX( NV*N + N*N, PV*N, PV*M ) ) - END IF -C -C Test the input scalar arguments. -C - LDWN = MAX( 1, N ) - LDW = MAX( 1, NV ) - IF( .NOT. ( LSAME( JOB, 'V' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBEV, 'G' ) .OR. UNITEV ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NV.LT.0 ) THEN - INFO = -8 - ELSE IF( PV.LT.0 ) THEN - INFO = -9 - ELSE IF( LDA.LT.LDWN ) THEN - INFO = -11 - ELSE IF( LDB.LT.LDWN ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P, PV ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, P, PV ) ) THEN - INFO = -17 - ELSE IF( LDAV.LT.LDW ) THEN - INFO = -19 - ELSE IF( LDEV.LT.1 .OR. ( .NOT.UNITEV .AND. LDEV.LT.NV ) ) THEN - INFO = -21 - ELSE IF( LDBV.LT.LDW ) THEN - INFO = -23 - ELSE IF( ( .NOT.CONJS .AND. LDCV.LT.MAX( 1, PV ) ) .OR. - $ ( CONJS .AND. LDCV.LT.MAX( 1, P ) ) ) THEN - INFO = -25 - ELSE IF( ( .NOT.CONJS .AND. LDDV.LT.MAX( 1, PV ) ) .OR. - $ ( CONJS .AND. LDDV.LT.MAX( 1, P ) ) ) THEN - INFO = -27 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -30 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JV', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( P.EQ.0 .OR. PV.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Set options for stability/antistability checking. -C - IF( DISCR ) THEN - ALPHA = ONE - ELSE - ALPHA = ZERO - END IF -C - WORK = ONE - TOLINF = DLAMCH( 'Epsilon' ) -C - IF( UNITEV ) THEN -C -C EV is the identity matrix. -C - IF( NV.GT.0 ) THEN -C -C Reduce AV to the real Schur form using an orthogonal -C similarity transformation AV <- Q'*AV*Q and apply the -C transformation to BV and CV: BV <- Q'*BV and CV <- CV*Q. -C -C Workspace needed: NV*(NV+5); -C prefer larger. -C - KW = NV*( NV + 2 ) + 1 - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) - CALL TB01WD( NV, PV, P, AV, LDAV, BV, LDBV, CV, LDCV, - $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - ELSE - STDOM = 'U' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL TB01WD( NV, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, - $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of eigenvalues of AV. -C - CALL AB09JX( DICO, STDOM, 'S', NV, ALPHA, DWORK, - $ DWORK(NV+1), DWORK, TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF -C - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - END IF -C - KW = NV*N + 1 - IF( CONJS ) THEN -C -C Compute the projection of conj(V)*G. -C -C Total workspace needed: NV*N + MAX( a, PV*N, PV*M ), where -C a = 0, if DICO = 'C', -C a = 2*NV, if DICO = 'D'. -C -C Compute -CV'*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute X and SCALE satisfying -C -C AV'*X*A - X = -SCALE*CV'*C. -C -C Additional workspace needed: 2*NV. -C - CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct CS = DV'*C + BV'*X*A/SCALE, -C DS = DV'*D + BV'*X*B/SCALE. -C -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C C <- DV'*C. -C - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) -C -C D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) -C -C C <- C + BV'*X*A/SCALE. -C - CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ZERO, DWORK(KW), PV ) - CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, - $ A, LDA, ONE, C, LDC ) -C -C D <- D + BV'*X*B/SCALE. -C - CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, - $ B, LDB, ONE, D, LDD ) - ELSE -C -C Compute X and SCALE satisfying -C -C AV'*X + X*A + SCALE*CV'*C = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct CS = DV'*C + BV'*X/SCALE, -C DS = DV'*D. -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C Construct C <- DV'*C + BV'*X/SCALE. -C - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - ELSE -C -C Compute the projection of V*G. -C -C Total workspace needed: NV*N + MAX( PV*N, PV*M ). -C -C Compute -BV*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, - $ ZERO, DWORK, LDW ) -C -C Compute X and SCALE satisfying -C -C AV*X - X*A + SCALE*BV*C = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct CS = DV*C + CV*X/SCALE, -C DS = DV*D. -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C Construct C <- DV*C + CV*X/SCALE. -C - CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV*D. -C - CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - ELSE -C -C EV is a general matrix. -C - IF( NV.GT.0 ) THEN - TOLINF = TOLINF * DLANGE( '1', NV, NV, EV, LDEV, DWORK ) -C -C Reduce (AV,EV), or (AV',EV') or (EV',AV') to a generalized -C real Schur form using an orthogonal equivalence -C transformation and apply the orthogonal transformation -C appropriately to BV and CV, or CV' and BV'. -C -C Workspace needed: 2*NV*NV + MAX( 11*NV+16, NV*P, NV*PV ); -C prefer larger. -C - KQ = 1 - KZ = KQ + NV*NV - KAR = KZ + NV*NV - KAI = KAR + NV - KB = KAI + NV - KW = KB + NV -C - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) -C -C Transpose AV and EV, if non-scalar. -C - DO 10 I = 1, NV - 1 - CALL DSWAP( NV-I, AV(I+1,I), 1, AV(I,I+1), LDAV ) - CALL DSWAP( NV-I, EV(I+1,I), 1, EV(I,I+1), LDEV ) - 10 CONTINUE -C - IF( DISCR ) THEN -C -C Reduce (EV',AV') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*EV'*Z results in a quasi-triangular form -C and Q'*AV'*Z results upper triangular. -C Total workspace needed: 2*NV*NV + 11*NV + 16. -C - EVTYPE = 'R' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NV, EV, LDEV, AV, LDAV, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - ELSE -C -C Reduce (AV',EV') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AV'*Z results in a quasi-triangular form -C and Q'*EV'*Z results upper triangular. -C Total workspace needed: 2*NV*NV + 11*NV + 16. -C - EVTYPE = 'G' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Z'*BV and CV*Q. -C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). -C - KW = KAR - CALL DLACPY( 'Full', NV, PV, BV, LDBV, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NV, PV, NV, ONE, DWORK(KZ), LDW, - $ DWORK(KW), LDW, ZERO, BV, LDBV ) - CALL DLACPY( 'Full', P, NV, CV, LDCV, DWORK(KW), P ) - CALL DGEMM( 'N', 'N', P, NV, NV, ONE, DWORK(KW), P, - $ DWORK(KQ), LDW, ZERO, CV, LDCV ) - ELSE -C -C Reduce (AV,EV) to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AV*Z results in a quasi-triangular form -C and Q'*EV*Z results upper triangular. -C Total workspace needed: 2*NV*NV + 11*NV + 16. -C - STDOM = 'U' - EVTYPE = 'G' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Q'*BV and CV*Z. -C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). -C - KW = KAR - CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NV, P, NV, ONE, DWORK(KQ), LDW, - $ DWORK(KW), LDW, ZERO, BV, LDBV ) - CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KW), PV ) - CALL DGEMM( 'N', 'N', PV, NV, NV, ONE, DWORK(KW), PV, - $ DWORK(KZ), LDW, ZERO, CV, LDCV ) - END IF - WORK = MAX( WORK, DBLE( 2*NV*NV + NV*MAX( P, PV ) ) ) -C - END IF -C - KC = 1 - KF = KC + NV*N - KE = KF + NV*N - KW = KE + N*N - CALL DLASET( 'Full', NV, N, ZERO, ZERO, DWORK(KF), LDW ) -C - IF( CONJS ) THEN -C -C Compute the projection of conj(V)*G. -C -C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) -C -C Compute CV'*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'T', 'N', NV, N, P, ONE, CV, LDCV, C, LDC, - $ ZERO, DWORK(KC), LDW ) -C - IF( DISCR ) THEN -C -C Compute X and SCALE satisfying -C -C EV'*X - AV'*X*A = SCALE*CV'*C by solving equivalently -C -C EV'*X - Y*A = SCALE*CV'*C, -C AV'*X - Y = 0. -C -C Additional workspace needed: -C real NV*N + N*N; -C integer NV+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, NV, N, EV, LDEV, A, LDA, - $ DWORK(KC), LDW, AV, LDAV, DWORK(KE), - $ LDWN, DWORK(KF), LDW, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct C <- DV'*C + BV'*X*A/SCALE, -C D <- DV'*D + BV'*X*B/SCALE. -C -C Additional workspace needed: MAX( PV*N, PV*M ). -C -C C <- DV'*C. -C - KW = KF - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) -C -C D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) -C -C C <- C + BV'*X*A/SCALE. -C - CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK(KC), LDW, ZERO, DWORK(KW), PV ) - CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, - $ A, LDA, ONE, C, LDC ) -C -C D <- D + BV'*X*B/SCALE. -C - CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, - $ B, LDB, ONE, D, LDD ) - ELSE -C -C Compute X and SCALE satisfying -C -C AV'*X + EV'*X*A + SCALE*CV'*C = 0 by solving equivalently -C -C AV'*X - Y*A = -SCALE*CV'*C, -C EV'*X - Y*(-I) = 0. -C -C Additional workspace needed: -C real NV*N+N*N; -C integer NV+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, - $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), - $ LDWN, DWORK(KF), LDW, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) -C -C Note that the computed solution in DWORK(KC) is -X. -C - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct C <- DV'*C + BV'*X/SCALE. -C - KW = KF - CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'T', 'N', PV, N, NV, -ONE / SCALE, BV, LDBV, - $ DWORK(KC), LDW, ONE, C, LDC ) -C -C Construct D <- DV'*D. -C - CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - ELSE -C -C Compute the projection of V*G. -C -C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) -C -C Compute -BV*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, - $ ZERO, DWORK, LDW ) -C -C Compute X and SCALE satisfying -C -C AV*X - EV*X*A + SCALE*BV*C = 0 by solving equivalently -C -C AV*X - Y*A = -SCALE*BV*C, -C EV*X - Y = 0. -C -C Additional workspace needed: -C real NV*N + N*N; -C integer NV+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) - CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, - $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), LDWN, - $ DWORK(KF), LDW, SCALE, DIF, DWORK(KW), - $ LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct C <- DV*C + CV*X/SCALE. -C - KW = KF - CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) - CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV*D. -C - CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), PV ) - CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) - END IF - END IF -C - DWORK(1) = MAX( WORK, DBLE( LW ) ) -C - RETURN -C *** Last line of AB09JV *** - END diff --git a/slycot/src/AB09JW.f b/slycot/src/AB09JW.f deleted file mode 100644 index 9c806842..00000000 --- a/slycot/src/AB09JW.f +++ /dev/null @@ -1,972 +0,0 @@ - SUBROUTINE AB09JW( JOB, DICO, JOBEW, STBCHK, N, M, P, NW, MW, - $ A, LDA, B, LDB, C, LDC, D, LDD, AW, LDAW, - $ EW, LDEW, BW, LDBW, CW, LDCW, DW, LDDW, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a state-space representation (A,BS,CS,DS) of the -C projection of G*W or G*conj(W) containing the poles of G, from the -C state-space representations (A,B,C,D) and (AW-lambda*EW,BW,CW,DW), -C of the transfer-function matrices G and W, respectively. -C G is assumed to be a stable transfer-function matrix and -C the state matrix A must be in a real Schur form. -C When computing the stable projection of G*W, it is assumed -C that G and W have completely distinct poles. -C When computing the stable projection of G*conj(W), it is assumed -C that G and conj(W) have completely distinct poles. -C -C Note: For a transfer-function matrix G, conj(G) denotes the -C conjugate of G given by G'(-s) for a continuous-time system or -C G'(1/z) for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the projection to be computed as follows: -C = 'W': compute the projection of G*W containing -C the poles of G; -C = 'C': compute the projection of G*conj(W) containing -C the poles of G. -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G and W are continuous-time systems; -C = 'D': G and W are discrete-time systems. -C -C JOBEW CHARACTER*1 -C Specifies whether EW is a general square or an identity -C matrix as follows: -C = 'G': EW is a general square matrix; -C = 'I': EW is the identity matrix. -C -C STBCHK CHARACTER*1 -C Specifies whether stability/antistability of W is to be -C checked as follows: -C = 'C': check stability if JOB = 'C' or antistability if -C JOB = 'W'; -C = 'N': do not check stability or antistability. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector of the system with -C the transfer-function matrix G. N >= 0. -C -C M (input) INTEGER -C The dimension of the input vector of the system with -C the transfer-function matrix G, and also the dimension -C of the output vector if JOB = 'W', or of the input vector -C if JOB = 'C', of the system with the transfer-function -C matrix W. M >= 0. -C -C P (input) INTEGER -C The dimension of the output vector of the system with the -C transfer-function matrix G. P >= 0. -C -C NW (input) INTEGER -C The dimension of the state vector of the system with the -C transfer-function matrix W. NW >= 0. -C -C MW (input) INTEGER -C The dimension of the input vector, if JOB = 'W', or of -C the output vector, if JOB = 'C', of the system with the -C transfer-function matrix W. MW >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system with the transfer-function -C matrix G in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, -C dimension (LDB,MAX(M,MW)) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading N-by-MW part of this -C array contains the input matrix BS of the projection of -C G*W, if JOB = 'W', or of G*conj(W), if JOB = 'C'. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain -C the output/state matrix C of the system with the -C transfer-function matrix G. The matrix CS is equal to C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, -C dimension (LDB,MAX(M,MW)) -C On entry, the leading P-by-M part of this array must -C contain the feedthrough matrix D of the system with -C the transfer-function matrix G. -C On exit, if INFO = 0, the leading P-by-MW part of -C this array contains the feedthrough matrix DS of the -C projection of G*W, if JOB = 'W', or of G*conj(W), -C if JOB = 'C'. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,P). -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, the leading NW-by-NW part of this array must -C contain the state matrix AW of the system with the -C transfer-function matrix W. -C On exit, if INFO = 0, the leading NW-by-NW part of this -C array contains a condensed matrix as follows: -C if JOBEW = 'I', it contains the real Schur form of AW; -C if JOBEW = 'G' and JOB = 'W', it contains a quasi-upper -C triangular matrix representing the real Schur matrix -C in the real generalized Schur form of the pair (AW,EW); -C if JOBEW = 'G', JOB = 'C' and DICO = 'C', it contains a -C quasi-upper triangular matrix corresponding to the -C generalized real Schur form of the pair (AW',EW'); -C if JOBEW = 'G', JOB = 'C' and DICO = 'D', it contains an -C upper triangular matrix corresponding to the generalized -C real Schur form of the pair (EW',AW'). -C -C LDAW INTEGER -C The leading dimension of the array AW. LDAW >= MAX(1,NW). -C -C EW (input/output) DOUBLE PRECISION array, dimension (LDEW,NW) -C On entry, if JOBEW = 'G', the leading NW-by-NW part of -C this array must contain the descriptor matrix EW of the -C system with the transfer-function matrix W. -C If JOBEW = 'I', EW is assumed to be an identity matrix -C and is not referenced. -C On exit, if INFO = 0 and JOBEW = 'G', the leading NW-by-NW -C part of this array contains a condensed matrix as follows: -C if JOB = 'W', it contains an upper triangular matrix -C corresponding to the real generalized Schur form of the -C pair (AW,EW); -C if JOB = 'C' and DICO = 'C', it contains an upper -C triangular matrix corresponding to the generalized real -C Schur form of the pair (AW',EW'); -C if JOB = 'C' and DICO = 'D', it contains a quasi-upper -C triangular matrix corresponding to the generalized -C real Schur form of the pair (EW',AW'). -C -C LDEW INTEGER -C The leading dimension of the array EW. -C LDEW >= MAX(1,NW), if JOBEW = 'G'; -C LDEW >= 1, if JOBEW = 'I'. -C -C BW (input/output) DOUBLE PRECISION array, -C dimension (LDBW,MBW), where MBW = MW, if JOB = 'W', and -C MBW = M, if JOB = 'C'. -C On entry, the leading NW-by-MBW part of this array must -C contain the input matrix BW of the system with the -C transfer-function matrix W. -C On exit, if INFO = 0, the leading NW-by-MBW part of this -C array contains Q'*BW, where Q is the orthogonal matrix -C that reduces AW to the real Schur form or the left -C orthogonal matrix used to reduce the pair (AW,EW), -C (AW',EW') or (EW',AW') to the generalized real Schur form. -C -C LDBW INTEGER -C The leading dimension of the array BW. LDBW >= MAX(1,NW). -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, the leading PCW-by-NW part of this array must -C contain the output matrix CW of the system with the -C transfer-function matrix W, where PCW = M if JOB = 'W' or -C PCW = MW if JOB = 'C'. -C On exit, if INFO = 0, the leading PCW-by-NW part of this -C array contains CW*Q, where Q is the orthogonal matrix that -C reduces AW to the real Schur form, or CW*Z, where Z is the -C right orthogonal matrix used to reduce the pair (AW,EW), -C (AW',EW') or (EW',AW') to the generalized real Schur form. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,PCW), where PCW = M if JOB = 'W', or -C PCW = MW if JOB = 'C'. -C -C DW (input) DOUBLE PRECISION array, -C dimension (LDDW,MBW), where MBW = MW if JOB = 'W', and -C MBW = M if JOB = 'C'. -C The leading PCW-by-MBW part of this array must contain -C the feedthrough matrix DW of the system with the -C transfer-function matrix W, where PCW = M if JOB = 'W', -C or PCW = MW if JOB = 'C'. -C -C LDDW INTEGER -C LDDW >= MAX(1,PCW), where PCW = M if JOB = 'W', or -C PCW = MW if JOB = 'C'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOBEW = 'I'; -C LIWORK = NW+N+6, if JOBEW = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= LW1, if JOBEW = 'I', -C LDWORK >= LW2, if JOBEW = 'G', where -C LW1 = MAX( 1, NW*(NW+5), NW*N + MAX( a, N*MW, P*MW ) ) -C a = 0, if DICO = 'C' or JOB = 'W', -C a = 2*NW, if DICO = 'D' and JOB = 'C'; -C LW2 = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), -C NW*N + MAX( NW*N+N*N, MW*N, P*MW ) ). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of the pair (AW,EW) to the real -C generalized Schur form failed (JOBEW = 'G'), -C or the reduction of the matrix AW to the real -C Schur form failed (JOBEW = 'I); -C = 2: the solution of the Sylvester equation failed -C because the matrix A and the pencil AW-lambda*EW -C have common eigenvalues (if JOB = 'W'), or the -C pencil -AW-lambda*EW and A have common eigenvalues -C (if JOB = 'C' and DICO = 'C'), or the pencil -C AW-lambda*EW has an eigenvalue which is the -C reciprocal of one of eigenvalues of A -C (if JOB = 'C' and DICO = 'D'); -C = 3: the solution of the Sylvester equation failed -C because the matrices A and AW have common -C eigenvalues (if JOB = 'W'), or the matrices A -C and -AW have common eigenvalues (if JOB = 'C' and -C DICO = 'C'), or the matrix A has an eigenvalue -C which is the reciprocal of one of eigenvalues of AW -C (if JOB = 'C' and DICO = 'D'); -C = 4: JOB = 'W' and the pair (AW,EW) has not completely -C unstable generalized eigenvalues, or JOB = 'C' and -C the pair (AW,EW) has not completely stable -C generalized eigenvalues. -C -C METHOD -C -C If JOB = 'W', the matrices of the stable projection of G*W are -C computed as -C -C BS = B*DW + Y*BW, CS = C, DS = D*DW, -C -C where Y satisfies the generalized Sylvester equation -C -C -A*Y*EW + Y*AW + B*CW = 0. -C -C If JOB = 'C', the matrices of the stable projection of G*conj(W) -C are computed using the following formulas: -C -C - for a continuous-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + Y*CW', CS = C, DS = D*DW', -C -C where Y satisfies the generalized Sylvester equation -C -C A*Y*EW' + Y*AW' + B*BW' = 0. -C -C - for a discrete-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + A*Y*CW', CS = C, DS = D*DW' + C*Y*CW', -C -C where Y satisfies the generalized Sylvester equation -C -C Y*EW' - A*Y*AW' = B*BW'. -C -C REFERENCES -C -C [1] Varga, A. -C Efficient and numerically reliable implementation of the -C frequency-weighted Hankel-norm approximation model reduction -C approach. -C Proc. 2001 ECC, Porto, Portugal, 2001. -C -C [2] Zhou, K. -C Frequency-weighted H-infinity norm and optimal Hankel norm -C model reduction. -C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on numerically stable algorithms. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C D. Sima, University of Bucharest, March 2001. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, JOBEW, STBCHK - INTEGER INFO, LDA, LDAW, LDB, LDBW, LDC, LDCW, - $ LDD, LDDW, LDEW, LDWORK, M, MW, N, NW, P -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AW(LDAW,*), B(LDB,*), BW(LDBW,*), - $ C(LDC,*), CW(LDCW,*), D(LDD,*), DW(LDDW,*), - $ DWORK(*), EW(LDEW,*) -C .. Local Scalars .. - CHARACTER*1 EVTYPE, STDOM - LOGICAL CONJS, DISCR, STABCK, UNITEW - DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK - INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, - $ KZ, LDW, LDWM, LDWN, LDWP, LW, SDIM -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL DELCTG, LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, - $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -C -C .. Executable Statements .. -C - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - UNITEW = LSAME( JOBEW, 'I' ) - STABCK = LSAME( STBCHK, 'C' ) -C - INFO = 0 - IF( UNITEW ) THEN - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NW - ELSE - IA = 0 - END IF - LW = MAX( 1, NW*( NW + 5 ), NW*N + MAX( IA, N*MW, P*MW ) ) - ELSE - LW = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), - $ NW*N + MAX( NW*N + N*N, MW*N, P*MW ) ) - END IF -C -C Test the input scalar arguments. -C - LDW = MAX( 1, NW ) - LDWM = MAX( 1, MW ) - LDWN = MAX( 1, N ) - LDWP = MAX( 1, P ) - IF( .NOT. ( LSAME( JOB, 'W' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBEW, 'G' ) .OR. UNITEW ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NW.LT.0 ) THEN - INFO = -8 - ELSE IF( MW.LT.0 ) THEN - INFO = -9 - ELSE IF( LDA.LT.LDWN ) THEN - INFO = -11 - ELSE IF( LDB.LT.LDWN ) THEN - INFO = -13 - ELSE IF( LDC.LT.LDWP ) THEN - INFO = -15 - ELSE IF( LDD.LT.LDWP ) THEN - INFO = -17 - ELSE IF( LDAW.LT.LDW ) THEN - INFO = -19 - ELSE IF( LDEW.LT.1 .OR. ( .NOT.UNITEW .AND. LDEW.LT.NW ) ) THEN - INFO = -21 - ELSE IF( LDBW.LT.LDW ) THEN - INFO = -23 - ELSE IF( ( .NOT.CONJS .AND. LDCW.LT.MAX( 1, M ) ) .OR. - $ ( CONJS .AND. LDCW.LT.LDWM ) ) THEN - INFO = -25 - ELSE IF( ( .NOT.CONJS .AND. LDDW.LT.MAX( 1, M ) ) .OR. - $ ( CONJS .AND. LDDW.LT.LDWM ) ) THEN - INFO = -27 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -30 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JW', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 ) THEN - CALL DLASET( 'Full', N, MW, ZERO, ZERO, B, LDB ) - CALL DLASET( 'Full', P, MW, ZERO, ZERO, D, LDD ) - DWORK(1) = ONE - RETURN - END IF -C -C Set options for stability/antistability checking. -C - IF( DISCR ) THEN - ALPHA = ONE - ELSE - ALPHA = ZERO - END IF -C - WORK = ONE - TOLINF = DLAMCH( 'Epsilon' ) -C - IF( UNITEW ) THEN -C -C EW is the identity matrix. -C - IF( NW.GT.0 ) THEN -C -C Reduce AW to the real Schur form using an orthogonal -C similarity transformation AW <- Q'*AW*Q and apply the -C transformation to BW and CW: BW <- Q'*BW and CW <- CW*Q. -C -C Workspace needed: NW*(NW+5); -C prefer larger. -C - KW = NW*( NW + 2 ) + 1 - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) - CALL TB01WD( NW, M, MW, AW, LDAW, BW, LDBW, CW, LDCW, - $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - ELSE - STDOM = 'U' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL TB01WD( NW, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), - $ DWORK(KW), LDWORK-KW+1, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of eigenvalues of AV. -C - CALL AB09JX( DICO, STDOM, 'S', NW, ALPHA, DWORK, - $ DWORK(NW+1), DWORK, TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF -C - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - END IF -C - KW = NW*N + 1 - IF( CONJS ) THEN -C -C Compute the projection of G*conj(W). -C -C Total workspace needed: NW*N + MAX( a, N*MW, P*MW ), where -C a = 0, if DICO = 'C', -C a = 2*NW, if DICO = 'D'. -C -C Compute -BW*B'. -C Workspace needed: NW*N. -C - CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute Y' and SCALE satisfying -C -C AW*Y'*A' - Y' = -SCALE*BW*B'. -C -C Additional workspace needed: 2*NW. -C - CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct BS = B*DW' + A*Y*CW'/SCALE, -C DS = D*DW' + C*Y*CW'/SCALE. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C B <- B*DW'. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) -C -C B <- B + A*Y*CW'/SCALE. -C - CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ZERO, DWORK(KW), LDWN ) - CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, - $ DWORK(KW), LDWN, ONE, B, LDB ) -C -C D <- D + C*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, - $ DWORK(KW), LDWN, ONE, D, LDD ) - ELSE -C -C Compute Y' and SCALE satisfying -C -C AW*Y' + Y'*A' + SCALE*BW*B' = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct BS = B*DW' + Y*CW'/SCALE, -C DS = D*DW'. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C Construct B <- B*DW' + Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ONE, B, LDB) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - ELSE -C -C Compute the projection of G*W. -C -C Total workspace needed: NW*N + MAX( N*MW, P*MW ). -C -C Compute B*CW. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, - $ ZERO, DWORK, LDWN ) -C -C Compute Y and SCALE satisfying -C -C A*Y - Y*AW - SCALE*B*CW = 0. -C - IF( N.GT.0 ) THEN - CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, - $ DWORK, LDWN, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - END IF -C -C Construct BS = B*DW + Y*BW/SCALE, -C DS = D*DW. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C Construct B <- B*DW + Y*BW/SCALE. -C - CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, DWORK, LDWN, - $ BW, LDBW, ONE, B, LDB) -C -C D <- D*DW. -C - CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - ELSE -C -C EW is a general matrix. -C - IF( NW.GT.0 ) THEN - TOLINF = TOLINF * DLANGE( '1', NW, NW, EW, LDEW, DWORK ) -C -C Reduce (AW,EW), or (AW',EW') or (EW',AW') to a generalized -C real Schur form using an orthogonal equivalence -C transformation and apply the orthogonal transformation -C appropriately to BW and CW, or CW' and BW'. -C -C Workspace needed: 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ); -C prefer larger. -C - KQ = 1 - KZ = KQ + NW*NW - KAR = KZ + NW*NW - KAI = KAR + NW - KB = KAI + NW - KW = KB + NW -C - IF( CONJS ) THEN - STDOM = 'S' - ALPHA = ALPHA + SQRT( TOLINF ) -C -C Transpose AW and EW, if non-scalar. -C - DO 10 I = 1, NW - 1 - CALL DSWAP( NW-I, AW(I+1,I), 1, AW(I,I+1), LDAW ) - CALL DSWAP( NW-I, EW(I+1,I), 1, EW(I,I+1), LDEW ) - 10 CONTINUE -C - IF( DISCR ) THEN -C -C Reduce (EW',AW') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*EW'*Z results in a quasi-triangular form -C and Q'*AW'*Z results upper triangular. -C Total workspace needed: 2*NW*NW + 11*NW + 16. -C - EVTYPE = 'R' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NW, EW, LDEW, AW, LDAW, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - ELSE -C -C Reduce (AW',EW') to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AW'*Z results in a quasi-triangular form -C and Q'*EW'*Z results upper triangular. -C Total workspace needed: 2*NW*NW + 11*NW + 16. -C - EVTYPE = 'G' - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - END IF - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Z'*BW and CW*Q. -C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). -C - KW = KAR - CALL DLACPY( 'Full', NW, M, BW, LDBW, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NW, M, NW, ONE, DWORK(KZ), LDW, - $ DWORK(KW), LDW, ZERO, BW, LDBW ) - CALL DLACPY( 'Full', MW, NW, CW, LDCW, DWORK(KW), LDWM ) - CALL DGEMM( 'N', 'N', MW, NW, NW, ONE, DWORK(KW), LDWM, - $ DWORK(KQ), LDW, ZERO, CW, LDCW ) - ELSE -C -C Reduce (AW,EW) to a generalized real Schur form -C using orthogonal transformation matrices Q and Z -C such that Q'*AW*Z results in a quasi-triangular form -C and Q'*EW*Z results upper triangular. -C Total workspace needed: 2*NW*NW + 11*NW + 16. -C - STDOM = 'U' - EVTYPE = 'G' - ALPHA = ALPHA - SQRT( TOLINF ) - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', - $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ DWORK(KQ), LDW, DWORK(KZ), LDW, - $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IF( STABCK ) THEN -C -C Check stability/antistability of generalized -C eigenvalues of the pair (AV,EV). -C - CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, - $ DWORK(KAR), DWORK(KAI), DWORK(KB), - $ TOLINF, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C -C Compute Q'*BW and CW*Z. -C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). -C - KW = KAR - CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KW), LDW ) - CALL DGEMM( 'T', 'N', NW, MW, NW, ONE, DWORK(KQ), LDW, - $ DWORK(KW), LDW, ZERO, BW, LDBW ) - CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KW), M ) - CALL DGEMM( 'N', 'N', M, NW, NW, ONE, DWORK(KW), M, - $ DWORK(KZ), LDW, ZERO, CW, LDCW ) - END IF - WORK = MAX( WORK, DBLE( 2*NW*NW + NW*MAX( M, MW ) ) ) -C - END IF -C - KC = 1 - KF = KC + NW*N - KE = KF + NW*N - KW = KE + N*N - CALL DLASET( 'Full', N, NW, ZERO, ZERO, DWORK(KF), LDWN ) -C - IF( CONJS ) THEN -C -C Compute the projection of G*conj(W). -C -C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) -C -C Compute B*BW'. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'T', N, NW, M, ONE, B, LDB, BW, LDBW, - $ ZERO, DWORK(KC), LDWN ) -C - IF( DISCR ) THEN -C -C Compute Y and SCALE satisfying -C -C Y*EW' - A*Y*AW' = SCALE*B*BW' by solving equivalently -C -C A*X - Y*EW' = -SCALE*B*BW', -C X - Y*AW' = 0. -C -C Additional workspace needed: -C real N*NW + N*N; -C integer NW+N+6. -C -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, N, NW, A, LDA, EW, LDEW, - $ DWORK(KC), LDWN, DWORK(KE), LDWN, AW, - $ LDAW, DWORK(KF), LDWN, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) -C -C Note that the computed solution in DWORK(KC) is -Y. -C - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct BS = B*DW' + A*Y*CW'/SCALE, -C DS = D*DW' + C*Y*CW'/SCALE. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C B <- B*DW'. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) -C -C B <- B + A*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, MW, NW, -ONE / SCALE, - $ DWORK(KF), LDWN, CW, LDCW, ZERO, - $ DWORK(KW), LDWN ) - CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, - $ DWORK(KW), LDWN, ONE, B, LDB ) -C -C D <- D + C*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, - $ DWORK(KW), LDWN, ONE, D, LDD ) - ELSE -C -C Compute Y and SCALE satisfying -C -C A*Y*EW' + Y*AW' + SCALE*B*BW' = 0 by solving equivalently -C -C A*X - Y*AW' = SCALE*B*BW', -C (-I)*X - Y*EW' = 0. -C -C Additional workspace needed: -C real N*NW+N*N; -C integer NW+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN - $ ) - CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, - $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, - $ LDEW, DWORK(KF), LDWN, SCALE, DIF, - $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct BS = B*DW' + Y*CW'/SCALE, -C DS = D*DW'. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C -C Construct B <- B*DW' + Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'T', N, MW, NW, ONE / SCALE, - $ DWORK(KF), LDWN, CW, LDCW, ONE, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - ELSE -C -C Compute the projection of G*W. -C -C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) -C -C Compute B*CW. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, - $ ZERO, DWORK(KC), LDWN ) -C -C Compute Y and SCALE satisfying -C -C -A*Y*EW + Y*AW + B*CW = 0 by solving equivalently -C -C A*X - Y*AW = SCALE*B*CW, -C X - Y*EW = 0. -C -C Additional workspace needed: -C real N*NW + N*N; -C integer NW+N+6. -C - IF( N.GT.0 ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) - CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, - $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, LDEW, - $ DWORK(KF), LDWN, SCALE, DIF, DWORK(KW), - $ LDWORK-KW+1, IWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Construct BS = B*DW + Y*BW/SCALE, -C DS = D*DW. -C -C Additional workspace needed: MAX( N*MW, P*MW ). -C Construct B <- B*DW + Y*BW/SCALE. -C - CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, - $ DWORK(KF), LDWN, BW, LDBW, ONE, B, LDB) -C -C D <- D*DW. -C - CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), LDWP ) - CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) - END IF - END IF -C - DWORK(1) = MAX( WORK, DBLE( LW ) ) -C - RETURN -C *** Last line of AB09JW *** - END diff --git a/slycot/src/AB09JX.f b/slycot/src/AB09JX.f deleted file mode 100644 index 68e2c60d..00000000 --- a/slycot/src/AB09JX.f +++ /dev/null @@ -1,253 +0,0 @@ - SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED, - $ TOLINF, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To check stability/antistability of finite eigenvalues with -C respect to a given stability domain. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the stability domain as follows: -C = 'C': for a continuous-time system; -C = 'D': for a discrete-time system. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C EVTYPE CHARACTER*1 -C Specifies whether the eigenvalues arise from a standard -C or a generalized eigenvalue problem as follows: -C = 'S': standard eigenvalue problem; -C = 'G': generalized eigenvalue problem; -C = 'R': reciprocal generalized eigenvalue problem. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of vectors ER, EI and ED. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the boundary of the domain of interest for the -C eigenvalues. For a continuous-time system -C (DICO = 'C'), ALPHA is the boundary value for the real -C parts of eigenvalues, while for a discrete-time system -C (DICO = 'D'), ALPHA >= 0 represents the boundary value for -C the moduli of eigenvalues. -C -C ER, EI, (input) DOUBLE PRECISION arrays, dimension (N) -C ED If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are -C the eigenvalues of a real matrix. -C ED is not referenced and is implicitly considered as -C a vector having all elements equal to one. -C If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j), -C j = 1,...,N, are the generalized eigenvalues of a pair of -C real matrices. If ED(j) is zero, then the j-th generalized -C eigenvalue is infinite. -C Complex conjugate pairs of eigenvalues must appear -C consecutively. -C -C Tolerances -C -C TOLINF DOUBLE PRECISION -C If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for -C detecting infinite generalized eigenvalues. -C 0 <= TOLINF < 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit, i.e., all eigenvalues lie within -C the domain of interest defined by DICO, STDOM -C and ALPHA; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: some eigenvalues lie outside the domain of interest -C defined by DICO, STDOM and ALPHA. -C METHOD -C -C The domain of interest for an eigenvalue lambda is defined by the -C parameters ALPHA, DICO and STDOM as follows: -C - for a continuous-time system (DICO = 'C'): -C Real(lambda) < ALPHA if STDOM = 'S'; -C Real(lambda) > ALPHA if STDOM = 'U'; -C - for a discrete-time system (DICO = 'D'): -C Abs(lambda) < ALPHA if STDOM = 'S'; -C Abs(lambda) > ALPHA if STDOM = 'U'. -C If EVTYPE = 'R', the same conditions apply for 1/lambda. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C -C KEYWORDS -C -C Stability. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EVTYPE, STDOM - INTEGER INFO, N - DOUBLE PRECISION ALPHA, TOLINF -C .. Array Arguments .. - DOUBLE PRECISION ED(*), EI(*), ER(*) -C .. Local Scalars - LOGICAL DISCR, RECEVP, STAB, STDEVP - DOUBLE PRECISION ABSEV, RPEV, SCALE - INTEGER I -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - STAB = LSAME( STDOM, 'S' ) - STDEVP = LSAME( EVTYPE, 'S' ) - RECEVP = LSAME( EVTYPE, 'R' ) -C -C Check the scalar input arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( STAB .OR. LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( STDEVP .OR. LSAME( EVTYPE, 'G' ) .OR. - $ RECEVP ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -5 - ELSE IF( TOLINF.LT.ZERO .OR. TOLINF.GE.ONE ) THEN - INFO = -9 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09JX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - IF( STAB ) THEN -C -C Check the stability of finite eigenvalues. -C - SCALE = ONE - IF( DISCR ) THEN - DO 10 I = 1, N - ABSEV = DLAPY2( ER(I), EI(I) ) - IF( RECEVP ) THEN - SCALE = ABSEV - ABSEV = ABS( ED(I) ) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ ABSEV.GE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 10 CONTINUE - ELSE - DO 20 I = 1, N - RPEV = ER(I) - IF( RECEVP ) THEN - SCALE = RPEV - RPEV = ED(I) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ RPEV.GE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 20 CONTINUE - END IF - ELSE -C -C Check the anti-stability of finite eigenvalues. -C - IF( DISCR ) THEN - DO 30 I = 1, N - ABSEV = DLAPY2( ER(I), EI(I) ) - IF( RECEVP ) THEN - SCALE = ABSEV - ABSEV = ABS( ED(I) ) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ ABSEV.LE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 30 CONTINUE - ELSE - DO 40 I = 1, N - RPEV = ER(I) - IF( RECEVP ) THEN - SCALE = RPEV - RPEV = ED(I) - ELSE IF( .NOT.STDEVP ) THEN - SCALE = ED(I) - END IF - IF( ABS( SCALE ).GT.TOLINF .AND. - $ RPEV.LE.ALPHA*SCALE ) THEN - INFO = 1 - RETURN - END IF - 40 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of AB09JX *** - END diff --git a/slycot/src/AB09KD.f b/slycot/src/AB09KD.f deleted file mode 100644 index d390cfd6..00000000 --- a/slycot/src/AB09KD.f +++ /dev/null @@ -1,864 +0,0 @@ - SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M, - $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using the frequency -C weighted optimal Hankel-norm approximation method. -C The Hankel norm of the weighted error -C -C V*(G-Gr)*W or conj(V)*(G-Gr)*conj(W) -C -C is minimized, where G and Gr are the transfer-function matrices -C of the original and reduced systems, respectively, and V and W -C are the transfer-function matrices of the left and right frequency -C weights, specified by their state space realizations (AV,BV,CV,DV) -C and (AW,BW,CW,DW), respectively. When minimizing the weighted -C error V*(G-Gr)*W, V and W must be antistable transfer-function -C matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be -C stable transfer-function matrices. -C Additionally, V and W must be invertible transfer-function -C matrices, with the feedthrough matrices DV and DW invertible. -C If the original system is unstable, then the frequency weighted -C Hankel-norm approximation is computed only for the -C ALPHA-stable part of the system. -C -C For a transfer-function matrix G, conj(G) denotes the conjugate -C of G given by G'(-s) for a continuous-time system or G'(1/z) -C for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the frequency-weighting problem as follows: -C = 'N': solve min||V*(G-Gr)*W||_H; -C = 'C': solve min||conj(V)*(G-Gr)*conj(W)||_H. -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C NV (input) INTEGER -C The order of the realization of the left frequency -C weighting V, i.e., the order of the matrix AV. NV >= 0. -C -C NW (input) INTEGER -C The order of the realization of the right frequency -C weighting W, i.e., the order of the matrix AW. NW >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of -C the resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the -C multiplicity of the Hankel singular value HSV(NR-NU+1), -C NR is the desired order on entry, and NMIN is the order -C of a minimal realization of the ALPHA-stable part of the -C given system; NMIN is determined as the number of Hankel -C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where -C EPS is the machine precision (see LAPACK Library Routine -C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the -C ALPHA-stable part of the weighted system (computed in -C HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the -C reduced order system in a real Schur form. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV -C part of this array must contain the state matrix AV of a -C state space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-NV part of this array contains a real Schur form -C of the state matrix of a state space realization of the -C inverse of V. -C AV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDAV INTEGER -C The leading dimension of the array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part -C of this array must contain the input matrix BV of a state -C space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-P part of this array contains the input matrix of a -C state space realization of the inverse of V. -C BV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDBV INTEGER -C The leading dimension of the array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part -C of this array must contain the output matrix CV of a state -C space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C P-by-NV part of this array contains the output matrix of a -C state space realization of the inverse of V. -C CV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input/output) DOUBLE PRECISION array, dimension (LDDV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part -C of this array must contain the feedthrough matrix DV of a -C state space realization of the left frequency weighting V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C P-by-P part of this array contains the feedthrough matrix -C of a state space realization of the inverse of V. -C DV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW -C part of this array must contain the state matrix AW of -C a state space realization of the right frequency -C weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-NW part of this array contains a real Schur form of -C the state matrix of a state space realization of the -C inverse of W. -C AW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDAW INTEGER -C The leading dimension of the array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part -C of this array must contain the input matrix BW of a state -C space realization of the right frequency weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-M part of this array contains the input matrix of a -C state space realization of the inverse of W. -C BW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDBW INTEGER -C The leading dimension of the array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part -C of this array must contain the output matrix CW of a state -C space realization of the right frequency weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C M-by-NW part of this array contains the output matrix of a -C state space realization of the inverse of W. -C CW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input/output) DOUBLE PRECISION array, dimension (LDDW,M) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part -C of this array must contain the feedthrough matrix DW of -C a state space realization of the right frequency -C weighting W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C M-by-M part of this array contains the feedthrough matrix -C of a state space realization of the inverse of W. -C DW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDDW INTEGER -C The leading dimension of the array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of this array contain -C the Hankel singular values, ordered decreasingly, of the -C ALPHA-stable part of the weighted original system. -C HSV(1) is the Hankel norm of the ALPHA-stable weighted -C subsystem. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the weighted -C original system (computed in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = MAX(1,M,c), if DICO = 'C', -C LIWORK = MAX(1,N,M,c), if DICO = 'D', -C where c = 0, if WEIGHT = 'N', -C c = 2*P, if WEIGHT = 'L', -C c = 2*M, if WEIGHT = 'R', -C c = MAX(2*M,2*P), if WEIGHT = 'B'. -C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of -C the computed minimal realization. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where -C LDW1 = 0 if WEIGHT = 'R' or 'N' and -C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C if WEIGHT = 'L' or WEIGHT = 'B', -C LDW2 = 0 if WEIGHT = 'L' or 'N' and -C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C if WEIGHT = 'R' or WEIGHT = 'B', with -C a = 0, b = 0, if DICO = 'C' or JOB = 'N', -C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system; in this case, the resulting NR is set equal -C to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system; in this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 3: the reduction of AV or AV-BV*inv(DV)*CV to a -C real Schur form failed; -C = 4: the reduction of AW or AW-BW*inv(DW)*CW to a -C real Schur form failed; -C = 5: JOB = 'N' and AV is not antistable, or -C JOB = 'C' and AV is not stable; -C = 6: JOB = 'N' and AW is not antistable, or -C JOB = 'C' and AW is not stable; -C = 7: the computation of Hankel singular values failed; -C = 8: the computation of stable projection in the -C Hankel-norm approximation algorithm failed; -C = 9: the order of computed stable projection in the -C Hankel-norm approximation algorithm differs -C from the order of Hankel-norm approximation; -C = 10: DV is singular; -C = 11: DW is singular; -C = 12: the solution of the Sylvester equation failed -C because the zeros of V (if JOB = 'N') or of conj(V) -C (if JOB = 'C') are not distinct from the poles -C of G1sr (see METHOD); -C = 13: the solution of the Sylvester equation failed -C because the zeros of W (if JOB = 'N') or of conj(W) -C (if JOB = 'C') are not distinct from the poles -C of G1sr (see METHOD). -C -C METHOD -C -C Let G be the transfer-function matrix of the original -C linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09KD determines -C the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t), (2) -C -C such that the corresponding transfer-function matrix Gr minimizes -C the Hankel-norm of the frequency-weighted error -C -C V*(G-Gr)*W, (3) -C or -C conj(V)*(G-Gr)*conj(W). (4) -C -C For minimizing (3), V and W are assumed to be antistable, while -C for minimizing (4), V and W are assumed to be stable transfer- -C function matrices. -C -C Note: conj(G) = G'(-s) for a continuous-time system and -C conj(G) = G'(1/z) for a discrete-time system. -C -C The following procedure is used to reduce G (see [1]): -C -C 1) Decompose additively G as -C -C G = G1 + G2, -C -C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and -C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. -C -C 2) Compute G1s, the stable projection of V*G1*W or -C conj(V)*G1*conj(W), using explicit formulas [4]. -C -C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s -C of order r. -C -C 4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W) -C or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4]. -C -C 5) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the weighted ALPHA-stable part G1s at step 3, the -C optimal Hankel-norm approximation method of [2], based on the -C square-root balancing projection formulas of [3], is employed. -C -C The optimal weighted approximation error satisfies -C -C HNORM[V*(G-Gr)*W] = S(r+1), -C or -C HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1), -C -C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the -C transfer-function matrix computed at step 2 of the above -C procedure, and HNORM(.) denotes the Hankel-norm. -C -C REFERENCES -C -C [1] Latham, G.A. and Anderson, B.D.O. -C Frequency-weighted optimal Hankel-norm approximation of stable -C transfer functions. -C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. -C -C [2] Glover, K. -C All optimal Hankel norm approximation of linear -C multivariable systems and their L-infinity error bounds. -C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. -C -C [3] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [4] Varga A. -C Explicit formulas for an efficient implementation -C of the frequency-weighting model reduction approach. -C Proc. 1993 European Control Conference, Groningen, NL, -C pp. 693-696, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on an accuracy enhancing square-root -C technique. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, -C by A. Varga, 1992. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. -C Oct. 2001, March 2005. -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL, WEIGHT - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, - $ NR, NS, NV, NW, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), - $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), - $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), - $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), - $ HSV(*) -C .. Local Scalars .. - LOGICAL CONJS, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW - INTEGER IA, IB, IERR, IWARNL, KI, KL, KU, KW, LW, NMIN, - $ NRA, NU, NU1 - DOUBLE PRECISION ALPWRK, MAXRED, RCOND, WRKOPT -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB07ND, AB09CX, AB09KX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NV - IB = 2*NW - ELSE - IA = 0 - IB = 0 - END IF - LW = 1 - IF( LEFTW ) - $ LW = MAX( LW, NV*(NV+5), NV*N + MAX( IA, P*N, P*M ) ) - IF( RIGHTW ) - $ LW = MAX( LW, MAX( NW*(NW+5), NW*N + MAX( IB, M*N, P*M ) ) ) - LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) - LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + - $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( NV.LT.0 ) THEN - INFO = -7 - ELSE IF( NW.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -11 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -12 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -20 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -22 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -24 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN - INFO = -26 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN - INFO = -28 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -30 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -32 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -34 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -36 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -40 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -43 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09KD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - NS = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KU = 1 - KL = KU + N*N - KI = KL + N - KW = KI + N -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation, A <- inv(T)*A*T, and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), - $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Compute the stable projection of the weighted ALPHA-stable part. -C -C Workspace: need MAX( 1, LDW1, LDW2 ), -C LDW1 = 0 if WEIGHT = 'R' or 'N' and -C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C if WEIGHT = 'L' or 'B', -C LDW2 = 0 if WEIGHT = 'L' or 'N' and -C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C if WEIGHT = 'R' or 'B', -C where a = 0, b = 0, if DICO = 'C' or JOB = 'N', -C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; -C prefer larger. -C - NS = N - NU -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 - IF( FRWGHT ) THEN - CALL AB09KX( JOB, DICO, WEIGHT, NS, NV, NW, M, P, A(NU1,NU1), - $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ DWORK, LDWORK, IWARNL, IERR ) -C - IF( IERR.NE.0 ) THEN -C -C Note: Only IERR = 1 or IERR = 2 are possible. -C Set INFO to 3 or 4. -C - INFO = IERR + 2 - RETURN - END IF -C - IF( IWARNL.NE.0 ) THEN -C -C Stability/antistability of V and W are compulsory. -C - IF( IWARNL.EQ.1 .OR. IWARNL.EQ.3 ) THEN - INFO = 5 - ELSE - INFO = 6 - END IF - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) - END IF -C -C Determine a reduced order approximation of the ALPHA-stable part. -C -C Workspace: need MAX( LDW3, LDW4 ), -C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, -C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + -C MAX( 3*M+1, MIN(N,M)+P ); -C prefer larger. -C - IWARNL = 0 - IF( FIXORD ) THEN - NRA = MAX( 0, NR - NU ) - IF( NRA.EQ.0 ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF - CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) -C - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN -C -C Set INFO = 7, 8 or 9. -C - INFO = IERR + 5 - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) - NMIN = IWORK(1) -C -C Compute the state space realizations of the inverses of V and W. -C -C Integer workspace: need c, -C Real workspace: need MAX(1,2*c), -C where c = 0, if WEIGHT = 'N', -C c = 2*P, if WEIGHT = 'L', -C c = 2*M, if WEIGHT = 'R', -C c = MAX(2*M,2*P), if WEIGHT = 'B'. -C - IF( LEFTW ) THEN - CALL AB07ND( NV, P, AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ RCOND, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 10 - RETURN - END IF - END IF - IF( RIGHTW ) THEN - CALL AB07ND( NW, M, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ RCOND, IWORK, DWORK, LDWORK, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 11 - RETURN - END IF - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C -C Compute the stable projection of weighted reduced ALPHA-stable -C part. -C - IF( FRWGHT ) THEN - CALL AB09KX( JOB, DICO, WEIGHT, NRA, NV, NW, M, P, A(NU1,NU1), - $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ DWORK, LDWORK, IWARNL, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.LE.2 ) THEN -C -C Set INFO to 3 or 4. -C - INFO = IERR + 2 - ELSE -C -C Set INFO to 12 or 13. -C - INFO = IERR + 9 - END IF - RETURN - END IF - END IF -C - NR = NRA + NU - IWORK(1) = NMIN - DWORK(1) = MAX( WRKOPT, DWORK(1) ) -C - RETURN -C *** Last line of AB09KD *** - END diff --git a/slycot/src/AB09KX.f b/slycot/src/AB09KX.f deleted file mode 100644 index 5ac044c7..00000000 --- a/slycot/src/AB09KX.f +++ /dev/null @@ -1,869 +0,0 @@ - SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P, - $ A, LDA, B, LDB, C, LDC, D, LDD, - $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, - $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a state-space representation (A,BS,CS,DS) of the -C stable projection of V*G*W or conj(V)*G*conj(W) from the -C state-space representations (A,B,C,D), (AV,BV,CV,DV), and -C (AW,BW,CW,DW) of the transfer-function matrices G, V and W, -C respectively. G is assumed to be a stable transfer-function -C matrix and the state matrix A must be in a real Schur form. -C When computing the stable projection of V*G*W, V and W are assumed -C to be completely unstable transfer-function matrices. -C When computing the stable projection of conj(V)*G*conj(W), -C V and W are assumed to be stable transfer-function matrices. -C -C For a transfer-function matrix G, conj(G) denotes the conjugate -C of G given by G'(-s) for a continuous-time system or G'(1/z) -C for a discrete-time system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies which projection to be computed as follows: -C = 'N': compute the stable projection of V*G*W; -C = 'C': compute the stable projection of -C conj(V)*G*conj(W). -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G, V and W are continuous-time systems; -C = 'D': G, V and W are discrete-time systems. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'L': only left weighting V is used (W = I); -C = 'R': only right weighting W is used (V = I); -C = 'B': both left and right weightings V and W are used. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. Also the number of rows of -C the matrix B and the number of columns of the matrix C. -C N represents the dimension of the state vector of the -C system with the transfer-function matrix G. N >= 0. -C -C NV (input) INTEGER -C The order of the matrix AV. Also the number of rows of -C the matrix BV and the number of columns of the matrix CV. -C NV represents the dimension of the state vector of the -C system with the transfer-function matrix V. NV >= 0. -C -C NW (input) INTEGER -C The order of the matrix AW. Also the number of rows of -C the matrix BW and the number of columns of the matrix CW. -C NW represents the dimension of the state vector of the -C system with the transfer-function matrix W. NW >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B, D, BW and DW -C and number of rows of the matrices CW and DW. M >= 0. -C M represents the dimension of input vectors of the -C systems with the transfer-function matrices G and W and -C also the dimension of the output vector of the system -C with the transfer-function matrix W. -C -C P (input) INTEGER -C The number of rows of the matrices C, D, CV and DV and the -C number of columns of the matrices BV and DV. P >= 0. -C P represents the dimension of output vectors of the -C systems with the transfer-function matrices G and V and -C also the dimension of the input vector of the system -C with the transfer-function matrix V. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must -C contain the state matrix A of the system with the -C transfer-function matrix G in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the input matrix BS of the stable -C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) -C if JOB = 'C'. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading P-by-N part of this -C array contains the output matrix CS of the stable -C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) -C if JOB = 'C'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the feedthrough matrix D of the system with the -C transfer-function matrix G. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the feedthrough matrix DS of the stable -C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) -C if JOB = 'C'. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,P). -C -C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV -C part of this array must contain the state matrix AV of -C the system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-NV part of this array contains a real Schur form -C of AV. -C AV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDAV INTEGER -C The leading dimension of the array AV. -C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDAV >= 1, if WEIGHT = 'R' or 'N'. -C -C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) -C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part -C of this array must contain the input matrix BV of the -C system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C NV-by-P part of this array contains the transformed input -C matrix BV. -C BV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDBV INTEGER -C The leading dimension of the array BV. -C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; -C LDBV >= 1, if WEIGHT = 'R' or 'N'. -C -C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) -C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part -C of this array must contain the output matrix CV of the -C system with the transfer-function matrix V. -C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading -C P-by-NV part of this array contains the transformed output -C matrix CV. -C CV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDCV INTEGER -C The leading dimension of the array CV. -C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDCV >= 1, if WEIGHT = 'R' or 'N'. -C -C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) -C If WEIGHT = 'L' or 'B', the leading P-by-P part of this -C array must contain the feedthrough matrix DV of the system -C with the transfer-function matrix V. -C DV is not referenced if WEIGHT = 'R' or 'N'. -C -C LDDV INTEGER -C The leading dimension of the array DV. -C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; -C LDDV >= 1, if WEIGHT = 'R' or 'N'. -C -C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW -C part of this array must contain the state matrix AW of -C the system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-NW part of this array contains a real Schur form -C of AW. -C AW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDAW INTEGER -C The leading dimension of the array AW. -C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDAW >= 1, if WEIGHT = 'L' or 'N'. -C -C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) -C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part -C of this array must contain the input matrix BW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C NW-by-M part of this array contains the transformed input -C matrix BW. -C BW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDBW INTEGER -C The leading dimension of the array BW. -C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; -C LDBW >= 1, if WEIGHT = 'L' or 'N'. -C -C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) -C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part -C of this array must contain the output matrix CW of the -C system with the transfer-function matrix W. -C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading -C M-by-NW part of this array contains the transformed output -C matrix CW. -C CW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDCW INTEGER -C The leading dimension of the array CW. -C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDCW >= 1, if WEIGHT = 'L' or 'N'. -C -C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) -C If WEIGHT = 'R' or 'B', the leading M-by-M part of this -C array must contain the feedthrough matrix DW of the system -C with the transfer-function matrix W. -C DW is not referenced if WEIGHT = 'L' or 'N'. -C -C LDDW INTEGER -C The leading dimension of the array DW. -C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; -C LDDW >= 1, if WEIGHT = 'L' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, LDW1, LDW2 ), where -C LDW1 = 0 if WEIGHT = 'R' or 'N' and -C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) -C if WEIGHT = 'L' or WEIGHT = 'B', -C LDW2 = 0 if WEIGHT = 'L' or 'N' and -C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) -C if WEIGHT = 'R' or WEIGHT = 'B', -C a = 0, b = 0, if DICO = 'C' or JOB = 'N', -C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: JOB = 'N' and AV is not completely unstable, or -C JOB = 'C' and AV is not stable; -C = 2: JOB = 'N' and AW is not completely unstable, or -C JOB = 'C' and AW is not stable; -C = 3: both above conditions appear. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of AV to a real Schur form failed; -C = 2: the reduction of AW to a real Schur form failed; -C = 3: the solution of the Sylvester equation failed -C because the matrices A and AV have common -C eigenvalues (if JOB = 'N'), or -AV and A have -C common eigenvalues (if JOB = 'C' and DICO = 'C'), -C or AV has an eigenvalue which is the reciprocal of -C one of the eigenvalues of A (if JOB = 'C' and -C DICO = 'D'); -C = 4: the solution of the Sylvester equation failed -C because the matrices A and AW have common -C eigenvalues (if JOB = 'N'), or -AW and A have -C common eigenvalues (if JOB = 'C' and DICO = 'C'), -C or AW has an eigenvalue which is the reciprocal of -C one of the eigenvalues of A (if JOB = 'C' and -C DICO = 'D'). -C -C METHOD -C -C The matrices of the stable projection of V*G*W are computed as -C -C BS = B*DW + Y*BW, CS = CV*X + DV*C, DS = DV*D*DW, -C -C where X and Y satisfy the continuous-time Sylvester equations -C -C AV*X - X*A + BV*C = 0, -C -A*Y + Y*AW + B*CW = 0. -C -C The matrices of the stable projection of conj(V)*G*conj(W) are -C computed using the explicit formulas established in [1]. -C -C For a continuous-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + Y*CW', CS = BV'*X + DV'*C, DS = DV'*D*DW', -C -C where X and Y satisfy the continuous-time Sylvester equations -C -C AV'*X + X*A + CV'*C = 0, -C A*Y + Y*AW' + B*BW' = 0. -C -C For a discrete-time system, the matrices BS, CS and DS of -C the stable projection are computed as -C -C BS = B*DW' + A*Y*CW', CS = BV'*X*A + DV'*C, -C DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW', -C -C where X and Y satisfy the discrete-time Sylvester equations -C -C AV'*X*A + CV'*C = X, -C A*Y*AW' + B*BW' = Y. -C -C REFERENCES -C -C [1] Varga A. -C Explicit formulas for an efficient implementation -C of the frequency-weighting model reduction approach. -C Proc. 1993 European Control Conference, Groningen, NL, -C pp. 693-696, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on numerically stable algorithms. -C -C FURTHER COMMENTS -C -C The matrix A must be stable, but its stability is not checked by -C this routine. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. -C D. Sima, University of Bucharest, May 2000. -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, -C by A. Varga, 1992. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Frequency weighting, model reduction, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOB, WEIGHT - INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, - $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, - $ NV, NW, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ AV(LDAV,*), BV(LDBV,*), CV(LDCV,*), DV(LDDV,*), - $ AW(LDAW,*), BW(LDBW,*), CW(LDCW,*), DW(LDDW,*), - $ DWORK(*) -C .. Local Scalars - LOGICAL CONJS, DISCR, FRWGHT, LEFTW, RIGHTW - DOUBLE PRECISION SCALE, WORK - INTEGER I, IA, IB, IERR, KW, LDW, LDWN, LW -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DTRSYL, SB04PY, TB01WD, XERBLA -C .. Executable Statements .. -C - CONJS = LSAME( JOB, 'C' ) - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) - RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) - FRWGHT = LEFTW .OR. RIGHTW -C - IWARN = 0 - INFO = 0 - IF ( DISCR .AND. CONJS ) THEN - IA = 2*NV - IB = 2*NW - ELSE - IA = 0 - IB = 0 - END IF - LW = 1 - IF( LEFTW ) - $ LW = MAX( LW, NV*( NV + 5 ), NV*N + MAX( IA, P*N, P*M ) ) - IF( RIGHTW ) - $ LW = MAX( LW, NW*( NW + 5 ), NW*N + MAX( IB, M*N, P*M ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -2 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NV.LT.0 ) THEN - INFO = -5 - ELSE IF( NW.LT.0 ) THEN - INFO = -6 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( P.LT.0 ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN - INFO = -18 - ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN - INFO = -20 - ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN - INFO = -22 - ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN - INFO = -24 - ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN - INFO = -26 - ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN - INFO = -28 - ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN - INFO = -30 - ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN - INFO = -32 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -34 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09KX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( .NOT.FRWGHT .OR. MIN( M, P ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WORK = ONE - IF( LEFTW .AND. NV.GT.0 ) THEN -C -C Reduce AV to a real Schur form using an orthogonal similarity -C transformation AV <- Q'*AV*Q and apply the transformation to -C BV and CV: BV <- Q'*BV and CV <- CV*Q. -C -C Workspace needed: NV*(NV+5); -C prefer larger. -C - KW = NV*( NV + 2 ) + 1 - CALL TB01WD( NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, - $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - IF( CONJS ) THEN -C -C Check the stability of the eigenvalues of AV. -C - IF ( DISCR ) THEN - DO 10 I = 1, NV - IF( DLAPY2( DWORK(I), DWORK(NV+I) ).GE.ONE) THEN - IWARN = 1 - GO TO 50 - END IF - 10 CONTINUE - ELSE - DO 20 I = 1, NV - IF( DWORK(I).GE.ZERO ) THEN - IWARN = 1 - GO TO 50 - END IF - 20 CONTINUE - END IF - ELSE -C -C Check the anti-stability of the eigenvalues of AV. -C - IF ( DISCR ) THEN - DO 30 I = 1, NV - IF( DLAPY2( DWORK(I), DWORK(NV+I) ).LE.ONE) THEN - IWARN = 1 - GO TO 50 - END IF - 30 CONTINUE - ELSE - DO 40 I = 1, NV - IF( DWORK(I).LE.ZERO ) THEN - IWARN = 1 - GO TO 50 - END IF - 40 CONTINUE - END IF - END IF - 50 CONTINUE -C - END IF -C - IF( RIGHTW .AND. NW.GT.0 ) THEN -C -C Reduce AW to a real Schur form using an orthogonal similarity -C transformation AW <- T'*AW*T and apply the transformation to -C BW and CW: BW <- T'*BW and CW <- CW*T. -C -C Workspace needed: NW*(NW+5); -C prefer larger. -C - KW = NW*( NW + 2 ) + 1 - CALL TB01WD( NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, - $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) -C - IF( CONJS ) THEN -C -C Check the stability of the eigenvalues of AW. -C - IF ( DISCR ) THEN - DO 60 I = 1, NW - IF( DLAPY2( DWORK(I), DWORK(NW+I) ).GE.ONE) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 60 CONTINUE - ELSE - DO 70 I = 1, NW - IF( DWORK(I).GE.ZERO ) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 70 CONTINUE - END IF - ELSE -C -C Check the anti-stability of the eigenvalues of AW. -C - IF ( DISCR ) THEN - DO 80 I = 1, NW - IF( DLAPY2( DWORK(I), DWORK(NW+I) ).LE.ONE) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 80 CONTINUE - ELSE - DO 90 I = 1, NW - IF( DWORK(I).LE.ZERO ) THEN - IWARN = IWARN + 2 - GO TO 100 - END IF - 90 CONTINUE - END IF - END IF - 100 CONTINUE - END IF -C - IF( LEFTW ) THEN - LDW = MAX( NV, 1 ) - KW = NV*N + 1 - IF( CONJS ) THEN -C -C Compute the projection of conj(V)*G. -C -C Total workspace needed: NV*N + MAX( a, P*N, P*M ), where -C a = 0, if DICO = 'C', -C a = 2*NV, if DICO = 'D'. -C -C Compute -CV'*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute X and SCALE satisfying -C -C AV'*X*A - X = -SCALE*CV'*C. -C -C Additional workspace needed: 2*NV. -C - CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct C <- DV'*C + BV'*X*A/SCALE, -C D <- DV'*D + BV'*X*B/SCALE. -C -C Additional workspace needed: MAX( P*N, P*M ). -C -C C <- DV'*C. -C - CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) -C -C D <- DV'*D. -C - CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) -C -C C <- C + BV'*X*A/SCALE. -C - CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ZERO, DWORK(KW), P ) - CALL DGEMM( 'N', 'N', P, N, N, ONE, DWORK(KW), P, A, LDA, - $ ONE, C, LDC ) -C -C D <- D + BV'*X*B/SCALE. -C - CALL DGEMM( 'N', 'N', P, M, N, ONE, DWORK(KW), P, B, LDB, - $ ONE, D, LDD ) - ELSE -C -C Compute X and SCALE satisfying -C -C AV'*X + X*A + SCALE*CV'*C = 0. -C - CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct C and D. -C Additional workspace needed: MAX( P*N, P*M ). -C -C Construct C <- BV'*X/SCALE + DV'*C. -C - CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) - CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV'*D. -C - CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - ELSE -C -C Compute the projection of V*G. -C -C Total workspace needed: NV*N + MAX( P*N, P*M ). -C -C Compute -BV*C. -C Workspace needed: NV*N. -C - CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, - $ ZERO, DWORK, LDW ) -C -C Compute X and SCALE satisfying -C -C AV*X - X*A + SCALE*BV*C = 0. -C - CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Construct C <- CV*X/SCALE + DV*C. -C - CALL DGEMM( 'N', 'N', P, N, P, ONE, DV, LDDV, C, LDC, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) - CALL DGEMM( 'N', 'N', P, N, NV, ONE / SCALE, CV, LDCV, - $ DWORK, LDW, ONE, C, LDC ) -C -C Construct D <- DV*D. -C - CALL DGEMM( 'N', 'N', P, M, P, ONE, DV, LDDV, D, LDD, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - END IF -C - IF( RIGHTW ) THEN - LDWN = MAX( N, 1 ) - KW = N*NW + 1 - IF( CONJS ) THEN -C -C Compute the projection of G*conj(W) or of conj(V)*G*conj(W). -C -C Total workspace needed: NW*N + MAX( b, M*N, P*M ), where -C b = 0, if DICO = 'C', -C b = 2*NW, if DICO = 'D'. -C -C Compute -BW*B'. -C Workspace needed: N*NW. -C - LDW = MAX( NW, 1 ) - CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, - $ ZERO, DWORK, LDW ) -C - IF( DISCR ) THEN -C -C Compute Y' and SCALE satisfying -C -C AW*Y'*A' - Y' = -SCALE*BW*B'. -C -C Additional workspace needed: 2*NW. -C - CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, DWORK(KW), IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Construct B <- B*DW' + A*Y*CW'/SCALE, -C D <- D*DW' + C*Y*CW'/SCALE. -C -C Additional workspace needed: MAX( N*M, P*M ). -C -C B <- B*DW'. -C - CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) -C -C B <- B + A*Y*CW'/SCALE. -C - CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ZERO, DWORK(KW), LDWN ) - CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, - $ DWORK(KW), LDWN, ONE, B, LDB ) -C -C D <- D + C*Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'N', P, M, N, ONE, C, LDC, - $ DWORK(KW), LDWN, ONE, D, LDD ) - ELSE -C -C Compute Y' and SCALE satisfying -C -C AW*Y' + Y'*A' + SCALE*BW*B' = 0. -C - CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, - $ DWORK, LDW, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Construct B and D. -C Additional workspace needed: MAX( N*M, P*M ). -C -C Construct B <- B*DW' + Y*CW'/SCALE. -C - CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, - $ CW, LDCW, ONE, B, LDB) -C -C D <- D*DW'. -C - CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - ELSE -C -C Compute the projection of G*W or of V*G*W. -C -C Total workspace needed: NW*N + MAX( M*N, P*M ). -C -C Compute B*CW. -C Workspace needed: N*NW. -C - CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, - $ ZERO, DWORK, LDWN ) -C -C Compute Y and SCALE satisfying -C -C A*Y - Y*AW - SCALE*B*CW = 0. -C - CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, - $ DWORK, LDWN, SCALE, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Construct B and D. -C Additional workspace needed: MAX( N*M, P*M ). -C Construct B <- B*DW + Y*BW/SCALE. -C - CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DW, LDDW, - $ ZERO, DWORK(KW), LDWN ) - CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) - CALL DGEMM( 'N', 'N', N, M, NW, ONE / SCALE, DWORK, LDWN, - $ BW, LDBW, ONE, B, LDB) -C -C D <- D*DW. -C - CALL DGEMM( 'N', 'N', P, M, M, ONE, D, LDD, DW, LDDW, - $ ZERO, DWORK(KW), P ) - CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) - END IF - END IF -C - DWORK(1) = MAX( WORK, DBLE( LW ) ) -C - RETURN -C *** Last line of AB09KX *** - END diff --git a/slycot/src/AB09MD.f b/slycot/src/AB09MD.f deleted file mode 100644 index aaa808bf..00000000 --- a/slycot/src/AB09MD.f +++ /dev/null @@ -1,474 +0,0 @@ - SUBROUTINE AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ A, LDA, B, LDB, C, LDC, NS, HSV, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr) for an original -C state-space representation (A,B,C) by using either the square-root -C or the balancing-free square-root Balance & Truncate (B & T) -C model reduction method for the ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root Balance & Truncate method; -C = 'N': use the balancing-free square-root -C Balance & Truncate method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, and NMIN is the order of a minimal realization -C of the ALPHA-stable part of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable -C part of the given system (computed in HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues in an -C upper real Schur form. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the given system -C (computed in HSV(1)). -C If TOL <= 0 on entry, the used default value is -C TOL = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C This value is appropriate to compute a minimal realization -C of the ALPHA-stable part. -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if JOB = 'B'; -C LIWORK = N, if JOB = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09MD determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) (2) -C -C such that -C -C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root -C Balance & Truncate method of [1] is used, and for an ALPHA-stable -C continuous-time system (DICO = 'C'), the resulting reduced model -C is balanced. For ALPHA-stable systems, setting TOL < 0, the -C routine can be used to compute balanced minimal state-space -C realizations. -C -C If JOB = 'N', the balancing-free square-root version of the -C Balance & Truncate method [2] is used to reduce the ALPHA-stable -C part G1. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), -C Vol. 2, pp. 42-46. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routines SADSDC, SRBT and SRBFT. -C -C REVISIONS -C -C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. -C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Balancing, minimal realization, model reduction, multivariable -C system, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, - $ NS, P - DOUBLE PRECISION ALPHA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD - INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, - $ NN, NRA, NU, NU1, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09AX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -21 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - NN = N*N - KU = 1 - KWR = KU + NN - KWI = KWR + N - KW = KWI + N - LWR = LDWORK - KW + 1 -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LWR, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NN - KW = KTI + NN -C -C Compute a B & T approximation of the stable part. -C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; -C prefer larger. -C - CALL AB09AX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, HSV, DWORK(KT), N, - $ DWORK(KTI), N, TOL, IWORK, DWORK(KW), LDWORK-KW+1, - $ IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - RETURN -C *** Last line of AB09MD *** - END diff --git a/slycot/src/AB09ND.f b/slycot/src/AB09ND.f deleted file mode 100644 index 49ea0c0c..00000000 --- a/slycot/src/AB09ND.f +++ /dev/null @@ -1,497 +0,0 @@ - SUBROUTINE AB09ND( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, - $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, - $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order model (Ar,Br,Cr,Dr) for an original -C state-space representation (A,B,C,D) by using either the -C square-root or the balancing-free square-root Singular -C Perturbation Approximation (SPA) model reduction method for the -C ALPHA-stable part of the system. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOB CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root SPA method; -C = 'N': use the balancing-free square-root SPA method. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NR is fixed; -C = 'A': the resulting order NR is automatically determined -C on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NR (input/output) INTEGER -C On entry with ORDSEL = 'F', NR is the desired order of the -C resulting reduced order system. 0 <= NR <= N. -C On exit, if INFO = 0, NR is the order of the resulting -C reduced order model. For a system with NU ALPHA-unstable -C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), -C NR is set as follows: if ORDSEL = 'F', NR is equal to -C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order -C on entry, and NMIN is the order of a minimal realization -C of the ALPHA-stable part of the given system; NMIN is -C determined as the number of Hankel singular values greater -C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine -C precision (see LAPACK Library Routine DLAMCH) and -C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable -C part of the given system (computed in HSV(1)); -C if ORDSEL = 'A', NR is the sum of NU and the number of -C Hankel singular values greater than -C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading NR-by-NR part of this -C array contains the state dynamics matrix Ar of the reduced -C order system. -C The resulting A has a block-diagonal form with two blocks. -C For a system with NU ALPHA-unstable eigenvalues and -C NS ALPHA-stable eigenvalues (NU+NS = N), the leading -C NU-by-NU block contains the unreduced part of A -C corresponding to ALPHA-unstable eigenvalues in an -C upper real Schur form. -C The trailing (NR+NS-N)-by-(NR+NS-N) block contains -C the reduced part of A corresponding to ALPHA-stable -C eigenvalues. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading NR-by-M part of this -C array contains the input/state matrix Br of the reduced -C order system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-NR part of this -C array contains the state/output matrix Cr of the reduced -C order system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original input/output matrix D. -C On exit, if INFO = 0, the leading P-by-M part of this -C array contains the input/output matrix Dr of the reduced -C order system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of reduced system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the -C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the -C Hankel-norm of the ALPHA-stable part of the given system -C (computed in HSV(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of -C ALPHA-stable eigenvalues of A and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C This value is appropriate to compute a minimal realization -C of the ALPHA-stable part. -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given system. -C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0, then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,2*N) -C On exit, if INFO = 0, IWORK(1) contains the order of the -C minimal realization of the ALPHA-stable part of the -C system. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C system. In this case, the resulting NR is set equal -C to NSMIN. -C = 2: with ORDSEL = 'F', the selected order NR is less -C than the order of the ALPHA-unstable part of the -C given system. In this case NR is set equal to the -C order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system. The subroutine AB09ND determines for -C the given system (1), the matrices of a reduced order system -C -C d[z(t)] = Ar*z(t) + Br*u(t) -C yr(t) = Cr*z(t) + Dr*u(t) (2) -C -C such that -C -C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], -C -C where G and Gr are transfer-function matrices of the systems -C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the -C infinity-norm of G. -C -C The following procedure is used to reduce a given G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. -C -C 2) Determine G1r, a reduced order approximation of the -C ALPHA-stable part G1. -C -C 3) Assemble the reduced model Gr as -C -C Gr = G1r + G2. -C -C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root -C balancing-based SPA method of [1] is used, and for an ALPHA-stable -C system, the resulting reduced model is balanced. -C -C If JOB = 'N', the balancing-free square-root SPA method of [2] -C is used to reduce the ALPHA-stable part G1. -C By setting TOL1 = TOL2, the routine can be used to compute -C Balance & Truncate approximations as well. -C -C REFERENCES -C -C [1] Liu Y. and Anderson B.D.O. -C Singular Perturbation Approximation of Balanced Systems, -C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. -C -C [2] Varga A. -C Balancing-free square-root algorithm for computing -C singular perturbation approximations. -C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, -C Vol. 2, pp. 1062-1065. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routines SADSDC and SRBFSP. -C -C REVISIONS -C -C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. -C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Balancing, minimal realization, model reduction, multivariable -C system, singular perturbation approximation, state-space model, -C state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOB, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, - $ M, N, NR, NS, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR, FIXORD - INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, - $ NN, NRA, NU, NU1, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09BX, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - FIXORD = LSAME( ORDSEL, 'F' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN - INFO = -8 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -21 - ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB09ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NR = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - NN = N*N - KU = 1 - KWR = KU + NN - KWI = KWR + N - KW = KWI + N - LWR = LDWORK - KW + 1 -C -C Reduce A to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LWR, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - IWARNL = 0 - NS = N - NU - IF( FIXORD ) THEN - NRA = MAX( 0, NR-NU ) - IF( NR.LT.NU ) - $ IWARNL = 2 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NS.EQ.0 ) THEN - NR = NU - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C - NU1 = NU + 1 -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NN - KW = KTI + NN -C -C Compute a SPA of the stable part. -C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; -C prefer larger. -C - CALL AB09BX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, - $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, - $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 1 - RETURN - END IF -C - NR = NRA + NU -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - RETURN -C *** Last line of AB09ND *** - END diff --git a/slycot/src/AB13AD.f b/slycot/src/AB13AD.f deleted file mode 100644 index b0889dd6..00000000 --- a/slycot/src/AB13AD.f +++ /dev/null @@ -1,352 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, - $ LDA, B, LDB, C, LDC, NS, HSV, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Hankel-norm of the ALPHA-stable projection of the -C transfer-function matrix G of the state-space system (A,B,C). -C -C FUNCTION VALUE -C -C AB13AD DOUBLE PRECISION -C The Hankel-norm of the ALPHA-stable projection of G -C (if INFO = 0). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix A. For a continuous-time -C system (DICO = 'C'), ALPHA <= 0 is the boundary value for -C the real parts of eigenvalues, while for a discrete-time -C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary -C (see the Note below). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains the state dynamics matrix A in a block -C diagonal real Schur form with its eigenvalues reordered -C and separated. The resulting A has two diagonal blocks. -C The leading NS-by-NS part of A has eigenvalues in the -C ALPHA-stability domain and the trailing (N-NS) x (N-NS) -C part has eigenvalues outside the ALPHA-stability domain. -C Note: The ALPHA-stability domain is defined either -C as the open half complex plane left to ALPHA, -C for a continous-time system (DICO = 'C'), or the -C interior of the ALPHA-radius circle centered in the -C origin, for a discrete-time system (DICO = 'D'). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the input/state matrix B of the transformed -C system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, if INFO = 0, the leading P-by-N part of this -C array contains the state/output matrix C of the -C transformed system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NS (output) INTEGER -C The dimension of the ALPHA-stable subsystem. -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, the leading NS elements of HSV contain the -C Hankel singular values of the ALPHA-stable part of the -C original system ordered decreasingly. -C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the computation of the ordered real Schur form of A -C failed; -C = 2: the separation of the ALPHA-stable/unstable diagonal -C blocks failed because of very close eigenvalues; -C = 3: the computed ALPHA-stable part is just stable, -C having stable eigenvalues very near to the imaginary -C axis (if DICO = 'C') or to the unit circle -C (if DICO = 'D'); -C = 4: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the following linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The following procedure is used to -C compute the Hankel-norm of the ALPHA-stable projection of G: -C -C 1) Decompose additively G as -C -C G = G1 + G2 -C -C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and -C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. -C For the computation of the additive decomposition, the -C algorithm presented in [1] is used. -C -C 2) Compute the Hankel-norm of ALPHA-stable projection G1 as the -C the maximum Hankel singular value of the system (As,Bs,Cs). -C The computation of the Hankel singular values is performed -C by using the square-root method of [2]. -C -C REFERENCES -C -C [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J. -C Synthesis of positive real multivariable feedback systems, -C Int. J. Control, Vol. 45, pp. 817-842, 1987. -C -C [2] Tombs, M.S. and Postlethwaite, I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on a square-root technique. -C 3 -C The algorithms require about 17N floating point operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SHANRM. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C Jun. 2017, RvP, made 1st error return value zero -C -C KEYWORDS -C -C Additive spectral decomposition, model reduction, -C multivariable system, state-space model, system norms. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER IERR, KT, KW, KW1, KW2 - DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION AB13AX, DLAMCH - EXTERNAL AB13AX, DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -16 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C -C - AB13AD = ZERO - CALL XERBLA( 'AB13AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NS = 0 - AB13AD = ZERO - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a -C diagonal matrix. -C Workspace: N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Allocate working storage. -C - KT = 1 - KW1 = N*N + 1 - KW2 = KW1 + N - KW = KW2 + N -C -C Reduce A to a block diagonal real Schur form, with the -C ALPHA-stable part in the leading diagonal position, using a -C non-orthogonal similarity transformation A <- inv(T)*A*T and -C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA, - $ B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1), - $ DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 1 - ELSE - INFO = 2 - END IF - RETURN - END IF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C - IF( NS.EQ.0 ) THEN - AB13AD = ZERO - ELSE -C -C Workspace: need N*(MAX(N,M,P)+5)+N*(N+1)/2; -C prefer larger. -C - AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV, - $ DWORK, LDWORK, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = IERR + 2 - RETURN - END IF -C - DWORK(1) = MAX( WRKOPT, DWORK(1) ) - END IF -C - RETURN -C *** Last line of AB13AD *** - END diff --git a/slycot/src/AB13AX.f b/slycot/src/AB13AX.f deleted file mode 100644 index ace56a1f..00000000 --- a/slycot/src/AB13AX.f +++ /dev/null @@ -1,309 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB, - $ C, LDC, HSV, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Hankel-norm of the transfer-function matrix G of -C a stable state-space system (A,B,C). The state dynamics matrix A -C of the given system is an upper quasi-triangular matrix in -C real Schur form. -C -C FUNCTION VALUE -C -C AB13AX DOUBLE PRECISION -C The Hankel-norm of G (if INFO = 0). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A in a real Schur canonical form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, this array contains the Hankel singular -C values of the given system ordered decreasingly. -C HSV(1) is the Hankel norm of the given system. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the state matrix A is not stable (if DICO = 'C') -C or not convergent (if DICO = 'D'); -C = 2: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the stable linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let G be the corresponding -C transfer-function matrix. The Hankel-norm of G is computed as the -C the maximum Hankel singular value of the system (A,B,C). -C The computation of the Hankel singular values is performed -C by using the square-root method of [1]. -C -C REFERENCES -C -C [1] Tombs M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C NUMERICAL ASPECTS -C -C The implemented method relies on a square-root technique. -C 3 -C The algorithms require about 17N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SHANRM. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Multivariable system, state-space model, system norms. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER I, IERR, J, KR, KS, KTAU, KU, KW, MNMP - DOUBLE PRECISION SCALEC, SCALEO, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + - $ ( N*( N + 1 ) )/2 ) ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - AB13AX = ZERO - CALL XERBLA( 'AB13AX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - AB13AX = ZERO - DWORK(1) = ONE - RETURN - END IF -C -C Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the -C matrices S, TAU, and R, respectively. S shares the storage with U. -C - KU = 1 - KS = 1 - MNMP = MAX( N, M, P ) - KTAU = KS + N*MNMP - KR = KTAU + N - KW = KR -C -C Copy C in U. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP ) -C -C If DISCR = .FALSE., solve for R the Lyapunov equation -C 2 -C A'*(R'*R) + (R'*R)*A + scaleo * C'*C = 0 . -C -C If DISCR = .TRUE., solve for R the Lyapunov equation -C 2 -C A'*(R'*R)*A + scaleo * C'*C = R'*R . -C -C Workspace needed: N*(MAX(N,M,P)+1); -C Additional workspace: need 4*N; -C prefer larger. -C - CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP, - $ DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - ENDIF -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Pack the upper triangle of R in DWORK(KR). -C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2. -C - CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) ) -C - KW = KR + ( N*( N + 1 ) )/2 -C -C Copy B in S (over U). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N ) -C -C If DISCR = .FALSE., solve for S the Lyapunov equation -C 2 -C A*(S*S') + (S*S')*A' + scalec *B*B' = 0 . -C -C If DISCR = .TRUE., solve for S the Lyapunov equation -C 2 -C A*(S*S')*A' + scalec *B*B' = S*S' . -C -C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2; -C Additional workspace: need 4*N; -C prefer larger. -C - CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N, - $ DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW), - $ LDWORK-KW+1, IERR ) -C - WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C -C | x x | -C Compute R*S in the form | 0 x | in S. Note that R is packed. -C - J = KS - DO 10 I = 1, N - CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR), - $ DWORK(J), 1 ) - J = J + N - 10 CONTINUE -C -C Compute the singular values of the upper triangular matrix R*S. -C -C Workspace needed: N*MAX(N,M,P); -C Additional workspace: need MAX(1,5*N); -C prefer larger. -C - KW = KTAU - CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1, - $ HSV, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - ENDIF -C -C Scale singular values. -C - CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) - AB13AX = HSV(1) -C - DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) -C - RETURN -C *** Last line of AB13AX *** - END diff --git a/slycot/src/AB13BD.f b/slycot/src/AB13BD.f deleted file mode 100644 index 72a3b69b..00000000 --- a/slycot/src/AB13BD.f +++ /dev/null @@ -1,392 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA, - $ B, LDB, C, LDC, D, LDD, NQ, TOL, - $ DWORK, LDWORK, IWARN, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the H2 or L2 norm of the transfer-function matrix G -C of the system (A,B,C,D). G must not have poles on the imaginary -C axis, for a continuous-time system, or on the unit circle, for -C a discrete-time system. If the H2-norm is computed, the system -C must be stable. -C -C FUNCTION VALUE -C -C AB13BD DOUBLE PRECISION -C The H2-norm of G, if JOBN = 'H', or the L2-norm of G, -C if JOBN = 'L' (if INFO = 0). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBN CHARACTER*1 -C Specifies the norm to be computed as follows: -C = 'H': the H2-norm; -C = 'L': the L2-norm. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of the -C matrix B, and the number of columns of the matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B and D. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices C and D. -C P represents the dimension of output vector. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix of the system. -C On exit, the leading NQ-by-NQ part of this array contains -C the state dynamics matrix (in a real Schur form) of the -C numerator factor Q of the right coprime factorization with -C inner denominator of G (see METHOD). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix of the system. -C On exit, the leading NQ-by-M part of this array contains -C the input/state matrix of the numerator factor Q of the -C right coprime factorization with inner denominator of G -C (see METHOD). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix of the system. -C On exit, the leading P-by-NQ part of this array contains -C the state/output matrix of the numerator factor Q of the -C right coprime factorization with inner denominator of G -C (see METHOD). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix of the system. -C If DICO = 'C', D must be a null matrix. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix of the numerator factor Q of -C the right coprime factorization with inner denominator -C of G (see METHOD). -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the resulting numerator Q of the right -C coprime factorization with inner denominator of G (see -C METHOD). -C Generally, NQ = N - NS, where NS is the number of -C uncontrollable unstable eigenvalues. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(B), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(B) denotes -C the 1-norm of B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ), -C N*( MAX( N, P ) + 4 ) + MIN( N, P ) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C occured during the assignment of eigenvalues in -C computing the right coprime factorization with inner -C denominator of G (see the SLICOT subroutine SB08DD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the reordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal (see SLICOT routine SB08DD); -C = 3: if DICO = 'C' and the matrix A has a controllable -C eigenvalue on the imaginary axis, or DICO = 'D' -C and A has a controllable eigenvalue on the unit -C circle; -C = 4: the solution of Lyapunov equation failed because -C the equation is singular; -C = 5: if DICO = 'C' and D is a nonzero matrix; -C = 6: if JOBN = 'H' and the system is unstable. -C -C METHOD -C -C The subroutine is based on the algorithms proposed in [1] and [2]. -C -C If the given transfer-function matrix G is unstable, then a right -C coprime factorization with inner denominator of G is first -C computed -C -1 -C G = Q*R , -C -C where Q and R are stable transfer-function matrices and R is -C inner. If G is stable, then Q = G and R = I. -C Let (AQ,BQ,CQ,DQ) be the state-space representation of Q. -C -C If DICO = 'C', then the L2-norm of G is computed as -C -C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)), -C -C where X satisfies the continuous-time Lyapunov equation -C -C AQ'*X + X*AQ + CQ'*CQ = 0. -C -C If DICO = 'D', then the l2-norm of G is computed as -C -C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)), -C -C where X satisfies the discrete-time Lyapunov equation -C -C AQ'*X*AQ - X + CQ'*CQ = 0. -C -C REFERENCES -C -C [1] Varga A. -C On computing 2-norms of transfer-function matrices. -C Proc. 1992 ACC, Chicago, June 1992. -C -C [2] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SL2NRM. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C Jan. 2003, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Coprime factorization, Lyapunov equation, multivariable system, -C state-space model, system norms. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBN - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, - $ N, NQ, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER KCR, KDR, KRW, KTAU, KU, MXNP, NR - DOUBLE PRECISION S2NORM, SCALE, WRKOPT -C .. External functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANGE, DLAPY2 - EXTERNAL DLANGE, DLAPY2, LSAME -C .. External subroutines .. - EXTERNAL DLACPY, DTRMM, SB03OU, SB08DD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - INFO = 0 - IWARN = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( JOBN, 'H' ) .OR. LSAME( JOBN, 'L' ) ) ) - $ THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDWORK.LT.MAX( 1, M*( N + M ) + - $ MAX( N*( N + 5 ), M*( M + 2 ), 4*P ), - $ N*( MAX( N, P ) + 4 ) + MIN( N, P ) ) ) - $ THEN - INFO = -17 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - AB13BD = ZERO - CALL XERBLA( 'AB13BD', -INFO ) - RETURN - END IF -C -C Compute the Frobenius norm of D. -C - S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) - IF( .NOT.DISCR .AND. S2NORM.NE.ZERO ) THEN - AB13BD = ZERO - INFO = 5 - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - NQ = 0 - AB13BD = ZERO - DWORK(1) = ONE - RETURN - END IF -C - KCR = 1 - KDR = KCR + M*N - KRW = KDR + M*M -C -C Compute the right coprime factorization with inner denominator -C of G. -C -C Workspace needed: M*(N+M); -C Additional workspace: need MAX( N*(N+5), M*(M+2), 4*M, 4*P ); -C prefer larger. -C - CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, NQ, - $ NR, DWORK(KCR), M, DWORK(KDR), M, TOL, DWORK(KRW), - $ LDWORK-KRW+1, IWARN, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = DWORK(KRW) + DBLE( KRW-1 ) -C -C Check stability. -C - IF( LSAME( JOBN, 'H' ) .AND. NR.GT.0 ) THEN - INFO = 6 - RETURN - END IF -C - IF( NQ.GT.0 ) THEN - KU = 1 - MXNP = MAX( NQ, P ) - KTAU = NQ*MXNP + 1 - KRW = KTAU + MIN( NQ, P ) -C -C Find X, the solution of Lyapunov equation. -C -C Workspace needed: N*MAX(N,P) + MIN(N,P); -C Additional workspace: 4*N; -C prefer larger. -C - CALL DLACPY( 'Full', P, NQ, C, LDC, DWORK(KU), MXNP ) - CALL SB03OU( DISCR, .FALSE., NQ, P, A, LDA, DWORK(KU), MXNP, - $ DWORK(KTAU), DWORK(KU), NQ, SCALE, DWORK(KRW), - $ LDWORK-KRW+1, INFO ) - IF( INFO.NE.0 ) THEN - IF( INFO.EQ.1 ) THEN - INFO = 4 - ELSE IF( INFO.EQ.2 ) THEN - INFO = 3 - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(KRW) + DBLE( KRW-1 ) ) -C -C Add the contribution of BQ'*X*BQ. -C -C Workspace needed: N*(N+M). -C - KTAU = NQ*NQ + 1 - CALL DLACPY( 'Full', NQ, M, B, LDB, DWORK(KTAU), NQ ) - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', NQ, M, - $ ONE, DWORK(KU), NQ, DWORK(KTAU), NQ ) - IF( NR.GT.0 ) - $ S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) - S2NORM = DLAPY2( S2NORM, DLANGE( 'Frobenius', NQ, M, - $ DWORK(KTAU), NQ, DWORK ) - $ / SCALE ) - END IF -C - AB13BD = S2NORM -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of AB13BD *** - END diff --git a/slycot/src/AB13CD.f b/slycot/src/AB13CD.f deleted file mode 100644 index fc9430f1..00000000 --- a/slycot/src/AB13CD.f +++ /dev/null @@ -1,606 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C, - $ LDC, D, LDD, TOL, IWORK, DWORK, - $ LDWORK, CWORK, LCWORK, BWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the H-infinity norm of the continuous-time stable -C system -C -C | A | B | -C G(s) = |---|---| . -C | C | D | -C -C FUNCTION VALUE -C -C AB13CD DOUBLE PRECISION -C If INFO = 0, the H-infinity norm of the system, HNORM, -C i.e., the peak gain of the frequency response (as measured -C by the largest singular value in the MIMO case). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used to set the accuracy in determining the -C norm. -C -C Workspace -C -C IWORK INTEGER array, dimension N -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK, and DWORK(2) contains the frequency where the -C gain of the frequency response achieves its peak value -C HNORM. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(2,4*N*N+2*M*M+3*M*N+M*NP+2*(N+NP)*NP+10*N+ -C 6*max(M,NP)). -C For good performance, LDWORK must generally be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) contains the optimal value -C of LCWORK. -C -C LCWORK INTEGER -C The dimension of the array CWORK. -C LCWORK >= max(1,(N+M)*(N+NP)+3*max(M,NP)). -C For good performance, LCWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the system is unstable; -C = 2: the tolerance is too small (the algorithm for -C computing the H-infinity norm did not converge); -C = 3: errors in computing the eigenvalues of A or of the -C Hamiltonian matrix (the QR algorithm did not -C converge); -C = 4: errors in computing singular values. -C -C METHOD -C -C The routine implements the method presented in [1]. -C -C REFERENCES -C -C [1] Bruinsma, N.A. and Steinbuch, M. -C A fast algorithm to compute the Hinfinity-norm of a transfer -C function matrix. -C Systems & Control Letters, vol. 14, pp. 287-293, 1990. -C -C NUMERICAL ASPECTS -C -C If the algorithm does not converge (INFO = 2), the tolerance must -C be increased. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999, -C Oct. 2000. -C P.Hr. Petkov, October 2000. -C A. Varga, October 2000. -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, system norm. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 10 ) - COMPLEX*16 CONE, JIMAG - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), - $ JIMAG = ( 0.0D0, 1.0D0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) - DOUBLE PRECISION HUGE - PARAMETER ( HUGE = 10.0D+0**30 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LCWORK, LDD, LDWORK, M, N, - $ NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - COMPLEX*16 CWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER I, ICW2, ICW3, ICW4, ICWRK, INFO2, ITER, IW10, - $ IW11, IW12, IW2, IW3, IW4, IW5, IW6, IW7, IW8, - $ IW9, IWRK, J, K, L, LCWAMX, LWAMAX, MINCWR, - $ MINWRK, SDIM - DOUBLE PRECISION DEN, FPEAK, GAMMA, GAMMAL, GAMMAU, OMEGA, RAT, - $ RATMAX, TEMP, WIMAX, WRMIN - LOGICAL COMPLX -C -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - LOGICAL SB02MV, SB02CX - EXTERNAL DLAPY2, SB02MV, SB02CX -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DGEMM, DGESV, DGESVD, DLACPY, DPOSV, - $ DPOTRF, DPOTRS, DSYRK, MA02ED, MB01RX, XERBLA, - $ ZGEMM, ZGESV, ZGESVD -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - END IF -C -C Compute workspace. -C - MINWRK = MAX( 2, 4*N*N + 2*M*M + 3*M*N + M*NP + 2*( N + NP )*NP + - $ 10*N + 6*MAX( M, NP ) ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -15 - END IF - MINCWR = MAX( 1, ( N + M )*( N + NP ) + 3*MAX( M, NP ) ) - IF( LCWORK.LT.MINCWR ) THEN - INFO = -17 - END IF - IF( INFO.NE.0 ) THEN - AB13CD = ZERO - CALL XERBLA( 'AB13CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. NP.EQ.0 ) THEN - AB13CD = ZERO - RETURN - END IF -C -C Workspace usage. -C - IW2 = N - IW3 = IW2 + N - IW4 = IW3 + N*N - IW5 = IW4 + N*M - IW6 = IW5 + NP*M - IWRK = IW6 + MIN( NP, M ) -C -C Determine the maximum singular value of G(infinity) = D . -C - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) - CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), - $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - AB13CD = ZERO - RETURN - END IF - GAMMAL = DWORK( IW6+1 ) - FPEAK = HUGE - LWAMAX = INT( DWORK( IWRK+1 ) ) + IWRK -C -C Quick return if N = 0 . -C - IF( N.EQ.0 ) THEN - AB13CD = GAMMAL - DWORK(1) = TWO - DWORK(2) = ZERO - CWORK(1) = ONE - RETURN - END IF -C -C Stability check. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) - CALL DGEES( 'N', 'S', SB02MV, N, DWORK( IW3+1 ), N, SDIM, DWORK, - $ DWORK( IW2+1 ), DWORK, N, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF - IF( SDIM.LT.N ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) -C -C Determine the maximum singular value of G(0) = -C*inv(A)*B + D . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IW4+1 ), N ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) - CALL DGESV( N, M, DWORK( IW3+1 ), N, IWORK, DWORK( IW4+1 ), N, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGEMM( 'N', 'N', NP, M, N, -ONE, C, LDC, DWORK( IW4+1 ), N, - $ ONE, DWORK( IW5+1 ), NP ) - CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), - $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN - GAMMAL = DWORK( IW6+1 ) - FPEAK = ZERO - END IF - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) -C -C Find a frequency which is close to the peak frequency. -C - COMPLX = .FALSE. - DO 10 I = 1, N - IF( DWORK( IW2+I ).NE.ZERO ) COMPLX = .TRUE. - 10 CONTINUE - IF( .NOT.COMPLX ) THEN - WRMIN = ABS( DWORK( 1 ) ) - DO 20 I = 2, N - IF( WRMIN.GT.ABS( DWORK( I ) ) ) WRMIN = ABS( DWORK( I ) ) - 20 CONTINUE - OMEGA = WRMIN - ELSE - RATMAX = ZERO - DO 30 I = 1, N - DEN = DLAPY2( DWORK( I ), DWORK( IW2+I ) ) - RAT = ABS( ( DWORK( IW2+I )/DWORK( I ) )/DEN ) - IF( RATMAX.LT.RAT ) THEN - RATMAX = RAT - WIMAX = DEN - END IF - 30 CONTINUE - OMEGA = WIMAX - END IF -C -C Workspace usage. -C - ICW2 = N*N - ICW3 = ICW2 + N*M - ICW4 = ICW3 + NP*N - ICWRK = ICW4 + NP*M -C -C Determine the maximum singular value of -C G(omega) = C*inv(j*omega*In - A)*B + D . -C - DO 50 J = 1, N - DO 40 I = 1, N - CWORK( I+(J-1)*N ) = -A( I, J ) - 40 CONTINUE - CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) - 50 CONTINUE - DO 70 J = 1, M - DO 60 I = 1, N - CWORK( ICW2+I+(J-1)*N ) = B( I, J ) - 60 CONTINUE - 70 CONTINUE - DO 90 J = 1, N - DO 80 I = 1, NP - CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) - 80 CONTINUE - 90 CONTINUE - DO 110 J = 1, M - DO 100 I = 1, NP - CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) - 100 CONTINUE - 110 CONTINUE - CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, - $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) - CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, DWORK( IW6+1 ), - $ CWORK, NP, CWORK, M, CWORK( ICWRK+1 ), LCWORK-ICWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN - GAMMAL = DWORK( IW6+1 ) - FPEAK = OMEGA - END IF - LCWAMX = INT( CWORK( ICWRK+1 ) ) + ICWRK -C -C Workspace usage. -C - IW2 = M*N - IW3 = IW2 + M*M - IW4 = IW3 + NP*NP - IW5 = IW4 + M*M - IW6 = IW5 + M*N - IW7 = IW6 + M*N - IW8 = IW7 + NP*NP - IW9 = IW8 + NP*N - IW10 = IW9 + 4*N*N - IW11 = IW10 + 2*N - IW12 = IW11 + 2*N - IWRK = IW12 + MIN( NP, M ) -C -C Compute D'*C . -C - CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, - $ DWORK, M ) -C -C Compute D'*D . -C - CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ZERO, DWORK( IW2+1 ), - $ M ) -C -C Compute D*D' . -C - CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ZERO, DWORK( IW3+1 ), - $ NP ) -C -C Main iteration loop for gamma. -C - ITER = 0 - 120 ITER = ITER + 1 - IF( ITER.GT.MAXIT ) THEN - INFO = 2 - RETURN - END IF - GAMMA = ( ONE + TWO*TOL )*GAMMAL -C -C Compute R = GAMMA^2*Im - D'*D . -C - DO 140 J = 1, M - DO 130 I = 1, J - DWORK( IW4+I+(J-1)*M ) = -DWORK( IW2+I+(J-1)*M ) - 130 CONTINUE - DWORK( IW4+J+(J-1)*M ) = GAMMA**2 - DWORK( IW2+J+(J-1)*M ) - 140 CONTINUE -C -C Compute inv(R)*D'*C . -C - CALL DLACPY( 'Full', M, N, DWORK, M, DWORK( IW5+1 ), M ) - CALL DPOTRF( 'U', M, DWORK( IW4+1 ), M, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW5+1 ), M, - $ INFO2 ) -C -C Compute inv(R)*B' . -C - DO 160 J = 1, N - DO 150 I = 1, M - DWORK( IW6+I+(J-1)*M ) = B( J, I ) - 150 CONTINUE - 160 CONTINUE - CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW6+1 ), M, - $ INFO2 ) -C -C Compute S = GAMMA^2*Ip - D*D' . -C - DO 180 J = 1, NP - DO 170 I = 1, J - DWORK( IW7+I+(J-1)*NP ) = -DWORK( IW3+I+(J-1)*NP ) - 170 CONTINUE - DWORK( IW7+J+(J-1)*NP ) = GAMMA**2 - DWORK( IW3+J+(J-1)*NP ) - 180 CONTINUE -C -C Compute inv(S)*C . -C - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IW8+1 ), NP ) - CALL DPOSV( 'U', NP, N, DWORK( IW7+1 ), NP, DWORK( IW8+1 ), NP, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Construct the Hamiltonian matrix . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW9+1 ), 2*N ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( IW5+1 ), M, - $ ONE, DWORK( IW9+1 ), 2*N ) - CALL MB01RX( 'Left', 'Upper', 'Transpose', N, NP, ZERO, -GAMMA, - $ DWORK( IW9+N+1 ), 2*N, C, LDC, DWORK( IW8+1 ), NP, - $ INFO2 ) - CALL MA02ED( 'Upper', N, DWORK( IW9+N+1 ), 2*N ) - CALL MB01RX( 'Left', 'Upper', 'NoTranspose', N, M, ZERO, GAMMA, - $ DWORK( IW9+2*N*N+1 ), 2*N, B, LDB, DWORK( IW6+1 ), M, - $ INFO2 ) - CALL MA02ED( 'Upper', N, DWORK( IW9+2*N*N+1 ), 2*N ) - DO 200 J = 1, N - DO 190 I = 1, N - DWORK( IW9+2*N*N+N+I+(J-1)*2*N ) = -DWORK( IW9+J+(I-1)*2*N ) - 190 CONTINUE - 200 CONTINUE -C -C Compute the eigenvalues of the Hamiltonian matrix. -C - CALL DGEES( 'N', 'S', SB02CX, 2*N, DWORK( IW9+1 ), 2*N, SDIM, - $ DWORK( IW10+1 ), DWORK( IW11+1 ), DWORK, 2*N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) -C - IF( SDIM.EQ.0 ) THEN - GAMMAU = GAMMA - GO TO 330 - END IF -C -C Store the positive imaginary parts. -C - J = 0 - DO 210 I = 1, SDIM-1, 2 - J = J + 1 - DWORK( IW10+J ) = DWORK( IW11+I ) - 210 CONTINUE - K = J -C - IF( K.GE.2 ) THEN -C -C Reorder the imaginary parts. -C - DO 230 J = 1, K-1 - DO 220 L = J+1, K - IF( DWORK( IW10+J ).LE. DWORK( IW10+L ) ) GO TO 220 - TEMP = DWORK( IW10+J ) - DWORK( IW10+J ) = DWORK( IW10+L ) - DWORK( IW10+L ) = TEMP - 220 CONTINUE - 230 CONTINUE -C -C Determine the next frequency. -C - DO 320 L = 1, K - 1 - OMEGA = ( DWORK( IW10+L ) + DWORK( IW10+L+1 ) )/TWO - DO 250 J = 1, N - DO 240 I = 1, N - CWORK( I+(J-1)*N ) = -A( I, J ) - 240 CONTINUE - CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) - 250 CONTINUE - DO 270 J = 1, M - DO 260 I = 1, N - CWORK( ICW2+I+(J-1)*N ) = B( I, J ) - 260 CONTINUE - 270 CONTINUE - DO 290 J = 1, N - DO 280 I = 1, NP - CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) - 280 CONTINUE - 290 CONTINUE - DO 310 J = 1, M - DO 300 I = 1, NP - CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) - 300 CONTINUE - 310 CONTINUE - CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, - $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) - CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, - $ DWORK( IW6+1 ), CWORK, NP, CWORK, M, - $ CWORK( ICWRK+1 ), LCWORK-ICWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN - GAMMAL = DWORK( IW6+1 ) - FPEAK = OMEGA - END IF - LCWAMX = MAX( INT( CWORK( ICWRK+1 ) ) + ICWRK, LCWAMX ) - 320 CONTINUE - END IF - GO TO 120 - 330 AB13CD = ( GAMMAL + GAMMAU )/TWO -C - DWORK( 1 ) = LWAMAX - DWORK( 2 ) = FPEAK - CWORK( 1 ) = LCWAMX - RETURN -C *** End of AB13CD *** - END diff --git a/slycot/src/AB13DD.f b/slycot/src/AB13DD.f deleted file mode 100644 index e9df19f4..00000000 --- a/slycot/src/AB13DD.f +++ /dev/null @@ -1,1870 +0,0 @@ - SUBROUTINE AB13DD( DICO, JOBE, EQUIL, JOBD, N, M, P, FPEAK, - $ A, LDA, E, LDE, B, LDB, C, LDC, D, LDD, GPEAK, - $ TOL, IWORK, DWORK, LDWORK, CWORK, LCWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the L-infinity norm of a continuous-time or -C discrete-time system, either standard or in the descriptor form, -C -C -1 -C G(lambda) = C*( lambda*E - A ) *B + D . -C -C The norm is finite if and only if the matrix pair (A,E) has no -C eigenvalue on the boundary of the stability domain, i.e., the -C imaginary axis, or the unit circle, respectively. It is assumed -C that the matrix E is nonsingular. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system, as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBE CHARACTER*1 -C Specifies whether E is a general square or an identity -C matrix, as follows: -C = 'G': E is a general square matrix; -C = 'I': E is the identity matrix. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the system (A,E,B,C) or (A,B,C), as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C P (input) INTEGER -C The row size of the matrix C. P >= 0. -C -C FPEAK (input/output) DOUBLE PRECISION array, dimension (2) -C On entry, this parameter must contain an estimate of the -C frequency where the gain of the frequency response would -C achieve its peak value. Setting FPEAK(2) = 0 indicates an -C infinite frequency. An accurate estimate could reduce the -C number of iterations of the iterative algorithm. If no -C estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1. -C FPEAK(1) >= 0, FPEAK(2) >= 0. -C On exit, if INFO = 0, this array contains the frequency -C OMEGA, where the gain of the frequency response achieves -C its peak value GPEAK, i.e., -C -C || G ( j*OMEGA ) || = GPEAK , if DICO = 'C', or -C -C j*OMEGA -C || G ( e ) || = GPEAK , if DICO = 'D', -C -C where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is -C infinite, if FPEAK(2) = 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'G', the leading N-by-N part of this array must -C contain the descriptor matrix E of the system. -C If JOBE = 'I', then E is assumed to be the identity -C matrix and is not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. -C LDE >= MAX(1,N), if JOBE = 'G'; -C LDE >= 1, if JOBE = 'I'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this array must -C contain the direct transmission matrix D. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C GPEAK (output) DOUBLE PRECISION array, dimension (2) -C The L-infinity norm of the system, i.e., the peak gain -C of the frequency response (as measured by the largest -C singular value in the MIMO case), coded in the same way -C as FPEAK. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used to set the accuracy in determining the -C norm. 0 <= TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= K, where K can be computed using the following -C pseudo-code (or the Fortran code included in the routine) -C -C d = 6*MIN(P,M); -C c = MAX( 4*MIN(P,M) + MAX(P,M), d ); -C if ( MIN(P,M) = 0 ) then -C K = 1; -C else if( N = 0 or B = 0 or C = 0 ) then -C if( JOBD = 'D' ) then -C K = P*M + c; -C else -C K = 1; -C end -C else -C if ( DICO = 'D' ) then -C b = 0; e = d; -C else -C b = N*(N+M); e = c; -C if ( JOBD = Z' ) then b = b + P*M; end -C end -C if ( JOBD = 'D' ) then -C r = P*M; -C if ( JOBE = 'I', DICO = 'C', -C N > 0, B <> 0, C <> 0 ) then -C K = P*P + M*M; -C r = r + N*(P+M); -C else -C K = 0; -C end -C K = K + r + c; r = r + MIN(P,M); -C else -C r = 0; K = 0; -C end -C r = r + N*(N+P+M); -C if ( JOBE = 'G' ) then -C r = r + N*N; -C if ( EQUIL = 'S' ) then -C K = MAX( K, r + 9*N ); -C end -C K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) ); -C else -C K = MAX( K, r + N + -C MAX( M, P, N*N+2*N, 3*N+b+e ) ); -C end -C w = 0; -C if ( JOBE = 'I', DICO = 'C' ) then -C w = r + 4*N*N + 11*N; -C if ( JOBD = 'D' ) then -C w = w + MAX(M,P) + N*(P+M); -C end -C end -C if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then -C w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) + -C MAX( 2*(N+P+M), 8*N*N + 16*N ) ); -C end -C K = MAX( 1, K, w, r + 2*N + e ); -C end -C -C For good performance, LDWORK must generally be larger. -C -C An easily computable upper bound is -C -C K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M + -C N*M + 22*N + 7*MIN(P,M) ). -C -C The smallest workspace is obtained for DICO = 'C', -C JOBE = 'I', and JOBD = 'Z', namely -C -C K = MAX( 1, N*N + N*P + N*M + N + -C MAX( N*N + N*M + P*M + 3*N + c, -C 4*N*N + 10*N ) ). -C -C for which an upper bound is -C -C K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) + -C 6*MIN(P,M) ). -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) contains the optimal -C LCWORK. -C -C LCWORK INTEGER -C The dimension of the array CWORK. -C LCWORK >= 1, if N = 0, or B = 0, or C = 0; -C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), -C otherwise. -C For good performance, LCWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix E is (numerically) singular; -C = 2: the (periodic) QR (or QZ) algorithm for computing -C eigenvalues did not converge; -C = 3: the SVD algorithm for computing singular values did -C not converge; -C = 4: the tolerance is too small and the algorithm did -C not converge. -C -C METHOD -C -C The routine implements the method presented in [1], with -C extensions and refinements for improving numerical robustness and -C efficiency. Structure-exploiting eigenvalue computations for -C Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the -C symmetric matrices to be implicitly inverted are not too ill- -C conditioned. Otherwise, generalized eigenvalue computations are -C used in the iterative algorithm of [1]. -C -C REFERENCES -C -C [1] Bruinsma, N.A. and Steinbuch, M. -C A fast algorithm to compute the Hinfinity-norm of a transfer -C function matrix. -C Systems & Control Letters, vol. 14, pp. 287-293, 1990. -C -C NUMERICAL ASPECTS -C -C If the algorithm does not converge in MAXIT = 30 iterations -C (INFO = 4), the tolerance must be increased. -C -C FURTHER COMMENTS -C -C If the matrix E is singular, other SLICOT Library routines -C could be used before calling AB13DD, for removing the singular -C part of the system. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C Partly based on SLICOT Library routine AB13CD by P.Hr. Petkov, -C D.W. Gu and M.M. Konstantinov. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C May 2003, Aug. 2005, March 2008, May 2009, Sep. 2009. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, system norm. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 30 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, P25 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, P25 = 0.25D+0 ) - DOUBLE PRECISION TEN, HUNDRD, THOUSD - PARAMETER ( TEN = 1.0D+1, HUNDRD = 1.0D+2, - $ THOUSD = 1.0D+3 ) -C .. -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBD, JOBE - INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, - $ M, N, P - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - COMPLEX*16 CWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), E( LDE, * ), - $ FPEAK( 2 ), GPEAK( 2 ) - INTEGER IWORK( * ) -C .. -C .. Local Scalars .. - CHARACTER VECT - LOGICAL DISCR, FULLE, ILASCL, ILESCL, LEQUIL, NODYN, - $ USEPEN, WITHD - INTEGER I, IA, IAR, IAS, IB, IBS, IBT, IBV, IC, ICU, - $ ID, IE, IERR, IES, IH, IH12, IHI, II, ILO, IM, - $ IMIN, IPA, IPE, IR, IS, ISB, ISC, ISL, ITAU, - $ ITER, IU, IV, IWRK, J, K, LW, MAXCWK, MAXWRK, - $ MINCWR, MINPM, MINWRK, N2, N2PM, NEI, NN, NWS, - $ NY, PM - DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNORM, BOUND, CNORM, - $ ENRM, ENRMTO, EPS, FPEAKI, FPEAKS, GAMMA, - $ GAMMAL, GAMMAS, MAXRED, OMEGA, PI, RAT, RCOND, - $ RTOL, SAFMAX, SAFMIN, SMLNUM, TM, TOLER, WMAX, - $ WRMIN -C .. -C .. Local Arrays .. - DOUBLE PRECISION TEMP( 1 ) -C .. -C .. External Functions .. - DOUBLE PRECISION AB13DX, DLAMCH, DLANGE, DLAPY2 - LOGICAL LSAME - EXTERNAL AB13DX, DLAMCH, DLANGE, DLAPY2, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEHRD, DGEMM, DGEQRF, DGESVD, - $ DGGBAL, DGGEV, DHGEQZ, DHSEQR, DLABAD, DLACPY, - $ DLASCL, DLASRT, DORGQR, DORMHR, DSWAP, DSYRK, - $ DTRCON, MA02AD, MB01SD, MB03XD, TB01ID, TG01AD, - $ TG01BD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, ATAN, ATAN2, COS, DBLE, INT, LOG, MAX, - $ MIN, SIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - N2 = 2*N - NN = N*N - PM = P + M - N2PM = N2 + PM - MINPM = MIN( P, M ) - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - FULLE = LSAME( JOBE, 'G' ) - LEQUIL = LSAME( EQUIL, 'S' ) - WITHD = LSAME( JOBD, 'D' ) -C - IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( MIN( FPEAK( 1 ), FPEAK( 2 ) ).LT.ZERO ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -18 - ELSE IF( TOL.LT.ZERO .OR. TOL.GE.ONE ) THEN - INFO = -20 - ELSE - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) - NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO - USEPEN = FULLE .OR. DISCR -C -C Compute workspace. -C - ID = 6*MINPM - IC = MAX( 4*MINPM + MAX( P, M ), ID ) - IF( MINPM.EQ.0 ) THEN - MINWRK = 1 - ELSE IF( NODYN ) THEN - IF( WITHD ) THEN - MINWRK = P*M + IC - ELSE - MINWRK = 1 - END IF - ELSE - IF ( DISCR ) THEN - IB = 0 - IE = ID - ELSE - IB = N*( N + M ) - IF ( .NOT.WITHD ) - $ IB = IB + P*M - IE = IC - END IF - IF ( WITHD ) THEN - IR = P*M - IF ( .NOT.USEPEN ) THEN - MINWRK = P*P + M*M - IR = IR + N*PM - ELSE - MINWRK = 0 - END IF - MINWRK = MINWRK + IR + IC - IR = IR + MINPM - ELSE - IR = 0 - MINWRK = 0 - END IF - IR = IR + N*( N + PM ) - IF ( FULLE ) THEN - IR = IR + NN - IF ( LEQUIL ) - $ MINWRK = MAX( MINWRK, IR + 9*N ) - MINWRK = MAX( MINWRK, IR + 4*N + MAX( M, 2*NN, - $ N + IB + IE ) ) - ELSE - MINWRK = MAX( MINWRK, IR + N + MAX( M, P, NN + N2, - $ 3*N + IB + IE ) ) - END IF - LW = 0 - IF ( .NOT.USEPEN ) THEN - LW = IR + 4*NN + 11*N - IF ( WITHD ) - $ LW = LW + MAX( M, P ) + N*PM - END IF - IF ( USEPEN .OR. WITHD ) - $ LW = MAX( LW, IR + 6*N + N2PM*N2PM + - $ MAX( N2PM + PM, 8*( NN + N2 ) ) ) - MINWRK = MAX( 1, MINWRK, LW, IR + N2 + IE ) - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -23 - ELSE - IF ( NODYN ) THEN - MINCWR = 1 - ELSE - MINCWR = MAX( 1, ( N + M )*( N + P ) + - $ 2*MINPM + MAX( P, M ) ) - END IF - IF( LCWORK.LT.MINCWR ) - $ INFO = -25 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AB13DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. P.EQ.0 ) THEN - GPEAK( 1 ) = ZERO - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ONE - FPEAK( 2 ) = ONE - DWORK( 1 ) = ONE - CWORK( 1 ) = ONE - RETURN - END IF -C -C Determine the maximum singular value of G(infinity) = D . -C If JOBE = 'I' and DICO = 'C', the full SVD of D, D = U*S*V', is -C computed and saved for later use. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - ID = 1 - IF ( WITHD ) THEN - IS = ID + P*M - IF ( USEPEN .OR. NODYN ) THEN - IU = IS + MINPM - IV = IU - IWRK = IV - VECT = 'N' - ELSE - IBV = IS + MINPM - ICU = IBV + N*M - IU = ICU + P*N - IV = IU + P*P - IWRK = IV + M*M - VECT = 'A' - END IF -C -C Workspace: need P*M + MIN(P,M) + V + -C MAX( 3*MIN(P,M) + MAX(P,M), 5*MIN(P,M) ), -C where V = N*(M+P) + P*P + M*M, -C if JOBE = 'I' and DICO = 'C', -C and N > 0, B <> 0, C <> 0, -C V = 0, otherwise; -C prefer larger. -C - CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) - CALL DGESVD( VECT, VECT, P, M, DWORK( ID ), P, DWORK( IS ), - $ DWORK( IU ), P, DWORK( IV ), M, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - GAMMAL = DWORK( IS ) - MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Restore D for later calculations. -C - CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) - ELSE - IWRK = 1 - GAMMAL = ZERO - MAXWRK = 1 - END IF -C -C Quick return if possible. -C - IF( NODYN ) THEN - GPEAK( 1 ) = GAMMAL - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ONE - FPEAK( 2 ) = ONE - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = ONE - RETURN - END IF -C - IF ( .NOT.USEPEN .AND. WITHD ) THEN -C -C Standard continuous-time case, D <> 0: Compute B*V and C'*U . -C - CALL DGEMM( 'No Transpose', 'Transpose', N, M, M, ONE, B, LDB, - $ DWORK( IV ), M, ZERO, DWORK( IBV ), N ) - CALL DGEMM( 'Transpose', 'No Transpose', N, P, P, ONE, C, - $ LDC, DWORK( IU ), P, ZERO, DWORK( ICU ), N ) -C -C U and V are no longer needed: free their memory space. -C Total workspace here: need P*M + MIN(P,M) + N*(M+P) -C (JOBE = 'I', DICO = 'C', JOBD = 'D'). -C - IWRK = IU - END IF -C -C Get machine constants. -C - EPS = DLAMCH( 'Epsilon' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - TOLER = SQRT( EPS ) -C -C Initiate the transformation of the system to an equivalent one, -C to be used for eigenvalue computations. -C -C Additional workspace: need N*N + N*M + P*N + 2*N, if JOBE = 'I'; -C 2*N*N + N*M + P*N + 2*N, if JOBE = 'G'. -C - IA = IWRK - IE = IA + NN - IF ( FULLE ) THEN - IB = IE + NN - ELSE - IB = IE - END IF - IC = IB + N*M - IR = IC + P*N - II = IR + N - IBT = II + N -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IA ), N ) - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IB ), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK( IC ), P ) -C -C Scale A if maximum element is outside the range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'Max', N, N, DWORK( IA ), N, DWORK ) - 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( 'General', 0, 0, ANRM, ANRMTO, N, N, DWORK( IA ), - $ N, IERR ) -C - IF ( FULLE ) THEN -C -C Descriptor system. -C -C Additional workspace: need N. -C - IWRK = IBT + N - CALL DLACPY( 'Full', N, N, E, LDE, DWORK( IE ), N ) -C -C Scale E if maximum element is outside the range -C [SMLNUM,BIGNUM]. -C - ENRM = DLANGE( 'Max', N, N, DWORK( IE ), N, DWORK ) - ILESCL = .FALSE. - IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN - ENRMTO = SMLNUM - ILESCL = .TRUE. - ELSE IF( ENRM.GT.BIGNUM ) THEN - ENRMTO = BIGNUM - ILESCL = .TRUE. - ELSE IF( ENRM.EQ.ZERO ) THEN -C -C Error return: Matrix E is 0. -C - INFO = 1 - RETURN - END IF - IF( ILESCL ) - $ CALL DLASCL( 'General', 0, 0, ENRM, ENRMTO, N, N, - $ DWORK( IE ), N, IERR ) -C -C Equilibrate the system, if required. -C -C Additional workspace: need 6*N. -C - IF( LEQUIL ) - $ CALL TG01AD( 'All', N, N, M, P, ZERO, DWORK( IA ), N, - $ DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), P, - $ DWORK( II ), DWORK( IR ), DWORK( IWRK ), - $ IERR ) -C -C For efficiency of later calculations, the system (A,E,B,C) is -C reduced to an equivalent one with the state matrix A in -C Hessenberg form, and E upper triangular. -C First, permute (A,E) to make it more nearly triangular. -C - CALL DGGBAL( 'Permute', N, DWORK( IA ), N, DWORK( IE ), N, ILO, - $ IHI, DWORK( II ), DWORK( IR ), DWORK( IWRK ), - $ IERR ) -C -C Apply the permutations to (the copies of) B and C. -C - DO 10 I = N, IHI + 1, -1 - K = DWORK( II+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - K = DWORK( IR+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - 10 CONTINUE -C - DO 20 I = 1, ILO - 1 - K = DWORK( II+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - K = DWORK( IR+I-1 ) - IF( K.NE.I ) - $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - 20 CONTINUE -C -C Reduce (A,E) to generalized Hessenberg form and apply the -C transformations to B and C. -C Additional workspace: need N + MAX(N,M); -C prefer N + MAX(N,M)*NB. -C - CALL TG01BD( 'General', 'No Q', 'No Z', N, M, P, ILO, IHI, - $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), N, - $ DWORK( IC ), P, DWORK, 1, DWORK, 1, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Check whether matrix E is nonsingular. -C Additional workspace: need 3*N. -C - CALL DTRCON( '1-norm', 'Upper', 'Non Unit', N, DWORK( IE ), N, - $ RCOND, DWORK( IWRK ), IWORK, IERR ) - IF( RCOND.LE.TEN*DBLE( N )*EPS ) THEN -C -C Error return: Matrix E is numerically singular. -C - INFO = 1 - RETURN - END IF -C -C Perform QZ algorithm, computing eigenvalues. The generalized -C Hessenberg form is saved for later use. -C Additional workspace: need 2*N*N + N; -C prefer larger. -C - IAS = IWRK - IES = IAS + NN - IWRK = IES + NN - CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) - CALL DLACPY( 'Full', N, N, DWORK( IE ), N, DWORK( IES ), N ) - CALL DHGEQZ( 'Eigenvalues', 'No Vectors', 'No Vectors', N, ILO, - $ IHI, DWORK( IAS ), N, DWORK( IES ), N, - $ DWORK( IR ), DWORK( II ), DWORK( IBT ), DWORK, N, - $ DWORK, N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Check if unscaling would cause over/underflow; if so, rescale -C eigenvalues (DWORK( IR+I-1 ),DWORK( II+I-1 ),DWORK( IBT+I-1 )) -C so DWORK( IBT+I-1 ) is on the order of E(I,I) and -C DWORK( IR+I-1 ) and DWORK( II+I-1 ) are on the order of A(I,I). -C - IF( ILASCL ) THEN -C - DO 30 I = 1, N - IF( DWORK( II+I-1 ).NE.ZERO ) THEN - IF( ( DWORK( IR+I-1 ) / SAFMAX ).GT.( ANRMTO / ANRM ) - $ .OR. - $ ( SAFMIN / DWORK( IR+I-1 ) ).GT.( ANRM / ANRMTO ) - $ ) THEN - TM = ABS( DWORK( IA+(I-1)*N+I ) / DWORK( IR+I-1 ) ) - DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM - DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM - DWORK( II+I-1 ) = DWORK( II+I-1 )*TM - ELSE IF( ( DWORK( II+I-1 ) / SAFMAX ).GT. - $ ( ANRMTO / ANRM ) .OR. - $ ( SAFMIN / DWORK( II+I-1 ) ).GT.( ANRM / ANRMTO ) ) - $ THEN - TM = ABS( DWORK( IA+I*N+I ) / DWORK( II+I-1 ) ) - DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM - DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM - DWORK( II+I-1 ) = DWORK( II+I-1 )*TM - END IF - END IF - 30 CONTINUE -C - END IF -C - IF( ILESCL ) THEN -C - DO 40 I = 1, N - IF( DWORK( II+I-1 ).NE.ZERO ) THEN - IF( ( DWORK( IBT+I-1 ) / SAFMAX ).GT.( ENRMTO / ENRM ) - $ .OR. - $ ( SAFMIN / DWORK( IBT+I-1 ) ).GT.( ENRM / ENRMTO ) - $ ) THEN - TM = ABS( DWORK( IE+(I-1)*N+I ) / DWORK( IBT+I-1 )) - DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM - DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM - DWORK( II+I-1 ) = DWORK( II+I-1 )*TM - END IF - END IF - 40 CONTINUE -C - END IF -C -C Undo scaling. -C - IF( ILASCL ) THEN - CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, - $ DWORK( IA ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( IR ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( II ), N, IERR ) - END IF -C - IF( ILESCL ) THEN - CALL DLASCL( 'Upper', 0, 0, ENRMTO, ENRM, N, N, - $ DWORK( IE ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ENRMTO, ENRM, N, 1, - $ DWORK( IBT ), N, IERR ) - END IF -C - ELSE -C -C Standard state-space system. -C - IF( LEQUIL ) THEN -C -C Equilibrate the system. -C - MAXRED = HUNDRD - CALL TB01ID( 'All', N, M, P, MAXRED, DWORK( IA ), N, - $ DWORK( IB ), N, DWORK( IC ), P, DWORK( II ), - $ IERR ) - END IF -C -C For efficiency of later calculations, the system (A,B,C) is -C reduced to a similar one with the state matrix in Hessenberg -C form. -C -C First, permute the matrix A to make it more nearly triangular -C and apply the permutations to B and C. -C - CALL DGEBAL( 'Permute', N, DWORK( IA ), N, ILO, IHI, - $ DWORK( IR ), IERR ) -C - DO 50 I = N, IHI + 1, -1 - K = DWORK( IR+I-1 ) - IF( K.NE.I ) THEN - CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - END IF - 50 CONTINUE -C - DO 60 I = 1, ILO - 1 - K = DWORK( IR+I-1 ) - IF( K.NE.I ) THEN - CALL DSWAP( M, DWORK( IB+I-1 ), N, - $ DWORK( IB+K-1 ), N ) - CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, - $ DWORK( IC+(K-1)*P ), 1 ) - END IF - 60 CONTINUE -C -C Reduce A to upper Hessenberg form and apply the transformations -C to B and C. -C Additional workspace: need N; (from II) -C prefer N*NB. -C - ITAU = IR - IWRK = ITAU + N - CALL DGEHRD( N, ILO, IHI, DWORK( IA ), N, DWORK( ITAU ), - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Additional workspace: need M; -C prefer M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, DWORK( IA ), - $ N, DWORK( ITAU ), DWORK( IB ), N, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Additional workspace: need P; -C prefer P*NB. -C - CALL DORMHR( 'Right', 'NoTranspose', P, N, ILO, IHI, - $ DWORK( IA ), N, DWORK( ITAU ), DWORK( IC ), P, - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Compute the eigenvalues. The Hessenberg form is saved for -C later use. -C Additional workspace: need N*N + N; (from IBT) -C prefer larger. -C - IAS = IBT - IWRK = IAS + NN - CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) - CALL DHSEQR( 'Eigenvalues', 'No Vectors', N, ILO, IHI, - $ DWORK( IAS ), N, DWORK( IR ), DWORK( II ), DWORK, - $ N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C - IF( ILASCL ) THEN -C -C Undo scaling for the Hessenberg form of A and eigenvalues. -C - CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, - $ DWORK( IA ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( IR ), N, IERR ) - CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, - $ DWORK( II ), N, IERR ) - END IF -C - END IF -C -C Look for (generalized) eigenvalues on the boundary of the -C stability domain. (Their existence implies an infinite norm.) -C Additional workspace: need 2*N. (from IAS) -C - IM = IAS - IAR = IM + N - IMIN = II - WRMIN = SAFMAX - BOUND = EPS*THOUSD -C - IF ( DISCR ) THEN - GAMMAL = ZERO -C -C For discrete-time case, compute the logarithm of the non-zero -C eigenvalues and save their moduli and absolute real parts. -C (The logarithms are overwritten on the eigenvalues.) -C Also, find the minimum distance to the unit circle. -C - IF ( FULLE ) THEN -C - DO 70 I = 0, N - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. SAFMAX is used. -C - TM = SAFMAX - END IF - IF ( TM.NE.ZERO ) THEN - DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) - DWORK( IR+I ) = LOG( TM ) - END IF - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - TM = ABS( ONE - TM ) - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - IM = IM + 1 - DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) - 70 CONTINUE -C - ELSE -C - DO 80 I = 0, N - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( TM.NE.ZERO ) THEN - DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) - DWORK( IR+I ) = LOG( TM ) - END IF - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - TM = ABS( ONE - TM ) - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - IM = IM + 1 - DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) - 80 CONTINUE -C - END IF -C - ELSE -C -C For continuous-time case, save moduli of eigenvalues and -C absolute real parts and find the maximum modulus and minimum -C absolute real part. -C - WMAX = ZERO -C - IF ( FULLE ) THEN -C - DO 90 I = 0, N - 1 - TM = ABS( DWORK( IR+I ) ) - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ DWORK( IM ).LT.SAFMAX*DWORK( IBT+I ) ) ) - $ THEN - TM = TM / DWORK( IBT+I ) - DWORK( IM ) = DWORK( IM ) / DWORK( IBT+I ) - ELSE - IF ( TM.LT.SAFMAX*DWORK( IBT+I ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. -C SAFMAX is used. -C - TM = SAFMAX - END IF - DWORK( IM ) = SAFMAX - END IF - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - DWORK( IAR+I ) = TM - IF( DWORK( IM ).GT.WMAX ) - $ WMAX = DWORK( IM ) - IM = IM + 1 - 90 CONTINUE -C - ELSE -C - DO 100 I = 0, N - 1 - TM = ABS( DWORK( IR+I ) ) - IF( TM.LT.WRMIN ) THEN - IMIN = II + I - WRMIN = TM - END IF - DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF( DWORK( IM ).GT.WMAX ) - $ WMAX = DWORK( IM ) - IM = IM + 1 - DWORK( IAR+I ) = TM - 100 CONTINUE -C - END IF -C - BOUND = BOUND + EPS*WMAX -C - END IF -C - IM = IM - N -C - IF( WRMIN.LT.BOUND ) THEN -C -C The L-infinity norm was found as infinite. -C - GPEAK( 1 ) = ONE - GPEAK( 2 ) = ZERO - TM = ABS( DWORK( IMIN ) ) - IF ( DISCR ) - $ TM = ABS( ATAN2( SIN( TM ), COS( TM ) ) ) - FPEAK( 1 ) = TM - IF ( TM.LT.SAFMAX ) THEN - FPEAK( 2 ) = ONE - ELSE - FPEAK( 2 ) = ZERO - END IF -C - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = ONE - RETURN - END IF -C -C Determine the maximum singular value of -C G(lambda) = C*inv(lambda*E - A)*B + D, -C over a selected set of frequencies. Besides the frequencies w = 0, -C w = pi (if DICO = 'D'), and the given value FPEAK, this test set -C contains the peak frequency for each mode (or an approximation -C of it). The (generalized) Hessenberg form of the system is used. -C -C First, determine the maximum singular value of G(0) and set FPEAK -C accordingly. -C Additional workspace: -C complex: need 1, if DICO = 'C'; -C (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)), otherwise; -C prefer larger; -C real: need LDW0+LDW1+LDW2, where -C LDW0 = N*N+N*M, if DICO = 'C'; -C LDW0 = 0, if DICO = 'D'; -C LDW1 = P*M, if DICO = 'C', JOBD = 'Z'; -C LDW1 = 0, otherwise; -C LDW2 = MIN(P,M)+MAX(3*MIN(P,M)+MAX(P,M), -C 5*MIN(P,M)), -C if DICO = 'C'; -C LDW2 = 6*MIN(P,M), otherwise. -C prefer larger. -C - IF ( DISCR ) THEN - IAS = IA - IBS = IB - IWRK = IAR + N - ELSE - IAS = IAR + N - IBS = IAS + NN - IWRK = IBS + N*M - CALL DLACPY( 'Upper', N, N, DWORK( IA ), N, DWORK( IAS ), N ) - CALL DCOPY( N-1, DWORK( IA+1 ), N+1, DWORK( IAS+1 ), N+1 ) - CALL DLACPY( 'Full', N, M, DWORK( IB ), N, DWORK( IBS ), N ) - END IF - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, ZERO, DWORK( IAS ), N, - $ DWORK( IE ), N, DWORK( IBS ), N, DWORK( IC ), P, - $ DWORK( ID ), P, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - FPEAKS = FPEAK( 1 ) - FPEAKI = FPEAK( 2 ) - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = ZERO - FPEAK( 2 ) = ONE - ELSE IF( .NOT.DISCR ) THEN - FPEAK( 1 ) = ONE - FPEAK( 2 ) = ZERO - END IF -C - MAXCWK = INT( CWORK( 1 ) ) -C - IF( DISCR ) THEN -C -C Try the frequency w = pi. -C - PI = FOUR*ATAN( ONE ) - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, PI, DWORK( IA ), - $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), - $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = PI - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = PI - FPEAK( 2 ) = ONE - END IF -C - ELSE - IWRK = IAS -C -C Restore D, if needed. -C - IF ( WITHD ) - $ CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) - END IF -C -C Build the remaining set of frequencies. -C Complex workspace: need (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)); -C prefer larger. -C Real workspace: need LDW2, see above; -C prefer larger. -C - IF ( MIN( FPEAKS, FPEAKI ).NE.ZERO ) THEN -C -C Compute also the norm at the given (finite) frequency. -C - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, FPEAKS, DWORK( IA ), - $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), - $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF ( DISCR ) THEN - TM = ABS( ATAN2( SIN( FPEAKS ), COS( FPEAKS ) ) ) - ELSE - TM = FPEAKS - END IF - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = TM - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = TM - FPEAK( 2 ) = ONE - END IF -C - END IF -C - DO 110 I = 0, N - 1 - IF( DWORK( II+I ).GE.ZERO .AND. DWORK( IM+I ).GT.ZERO ) THEN - IF ( ( DWORK( IM+I ).GE.ONE ) .OR. ( DWORK( IM+I ).LT.ONE - $ .AND. DWORK( IAR+I ).LT.SAFMAX*DWORK( IM+I ) ) ) THEN - RAT = DWORK( IAR+I ) / DWORK( IM+I ) - ELSE - RAT = ONE - END IF - OMEGA = DWORK( IM+I )*SQRT( MAX( P25, ONE - TWO*RAT**2 ) ) -C - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, - $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), - $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, - $ IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF ( DISCR ) THEN - TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) - ELSE - TM = OMEGA - END IF - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = TM - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = TM - FPEAK( 2 ) = ONE - END IF -C - END IF - 110 CONTINUE -C -C Return if the lower bound is zero. -C - IF( GAMMAL.EQ.ZERO ) THEN - GPEAK( 1 ) = ZERO - FPEAK( 1 ) = ZERO - GPEAK( 2 ) = ONE - FPEAK( 2 ) = ONE - GO TO 340 - END IF -C -C Start the modified gamma iteration for the Bruinsma-Steinbuch -C algorithm. -C - IF ( .NOT.DISCR ) - $ RTOL = HUNDRD*TOLER - ITER = 0 -C -C WHILE ( Iteration may continue ) DO -C - 120 CONTINUE -C - ITER = ITER + 1 - GAMMA = ( ONE + TOL )*GAMMAL - USEPEN = FULLE .OR. DISCR - IF ( .NOT.USEPEN .AND. WITHD ) THEN -C -C Check whether one can use an explicit Hamiltonian matrix: -C compute -C min(rcond(GAMMA**2*Im - S'*S), rcond(GAMMA**2*Ip - S*S')). -C If P = M = 1, then GAMMA**2 - S(1)**2 is used instead. -C - IF ( M.NE.P ) THEN - RCOND = ONE - ( DWORK( IS ) / GAMMA )**2 - ELSE IF ( MINPM.GT.1 ) THEN - RCOND = ( GAMMA**2 - DWORK( IS )**2 ) / - $ ( GAMMA**2 - DWORK( IS+P-1 )**2 ) - ELSE - RCOND = GAMMA**2 - DWORK( IS )**2 - END IF -C - USEPEN = RCOND.LT.RTOL - END IF -C - IF ( USEPEN ) THEN -C -C Use the QZ algorithm on a pencil. -C Additional workspace here: need 6*N. (from IR) -C - II = IR + N2 - IBT = II + N2 - IH12 = IBT + N2 - IM = IH12 -C -C Set up the needed parts of the Hamiltonian pencil (H,J), -C -C ( H11 H12 ) -C H = ( ) , -C ( H21 H22 ) -C -C with -C -C ( A 0 ) ( 0 B ) ( E 0 ) -C H11 = ( ), H12 = ( )/nB, J11 = ( ), -C ( 0 -A' ) ( C' 0 ) ( 0 E' ) -C -C ( C 0 ) ( Ip D/g ) -C H21 = ( )*nB, H22 = ( ), -C ( 0 -B' ) ( D'/g Im ) -C -C if DICO = 'C', and -C -C ( A 0 ) ( B 0 ) ( E 0 ) -C H11 = ( ), H12 = ( )/nB, J11 = ( ), -C ( 0 E' ) ( 0 C' ) ( 0 A') -C -C ( 0 0 ) ( Im D'/g ) ( 0 B') -C H21 = ( )*nB, H22 = ( ), J21 = ( )*nB, -C ( C 0 ) ( D/g Ip ) ( 0 0 ) -C -C if DICO = 'D', where g = GAMMA, and nB = norm(B,1). -C First build [H12; H22]. -C - TEMP( 1 ) = ZERO - IH = IH12 -C - IF ( DISCR ) THEN -C - DO 150 J = 1, M -C - DO 130 I = 1, N - DWORK( IH ) = B( I, J ) / BNORM - IH = IH + 1 - 130 CONTINUE -C - CALL DCOPY( N+M, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+N+J-1 ) = ONE - IH = IH + N + M -C - DO 140 I = 1, P - DWORK( IH ) = D( I, J ) / GAMMA - IH = IH + 1 - 140 CONTINUE -C - 150 CONTINUE -C - DO 180 J = 1, P - CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) - IH = IH + N -C - DO 160 I = 1, N - DWORK( IH ) = C( J, I ) / BNORM - IH = IH + 1 - 160 CONTINUE -C - DO 170 I = 1, M - DWORK( IH ) = D( J, I ) / GAMMA - IH = IH + 1 - 170 CONTINUE -C - CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+J-1 ) = ONE - IH = IH + P - 180 CONTINUE -C - ELSE -C - DO 210 J = 1, P - CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) - IH = IH + N -C - DO 190 I = 1, N - DWORK( IH ) = C( J, I ) / BNORM - IH = IH + 1 - 190 CONTINUE -C - CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+J-1 ) = ONE - IH = IH + P -C - DO 200 I = 1, M - DWORK( IH ) = D( J, I ) / GAMMA - IH = IH + 1 - 200 CONTINUE -C - 210 CONTINUE -C - DO 240 J = 1, M -C - DO 220 I = 1, N - DWORK( IH ) = B( I, J ) / BNORM - IH = IH + 1 - 220 CONTINUE -C - CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) - IH = IH + N -C - DO 230 I = 1, P - DWORK( IH ) = D( I, J ) / GAMMA - IH = IH + 1 - 230 CONTINUE -C - CALL DCOPY( M, TEMP, 0, DWORK( IH ), 1 ) - DWORK( IH+J-1 ) = ONE - IH = IH + M - 240 CONTINUE -C - END IF -C -C Compute the QR factorization of [H12; H22]. -C For large P and M, it could be more efficient to exploit the -C structure of [H12; H22] and use the factored form of Q. -C Additional workspace: need (2*N+P+M)*(2*N+P+M)+2*(P+M); -C prefer (2*N+P+M)*(2*N+P+M)+P+M+ -C (P+M)*NB. -C - ITAU = IH12 + N2PM*N2PM - IWRK = ITAU + PM - CALL DGEQRF( N2PM, PM, DWORK( IH12 ), N2PM, DWORK( ITAU ), - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Apply part of the orthogonal transformation: -C Q1 = Q(:,P+M+(1:2*N))' to the matrix [H11; H21/GAMMA]. -C If DICO = 'C', apply Q(1:2*N,P+M+(1:2*N))' to the -C matrix J11. -C If DICO = 'D', apply Q1 to the matrix [J11; J21/GAMMA]. -C H11, H21, J11, and J21 are not fully built. -C First, build the (2*N+P+M)-by-(2*N+P+M) matrix Q. -C Using Q will often provide better efficiency than the direct -C use of the factored form of Q, especially when P+M < N. -C Additional workspace: need P+M+2*N+P+M; -C prefer P+M+(2*N+P+M)*NB. -C - CALL DORGQR( N2PM, N2PM, PM, DWORK( IH12 ), N2PM, - $ DWORK( ITAU ), DWORK( IWRK ), LDWORK-IWRK+1, - $ IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C -C Additional workspace: need 8*N*N. -C - IPA = ITAU - IPE = IPA + 4*NN - IWRK = IPE + 4*NN - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM ), N2PM, A, LDA, ZERO, - $ DWORK( IPA ), N2 ) - IF ( DISCR ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, - $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+M), N2PM, - $ C, LDC, ONE, DWORK( IPA ), N2 ) - IF ( FULLE ) THEN - CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, - $ ZERO, DWORK( IPA+2*NN ), N2 ) - ELSE - CALL MA02AD( 'Full', N, N2, DWORK( IH12+PM*N2PM+N ), - $ N2PM, DWORK( IPA+2*NN ), N2 ) - NY = N - END IF - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, - $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2), N2PM, - $ C, LDC, ONE, DWORK( IPA ), N2 ) - CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, -ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, ZERO, - $ DWORK( IPA+2*NN ), N2 ) - CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, - $ -BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+P), - $ N2PM, B, LDB, ONE, DWORK( IPA+2*NN ), N2 ) - NY = N2 - END IF -C - IF ( FULLE ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM ), N2PM, E, LDE, ZERO, - $ DWORK( IPE ), N2 ) - ELSE - CALL MA02AD( 'Full', NY, N2, DWORK( IH12+PM*N2PM ), - $ N2PM, DWORK( IPE ), N2 ) - END IF - IF ( DISCR ) THEN - CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, - $ ZERO, DWORK( IPE+2*NN ), N2 ) - CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, - $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2 ), N2PM, - $ B, LDB, ONE, DWORK( IPE+2*NN ), N2 ) - ELSE - IF ( FULLE ) - $ CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, - $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, - $ ZERO, DWORK( IPE+2*NN ), N2 ) - END IF -C -C Compute the eigenvalues of the Hamiltonian pencil. -C Additional workspace: need 16*N; -C prefer larger. -C - CALL DGGEV( 'No Vectors', 'No Vectors', N2, DWORK( IPA ), - $ N2, DWORK( IPE ), N2, DWORK( IR ), DWORK( II ), - $ DWORK( IBT ), DWORK, N2, DWORK, N2, - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C - ELSE IF ( .NOT.WITHD ) THEN -C -C Standard continuous-time case with D = 0. -C Form the needed part of the Hamiltonian matrix explicitly: -C H = H11 - H12*inv(H22)*H21/g. -C Additional workspace: need 2*N*N+N. (from IBT) -C - IH = IBT - IH12 = IH + NN - ISL = IH12 + NN + N - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) -C -C Compute triangles of -C'*C/GAMMA and B*B'/GAMMA. -C - CALL DSYRK( 'Lower', 'Transpose', N, P, -ONE/GAMMA, C, LDC, - $ ZERO, DWORK( IH12 ), N ) - CALL DSYRK( 'Upper', 'No Transpose', N, M, ONE/GAMMA, B, - $ LDB, ZERO, DWORK( IH12+N ), N ) -C - ELSE -C -C Standard continuous-time case with D <> 0 and the SVD of D -C can be used. Compute explicitly the needed part of the -C Hamiltonian matrix: -C -C (A+B1*S'*inv(g^2*Ip-S*S')*C1' g*B1*inv(g^2*Im-S'*S)*B1') -C H = ( ) -C ( -g*C1*inv(g^2*Ip-S*S')*C1' -H11' ) -C -C where g = GAMMA, B1 = B*V, C1 = C'*U, and H11 is the first -C block of H. -C Primary additional workspace: need 2*N*N+N (from IBT) -C (for building the relevant part of the Hamiltonian matrix). -C -C Compute C1*sqrt(inv(g^2*Ip-S*S')) . -C Additional workspace: need MAX(M,P)+N*P. -C - IH = IBT - IH12 = IH + NN - ISL = IH12 + NN + N -C - DO 250 I = 0, MINPM - 1 - DWORK( ISL+I ) = ONE/SQRT( GAMMA**2 - DWORK( IS+I )**2 ) - 250 CONTINUE -C - IF ( M.LT.P ) THEN - DWORK( ISL+M ) = ONE / GAMMA - CALL DCOPY( P-M-1, DWORK( ISL+M ), 0, DWORK( ISL+M+1 ), - $ 1 ) - END IF - ISC = ISL + MAX( M, P ) - CALL DLACPY( 'Full', N, P, DWORK( ICU ), N, DWORK( ISC ), - $ N ) - CALL MB01SD( 'Column', N, P, DWORK( ISC ), N, DWORK, - $ DWORK( ISL ) ) -C -C Compute B1*S' . -C Additional workspace: need N*M. -C - ISB = ISC + P*N - CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), - $ N ) - CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, - $ DWORK( IS ) ) -C -C Compute B1*S'*sqrt(inv(g^2*Ip-S*S')) . -C - CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, - $ DWORK( ISL ) ) -C -C Compute H11 . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) - CALL DGEMM( 'No Transpose', 'Transpose', N, N, MINPM, ONE, - $ DWORK( ISB ), N, DWORK( ISC ), N, ONE, - $ DWORK( IH ), N ) -C -C Compute B1*sqrt(inv(g^2*Im-S'*S)) . -C - IF ( P.LT.M ) THEN - DWORK( ISL+P ) = ONE / GAMMA - CALL DCOPY( M-P-1, DWORK( ISL+P ), 0, DWORK( ISL+P+1 ), - $ 1 ) - END IF - CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), - $ N ) - CALL MB01SD( 'Column', N, M, DWORK( ISB ), N, DWORK, - $ DWORK( ISL ) ) -C -C Compute the lower triangle of H21 and the upper triangle -C of H12. -C - CALL DSYRK( 'Lower', 'No Transpose', N, P, -GAMMA, - $ DWORK( ISC ), N, ZERO, DWORK( IH12 ), N ) - CALL DSYRK( 'Upper', 'No Transpose', N, M, GAMMA, - $ DWORK( ISB ), N, ZERO, DWORK( IH12+N ), N ) - END IF -C - IF ( .NOT.USEPEN ) THEN -C -C Compute the eigenvalues of the Hamiltonian matrix by the -C symplectic URV and the periodic Schur decompositions. -C Additional workspace: need (2*N+8)*N; -C prefer larger. -C - IWRK = ISL + NN - CALL MB03XD( 'Both', 'Eigenvalues', 'No vectors', - $ 'No vectors', N, DWORK( IH ), N, DWORK( IH12 ), - $ N, DWORK( ISL ), N, TEMP, 1, TEMP, 1, TEMP, 1, - $ TEMP, 1, DWORK( IR ), DWORK( II ), ILO, - $ DWORK( IWRK ), DWORK( IWRK+N ), - $ LDWORK-IWRK-N+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK + N - 1, MAXWRK ) - END IF -C -C Detect eigenvalues on the boundary of the stability domain, -C if any. The test is based on a round-off level of eps*rho(H) -C (after balancing) resulting in worst-case perturbations of -C order sqrt(eps*rho(H)), for continuous-time systems, on the -C real part of poles of multiplicity two (typical as GAMMA -C approaches the infinity norm). Similarly, in the discrete-time -C case. Above, rho(H) is the maximum modulus of eigenvalues -C (continuous-time case). -C -C Compute maximum eigenvalue modulus and check the absolute real -C parts (if DICO = 'C'), or moduli (if DICO = 'D'). -C - WMAX = ZERO -C - IF ( USEPEN ) THEN -C -C Additional workspace: need 2*N, if DICO = 'D'; (from IM) -C 0, if DICO = 'C'. -C - DO 260 I = 0, N2 - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. SAFMAX is used. -C - TM = SAFMAX - END IF - WMAX = MAX( WMAX, TM ) - IF ( DISCR ) - $ DWORK( IM+I ) = TM - 260 CONTINUE -C - ELSE -C - DO 270 I = 0, N - 1 - TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) - WMAX = MAX( WMAX, TM ) - 270 CONTINUE -C - END IF -C - NEI = 0 -C - IF ( USEPEN ) THEN -C - DO 280 I = 0, N2 - 1 - IF ( DISCR ) THEN - TM = ABS( ONE - DWORK( IM+I ) ) - ELSE - TM = ABS( DWORK( IR+I ) ) - IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. - $ ( DWORK( IBT+I ).LT.ONE .AND. - $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN - TM = TM / DWORK( IBT+I ) - ELSE -C -C The pencil has too large eigenvalues. -C SAFMAX is used. -C - TM = SAFMAX - END IF - END IF - IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN - DWORK( IR+NEI ) = DWORK( IR+I ) / DWORK( IBT+I ) - DWORK( II+NEI ) = DWORK( II+I ) / DWORK( IBT+I ) - NEI = NEI + 1 - END IF - 280 CONTINUE -C - ELSE -C - DO 290 I = 0, N - 1 - TM = ABS( DWORK( IR+I ) ) - IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN - DWORK( IR+NEI ) = DWORK( IR+I ) - DWORK( II+NEI ) = DWORK( II+I ) - NEI = NEI + 1 - END IF - 290 CONTINUE -C - END IF -C - IF( NEI.EQ.0 ) THEN -C -C There is no eigenvalue on the boundary of the stability -C domain for G = ( ONE + TOL )*GAMMAL. The norm was found. -C - GPEAK( 1 ) = GAMMAL - GPEAK( 2 ) = ONE - GO TO 340 - END IF -C -C Compute the frequencies where the gain G is attained and -C generate new test frequencies. -C - NWS = 0 -C - IF ( DISCR ) THEN -C - DO 300 I = 0, NEI - 1 - TM = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) - DWORK( IR+I ) = MAX( EPS, TM ) - NWS = NWS + 1 - 300 CONTINUE -C - ELSE -C - J = 0 -C - DO 310 I = 0, NEI - 1 - IF ( DWORK( II+I ).GT.EPS ) THEN - DWORK( IR+NWS ) = DWORK( II+I ) - NWS = NWS + 1 - ELSE IF ( DWORK( II+I ).EQ.EPS ) THEN - J = J + 1 - IF ( J.EQ.1 ) THEN - DWORK( IR+NWS ) = EPS - NWS = NWS + 1 - END IF - END IF - 310 CONTINUE -C - END IF -C - CALL DLASRT( 'Increasing', NWS, DWORK( IR ), IERR ) - LW = 1 -C - DO 320 I = 0, NWS - 1 - IF ( DWORK( IR+LW-1 ).NE.DWORK( IR+I ) ) THEN - DWORK( IR+LW ) = DWORK( IR+I ) - LW = LW + 1 - END IF - 320 CONTINUE -C - IF ( LW.EQ.1 ) THEN - IF ( ITER.EQ.1 .AND. NWS.GE.1 ) THEN -C -C Duplicate the frequency trying to force iteration. -C - DWORK( IR+1 ) = DWORK( IR ) - LW = LW + 1 - ELSE -C -C The norm was found. -C - GPEAK( 1 ) = GAMMAL - GPEAK( 2 ) = ONE - GO TO 340 - END IF - END IF -C -C Form the vector of mid-points and compute the gain at new test -C frequencies. Save the current lower bound. -C - IWRK = IR + LW - GAMMAS = GAMMAL -C - DO 330 I = 0, LW - 2 - IF ( DISCR ) THEN - OMEGA = ( DWORK( IR+I ) + DWORK( IR+I+1 ) ) / TWO - ELSE - OMEGA = SQRT( DWORK( IR+I )*DWORK( IR+I+1 ) ) - END IF -C -C Additional workspace: need LDW2, see above; -C prefer larger. -C - GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, - $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), - $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, - $ IERR ) - MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - IF ( DISCR ) THEN - TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) - ELSE - TM = OMEGA - END IF - IF( IERR.GE.1 .AND. IERR.LE.N ) THEN - GPEAK( 1 ) = ONE - FPEAK( 1 ) = TM - GPEAK( 2 ) = ZERO - FPEAK( 2 ) = ONE - GO TO 340 - ELSE IF( IERR.EQ.N+1 ) THEN - INFO = 3 - RETURN - END IF -C - IF( GAMMAL.LT.GAMMA ) THEN - GAMMAL = GAMMA - FPEAK( 1 ) = TM - FPEAK( 2 ) = ONE - END IF - 330 CONTINUE -C -C If the lower bound has not been improved, return. (This is a -C safeguard against undetected modes of Hamiltonian matrix on the -C boundary of the stability domain.) -C - IF ( GAMMAL.LT.GAMMAS*( ONE + TOL/TEN ) ) THEN - GPEAK( 1 ) = GAMMAL - GPEAK( 2 ) = ONE - GO TO 340 - END IF -C -C END WHILE -C - IF ( ITER.LE.MAXIT ) THEN - GO TO 120 - ELSE - INFO = 4 - RETURN - END IF -C - 340 CONTINUE - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = MAXCWK - RETURN -C *** Last line of AB13DD *** - END diff --git a/slycot/src/AB13DX.f b/slycot/src/AB13DX.f deleted file mode 100644 index 5de0bd78..00000000 --- a/slycot/src/AB13DX.f +++ /dev/null @@ -1,549 +0,0 @@ - DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P, - $ OMEGA, A, LDA, E, LDE, B, LDB, - $ C, LDC, D, LDD, IWORK, DWORK, - $ LDWORK, CWORK, LCWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the maximum singular value of a given continuous-time -C or discrete-time transfer-function matrix, either standard or in -C the descriptor form, -C -C -1 -C G(lambda) = C*( lambda*E - A ) *B + D , -C -C for a given complex value lambda, where lambda = j*omega, in the -C continuous-time case, and lambda = exp(j*omega), in the -C discrete-time case. The matrices A, E, B, C, and D are real -C matrices of appropriate dimensions. Matrix A must be in an upper -C Hessenberg form, and if JOBE ='G', the matrix E must be upper -C triangular. The matrices B and C must correspond to the system -C in (generalized) Hessenberg form. -C -C FUNCTION VALUE -C -C AB13DX DOUBLE PRECISION -C The maximum singular value of G(lambda). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system, as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBE CHARACTER*1 -C Specifies whether E is an upper triangular or an identity -C matrix, as follows: -C = 'G': E is a general upper triangular matrix; -C = 'I': E is the identity matrix. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C P (input) INTEGER -C The row size of the matrix C. P >= 0. -C -C OMEGA (input) DOUBLE PRECISION -C The frequency value for which the calculations should be -C done. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper Hessenberg part of this -C array must contain the state dynamics matrix A in upper -C Hessenberg form. The elements below the subdiagonal are -C not referenced. -C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, -C and C <> 0, the leading N-by-N upper Hessenberg part of -C this array contains the factors L and U from the LU -C factorization of A (A = P*L*U); the unit diagonal elements -C of L are not stored, L is lower bidiagonal, and P is -C stored in IWORK (see SLICOT Library routine MB02SD). -C Otherwise, this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'G', the leading N-by-N upper triangular part of -C this array must contain the upper triangular descriptor -C matrix E of the system. The elements of the strict lower -C triangular part of this array are not referenced. -C If JOBE = 'I', then E is assumed to be the identity -C matrix and is not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. -C LDE >= MAX(1,N), if JOBE = 'G'; -C LDE >= 1, if JOBE = 'I'. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, -C C <> 0, and INFO = 0 or N+1, the leading N-by-M part of -C this array contains the solution of the system A*X = B. -C Otherwise, this array is unchanged on exit. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the direct transmission matrix D. -C On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D', -C or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or -C N+1), the contents of this array is destroyed. -C Otherwise, this array is unchanged on exit. -C This array is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0; -C LIWORK = 0, otherwise. -C This array contains the pivot indices in the LU -C factorization of the matrix lambda*E - A; for 1 <= i <= N, -C row i of the matrix was interchanged with row IWORK(i). -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the -C singular values of G(lambda), except for the first one, -C which is returned in the function value AB13DX. -C If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last -C MIN(P,M)-1 zero singular values of G(lambda) are not -C stored in DWORK(2), ..., DWORK(MIN(P,M)). -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1, LDW1 + LDW2 ), -C LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0, -C DICO = 'C', and JOBD = 'Z'; -C LDW1 = 0, otherwise; -C LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)), -C if (N = 0, or B = 0, or C = 0) and JOBD = 'D', -C or (N > 0, B <> 0, C <> 0, OMEGA = 0, and -C DICO = 'C'); -C LDW2 = 0, if (N = 0, or B = 0, or C = 0) and JOBD = 'Z', -C or MIN(P,M) = 0; -C LDW2 = 6*MIN(P,M), otherwise. -C For good performance, LDWORK must generally be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) contains the optimal -C LCWORK. -C -C LCWORK INTEGER -C The dimension of the array CWORK. -C LCWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0 -C and DICO = 'C') or MIN(P,M) = 0; -C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), -C otherwise. -C For good performance, LCWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero; the LU -C factorization of the matrix lambda*E - A has been -C completed, but the factor U is exactly singular, -C i.e., the matrix lambda*E - A is exactly singular; -C = N+1: the SVD algorithm for computing singular values -C did not converge. -C -C METHOD -C -C The routine implements standard linear algebra calculations, -C taking problem structure into account. LAPACK Library routines -C DGESVD and ZGESVD are used for finding the singular values. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, system norm. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER DICO, JOBD, JOBE - INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, - $ M, N, P - DOUBLE PRECISION OMEGA -C .. -C .. Array Arguments .. - COMPLEX*16 CWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), E( LDE, * ) - INTEGER IWORK( * ) -C .. -C .. Local Scalars .. - LOGICAL DISCR, FULLE, NODYN, SPECL, WITHD - INTEGER I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J, - $ MAXWRK, MINCWR, MINPM, MINWRK - DOUBLE PRECISION BNORM, CNORM, LAMBDI, LAMBDR, UPD -C -C .. External Functions .. - DOUBLE PRECISION DLANGE - LOGICAL LSAME - EXTERNAL DLANGE, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ, - $ XERBLA, ZGEMM, ZGESVD, ZLACP2 -C .. -C .. Intrinsic Functions .. - INTRINSIC COS, DCMPLX, INT, MAX, MIN, SIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - FULLE = LSAME( JOBE, 'G' ) - WITHD = LSAME( JOBD, 'D' ) -C - IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -17 - ELSE - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) - NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO - SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR - MINPM = MIN( P, M ) -C -C Compute workspace. -C - IF( MINPM.EQ.0 ) THEN - MINWRK = 0 - ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN - MINWRK = MINPM + MAX( 3*MINPM + MAX( P, M ), 5*MINPM ) - IF ( SPECL .AND. .NOT.WITHD ) - $ MINWRK = MINWRK + P*M - ELSE IF ( NODYN .AND. .NOT.WITHD ) THEN - MINWRK = 0 - ELSE - MINWRK = 6*MINPM - END IF - MINWRK = MAX( 1, MINWRK ) -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -20 - ELSE - IF ( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR. - $ MINPM.EQ.0 ) THEN - MINCWR = 1 - ELSE - MINCWR = MAX( 1, ( N + M )*( N + P ) + - $ 2*MINPM + MAX( P, M ) ) - END IF - IF( LCWORK.LT.MINCWR ) - $ INFO = -22 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - AB13DX = ZERO - CALL XERBLA( 'AB13DX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MINPM.EQ.0 ) THEN - AB13DX = ZERO -C - DWORK( 1 ) = ONE - CWORK( 1 ) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IS = 1 - IWRK = IS + MINPM -C - IF( NODYN ) THEN -C -C No dynamics: Determine the maximum singular value of G = D . -C - IF ( WITHD ) THEN -C -C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), -C 5*MIN(P,M)); -C prefer larger. -C - CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, - $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = N + 1 - AB13DX = ZERO - RETURN - END IF - AB13DX = DWORK( IS ) - MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 - ELSE - AB13DX = ZERO - MAXWRK = 1 - END IF -C - DWORK( 1 ) = MAXWRK - CWORK( 1 ) = ONE - RETURN - END IF -C -C Determine the maximum singular value of -C G(lambda) = C*inv(lambda*E - A)*B + D. -C The (generalized) Hessenberg form of the system is used. -C - IF ( SPECL ) THEN -C -C Special continuous-time case: -C Determine the maximum singular value of the real matrix G(0). -C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), -C 5*MIN(P,M)); -C prefer larger. -C - CALL MB02SD( N, A, LDA, IWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR - DWORK( 1 ) = ONE - CWORK( 1 ) = ONE - AB13DX = ZERO - RETURN - END IF - CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB, - $ IERR ) - IF ( WITHD ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, - $ C, LDC, B, LDB, ONE, D, LDD ) - CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, - $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), - $ LDWORK-IWRK+1, IERR ) - ELSE -C -C Additional workspace: need P*M. -C - ID = IWRK - IWRK = ID + P*M - CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, - $ C, LDC, B, LDB, ZERO, DWORK( ID ), P ) - CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ), - $ P, DWORK( IS ), DWORK, P, DWORK, M, - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - END IF - IF( IERR.GT.0 ) THEN - INFO = N + 1 - AB13DX = ZERO - RETURN - END IF -C - AB13DX = DWORK( IS ) - DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1 - CWORK( 1 ) = ONE - RETURN - END IF -C -C General case: Determine the maximum singular value of G(lambda). -C Complex workspace: need N*N + N*M + P*N + P*M. -C - ICB = 1 + N*N - ICC = ICB + N*M - ICD = ICC + P*N - ICWK = ICD + P*M -C - IF ( WITHD ) THEN - UPD = ONE - ELSE - UPD = ZERO - END IF -C - IF ( DISCR ) THEN - LAMBDR = COS( OMEGA ) - LAMBDI = SIN( OMEGA ) -C -C Build lambda*E - A . -C - IF ( FULLE ) THEN -C - DO 20 J = 1, N -C - DO 10 I = 1, J - CWORK( I+(J-1)*N ) = - $ DCMPLX( LAMBDR*E( I, J ) - A( I, J ), - $ LAMBDI*E( I, J ) ) - 10 CONTINUE -C - IF( J.LT.N ) - $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) - 20 CONTINUE -C - ELSE -C - DO 40 J = 1, N -C - DO 30 I = 1, MIN( J+1, N ) - CWORK( I+(J-1)*N ) = -A( I, J ) - 30 CONTINUE -C - CWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI ) - 40 CONTINUE -C - END IF -C - ELSE -C -C Build j*omega*E - A. -C - IF ( FULLE ) THEN -C - DO 60 J = 1, N -C - DO 50 I = 1, J - CWORK( I+(J-1)*N ) = - $ DCMPLX( -A( I, J ), OMEGA*E( I, J ) ) - 50 CONTINUE -C - IF( J.LT.N ) - $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) - 60 CONTINUE -C - ELSE -C - DO 80 J = 1, N -C - DO 70 I = 1, MIN( J+1, N ) - CWORK( I+(J-1)*N ) = -A( I, J ) - 70 CONTINUE -C - CWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA ) - 80 CONTINUE -C - END IF -C - END IF -C -C Build G(lambda) . -C - CALL ZLACP2( 'Full', N, M, B, LDB, CWORK( ICB ), N ) - CALL ZLACP2( 'Full', P, N, C, LDC, CWORK( ICC ), P ) - IF ( WITHD ) - $ CALL ZLACP2( 'Full', P, M, D, LDD, CWORK( ICD ), P ) -C - CALL MB02SZ( N, CWORK, N, IWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR - DWORK( 1 ) = ONE - CWORK( 1 ) = ICWK - 1 - AB13DX = ZERO - RETURN - END IF - CALL MB02RZ( 'No Transpose', N, M, CWORK, N, IWORK, - $ CWORK( ICB ), N, IERR ) - CALL ZGEMM( 'No Transpose', 'No Transpose', P, M, N, CONE, - $ CWORK( ICC ), P, CWORK( ICB ), N, - $ DCMPLX( UPD, ZERO ), CWORK( ICD ), P ) -C -C Additional workspace, complex: need 2*MIN(P,M) + MAX(P,M); -C prefer larger; -C real: need 5*MIN(P,M). -C - CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, CWORK( ICD ), P, - $ DWORK( IS ), CWORK, P, CWORK, M, CWORK( ICWK ), - $ LCWORK-ICWK+1, DWORK( IWRK ), IERR ) - IF( IERR.GT.0 ) THEN - INFO = N + 1 - RETURN - END IF - AB13DX = DWORK( IS ) -C - DWORK( 1 ) = 6*MINPM - CWORK( 1 ) = INT( CWORK( ICWK ) ) + ICWK - 1 -C - RETURN -C *** Last line of AB13DX *** - END diff --git a/slycot/src/AB13ED.f b/slycot/src/AB13ED.f deleted file mode 100644 index 32033b73..00000000 --- a/slycot/src/AB13ED.f +++ /dev/null @@ -1,347 +0,0 @@ - SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate beta(A), the 2-norm distance from a real matrix A to -C the nearest complex matrix with an eigenvalue on the imaginary -C axis. The estimate is given as -C -C LOW <= beta(A) <= HIGH, -C -C where either -C -C (1 + TOL) * LOW >= HIGH, -C -C or -C -C LOW = 0 and HIGH = delta, -C -C and delta is a small number approximately equal to the square root -C of machine precision times the Frobenius norm (Euclidean norm) -C of A. If A is stable in the sense that all eigenvalues of A lie -C in the open left half complex plane, then beta(A) is the distance -C to the nearest unstable complex matrix, i.e., the complex -C stability radius. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C LOW (output) DOUBLE PRECISION -C A lower bound for beta(A). -C -C HIGH (output) DOUBLE PRECISION -C An upper bound for beta(A). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Specifies the accuracy with which LOW and HIGH approximate -C beta(A). If the user sets TOL to be less than SQRT(EPS), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH), then the tolerance is taken to be -C SQRT(EPS). -C The recommended value is TOL = 9, which gives an estimate -C of beta(A) correct to within an order of magnitude. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 3*N*(N+1) ). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm (LAPACK Library routine DHSEQR) -C fails to converge; this error is very rare. -C -C METHOD -C -C Let beta(A) be the 2-norm distance from a real matrix A to the -C nearest complex matrix with an eigenvalue on the imaginary axis. -C It is known that beta(A) = minimum of the smallest singular -C value of (A - jwI), where I is the identity matrix and j**2 = -1, -C and the minimum is taken over all real w. -C The algorithm computes a lower bound LOW and an upper bound HIGH -C for beta(A) by a bisection method in the following way. Given a -C non-negative real number sigma, the Hamiltonian matrix H(sigma) -C is constructed: -C -C | A -sigma*I | | A G | -C H(sigma) = | | := | | . -C | sigma*I -A' | | F -A' | -C -C It can be shown [1] that H(sigma) has an eigenvalue whose real -C part is zero if and only if sigma >= beta. Any lower and upper -C bounds on beta(A) can be improved by choosing a number between -C them and checking to see if H(sigma) has an eigenvalue with zero -C real part. This decision is made by computing the eigenvalues of -C H(sigma) using the square reduced algorithm of Van Loan [2]. -C -C REFERENCES -C -C [1] Byers, R. -C A bisection method for measuring the distance of a stable -C matrix to the unstable matrices. -C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. -C -C [2] Van Loan, C.F. -C A symplectic method for approximating all the eigenvalues of a -C Hamiltonian matrix. -C Linear Algebra and its Applications, Vol 61, 233-251, 1984. -C -C NUMERICAL ASPECTS -C -C Due to rounding errors the computed values of LOW and HIGH can be -C proven to satisfy -C -C LOW - p(n) * sqrt(e) * norm(A) <= beta(A) -C and -C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A), -C -C where p(n) is a modest polynomial of degree 3, e is the machine -C precision and norm(A) is the Frobenius norm of A, see [1]. -C The recommended value for TOL is 9 which gives an estimate of -C beta(A) correct to within an order of magnitude. -C AB13ED requires approximately 38*N**3 flops for TOL = 9. -C -C CONTRIBUTOR -C -C R. Byers, the routines BISEC and BISEC0 (January, 1995). -C -C REVISIONS -C -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. -C -C KEYWORDS -C -C Distances, eigenvalue, eigenvalue perturbation, norms, stability -C radius. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION HIGH, LOW, TOL - INTEGER INFO, LDA, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*) -C .. Local Scalars .. - INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR, - $ JWORK, MINWRK, N2 - DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2 - LOGICAL RNEG, SUFWRK -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, - $ DSYMV, MA02ED, MB04ZD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - MINWRK = 3*N*( N + 1 ) -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB13ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - LOW = ZERO - IF ( N.EQ.0 ) THEN - HIGH = ZERO - DWORK(1) = ONE - RETURN - END IF -C -C Indices for splitting the work array. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - N2 = N*N - IGF = 1 - IA2 = IGF + N2 + N - IAA = IA2 + N2 - IWK = IAA + N2 - IWR = IAA - IWI = IWR + N -C - SUFWRK = LDWORK-IWK.GE.N2 -C -C Computation of the tolerances and the treshold for termination of -C the bisection method. SEPS is the square root of the machine -C precision. -C - SFMN = DLAMCH( 'Safe minimum' ) - SEPS = SQRT( DLAMCH( 'Epsilon' ) ) - TAU = ONE + MAX( TOL, SEPS ) - ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - TOL1 = SEPS * ANRM - TOL2 = TOL1 * DBLE( 2*N ) -C -C Initialization of the bisection method. -C - HIGH = ANRM -C -C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO - 10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN - SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) ) -C -C Set up H(sigma). -C Workspace: N*(N+1)+2*N*N. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) - DWORK(IGF) = SIGMA - DWORK(IGF+N) = -SIGMA - DUMMY(1) = ZERO - CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) -C - DO 20 I = IGF, IA2 - N - 2, N + 1 - CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) - 20 CONTINUE -C -C Computation of the eigenvalues by the square reduced algorithm. -C Workspace: N*(N+1)+2*N*N+2*N. -C - CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, - $ DUMMY2, 1, DWORK(IWK), INFO ) -C -C Form the matrix A*A + F*G. -C Workspace: need N*(N+1)+2*N*N+N; -C prefer N*(N+1)+3*N*N. -C - JWORK = IA2 - IF ( SUFWRK ) - $ JWORK = IWK -C - CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) - CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) -C - IF ( SUFWRK ) THEN -C -C Use BLAS 3 calculation. -C - CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, - $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) - ELSE -C -C Use BLAS 2 calculation. -C - DO 30 I = 1, N - CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, - $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) - CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) - 30 CONTINUE -C - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, - $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) -C -C Find the eigenvalues of A*A + F*G. -C Workspace: N*(N+1)+N*N+3*N. -C - JWORK = IWI + N - CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), - $ I ) - CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, - $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, - $ DWORK(JWORK), N, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C -C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the -C squares of the eigenvalues of H(sigma). -C - I = 0 - RNEG = .FALSE. -C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive -C .AND. I < N ) DO - 40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN - TEMP = ABS( DWORK(IWI+I) ) - IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 - RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) ) - I = I + 1 - GO TO 40 -C END WHILE 40 - END IF - - IF ( RNEG ) THEN - HIGH = SIGMA - ELSE - LOW = SIGMA - END IF - GO TO 10 -C END WHILE 10 - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) ) -C -C *** Last line of AB13ED *** - END diff --git a/slycot/src/AB13FD.f b/slycot/src/AB13FD.f deleted file mode 100644 index 44628b47..00000000 --- a/slycot/src/AB13FD.f +++ /dev/null @@ -1,403 +0,0 @@ - SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, - $ CWORK, LCWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute beta(A), the 2-norm distance from a real matrix A to -C the nearest complex matrix with an eigenvalue on the imaginary -C axis. If A is stable in the sense that all eigenvalues of A lie -C in the open left half complex plane, then beta(A) is the complex -C stability radius, i.e., the distance to the nearest unstable -C complex matrix. The value of beta(A) is the minimum of the -C smallest singular value of (A - jwI), taken over all real w. -C The value of w corresponding to the minimum is also computed. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C BETA (output) DOUBLE PRECISION -C The computed value of beta(A), which actually is an upper -C bound. -C -C OMEGA (output) DOUBLE PRECISION -C The value of w such that the smallest singular value of -C (A - jwI) equals beta(A). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Specifies the accuracy with which beta(A) is to be -C calculated. (See the Numerical Aspects section below.) -C If the user sets TOL to be less than EPS, where EPS is the -C machine precision (see LAPACK Library Routine DLAMCH), -C then the tolerance is taken to be EPS. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C If DWORK(1) is not needed, the first 2*N*N entries of -C DWORK may overlay CWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 3*N*(N+2) ). -C For optimum performance LDWORK should be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0, CWORK(1) returns the optimal value -C of LCWORK. -C If CWORK(1) is not needed, the first N*N entries of -C CWORK may overlay DWORK. -C -C LCWORK INTEGER -C The length of the array CWORK. -C LCWORK >= MAX( 1, N*(N+3) ). -C For optimum performance LCWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the routine fails to compute beta(A) within the -C specified tolerance. Nevertheless, the returned -C value is an upper bound on beta(A); -C = 2: either the QR or SVD algorithm (LAPACK Library -C routines DHSEQR, DGESVD or ZGESVD) fails to -C converge; this error is very rare. -C -C METHOD -C -C AB13FD combines the methods of [1] and [2] into a provably -C reliable, quadratically convergent algorithm. It uses the simple -C bisection strategy of [1] to find an interval which contains -C beta(A), and then switches to the modified bisection strategy of -C [2] which converges quadratically to a minimizer. Note that the -C efficiency of the strategy degrades if there are several local -C minima that are near or equal the global minimum. -C -C REFERENCES -C -C [1] Byers, R. -C A bisection method for measuring the distance of a stable -C matrix to the unstable matrices. -C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. -C -C [2] Boyd, S. and Balakrishnan, K. -C A regularity result for the singular values of a transfer -C matrix and a quadratically convergent algorithm for computing -C its L-infinity norm. -C Systems and Control Letters, Vol. 15, pp. 1-7, 1990. -C -C NUMERICAL ASPECTS -C -C In the presence of rounding errors, the computed function value -C BETA satisfies -C -C beta(A) <= BETA + epsilon, -C -C BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)), -C -C where norm(A) is the Frobenius norm of A, -C -C epsilon = p(N) * EPS * norm(A), -C and -C delta = p(N) * SQRT(EPS) * norm(A), -C -C and p(N) is a low degree polynomial. It is recommended to choose -C TOL greater than SQRT(EPS). Although rounding errors can cause -C AB13FD to fail for smaller values of TOL, nevertheless, it usually -C succeeds. Regardless of success or failure, the first inequality -C holds. -C -C CONTRIBUTORS -C -C R. Byers, the routines QSEC and QSEC0 (January, 1995). -C -C REVISIONS -C -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2002, -C Jan. 2003. -C -C KEYWORDS -C -C complex stability radius, distances, eigenvalue, eigenvalue -C perturbation, norms. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 50 ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LCWORK, LDA, LDWORK, N - DOUBLE PRECISION BETA, OMEGA, TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*) - COMPLEX*16 CWORK(*) -C .. Local Scalars .. - INTEGER I, IA2, IAA, IGF, IHI, ILO, ITNUM, IWI, IWK, - $ IWR, JWORK, KOM, LBEST, MINWRK, N2 - DOUBLE PRECISION EPS, LOW, OM, OM1, OM2, SFMN, SIGMA, SV, TAU, - $ TEMP, TOL1 - LOGICAL SUFWRK -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, MB03NY - EXTERNAL DLAMCH, DLANGE, MB03NY -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, - $ DSYMV, MA02ED, MB04ZD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - MINWRK = 3*N*( N + 2 ) -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -8 - ELSE IF( LCWORK.LT.MAX( 1, N*( N + 3 ) ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB13FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - OMEGA = ZERO - IF ( N.EQ.0 ) THEN - BETA = ZERO - DWORK(1) = ONE - CWORK(1) = CONE - RETURN - END IF -C -C Indices for splitting the work array. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C - N2 = N*N - IGF = 1 - IA2 = IGF + N2 + N - IAA = IA2 + N2 - IWK = IAA + N2 - IWR = IAA - IWI = IWR + N -C - SUFWRK = LDWORK-IWK.GE.N2 -C -C Computation of the tolerances. EPS is the machine precision. -C - SFMN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Epsilon' ) - TOL1 = SQRT( EPS * DBLE( 2*N ) ) * - $ DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - TAU = ONE + MAX( TOL, EPS ) -C -C Initialization, upper bound at known critical point. -C Workspace: need N*(N+1)+5*N; prefer larger. -C - KOM = 2 - LOW = ZERO - CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) - BETA = MB03NY( N, OMEGA, DWORK(IGF), N, DWORK(IGF+N2), - $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - LBEST = MAX( MINWRK, INT( DWORK(IA2) ) - IA2 + 1, 4*N2 + N ) -C - ITNUM = 1 -C WHILE ( ITNUM <= MAXIT and BETA > TAU*MAX( TOL1, LOW ) ) DO - 10 IF ( ( ITNUM.LE.MAXIT ) .AND. - $ ( BETA.GT.TAU*MAX( TOL1, LOW ) ) ) THEN - IF ( KOM.EQ.2 ) THEN - SIGMA = BETA/TAU - ELSE - SIGMA = SQRT( BETA ) * SQRT( MAX( TOL1, LOW ) ) - END IF -C -C Set up H(sigma). -C Workspace: N*(N+1)+2*N*N. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) - DWORK(IGF) = SIGMA - DWORK(IGF+N) = -SIGMA - DUMMY(1) = ZERO - CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) -C - DO 20 I = IGF, IA2 - N - 2, N + 1 - CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) - 20 CONTINUE -C -C Computation of the eigenvalues by the square reduced algorithm. -C Workspace: N*(N+1)+2*N*N+2*N. -C - CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, - $ DUMMY2, 1, DWORK(IWK), INFO ) -C -C Form the matrix A*A + F*G. -C Workspace: need N*(N+1)+2*N*N+N; -C prefer N*(N+1)+3*N*N. -C - JWORK = IA2 - IF ( SUFWRK ) - $ JWORK = IWK -C - CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) - CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) -C - IF ( SUFWRK ) THEN -C -C Use BLAS 3 calculation. -C - CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, - $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) - ELSE -C -C Use BLAS 2 calculation. -C - DO 30 I = 1, N - CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, - $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) - CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) - 30 CONTINUE -C - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, - $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) -C -C Find the eigenvalues of A*A + F*G. -C Workspace: N*(N+1)+N*N+3*N. -C - JWORK = IWI + N - CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), - $ I ) - CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, - $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, - $ DWORK(JWORK), N, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Count negative real axis squared eigenvalues. If there are two, -C then the valley is isolated, and next approximate minimizer is -C mean of the square roots. -C - KOM = 0 - DO 40 I = 0, N - 1 - TEMP = ABS( DWORK(IWI+I) ) - IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 - IF ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL1 ) ) THEN - KOM = KOM + 1 - OM = SQRT( -DWORK(IWR+I) ) - IF ( KOM.EQ.1 ) OM1 = OM - IF ( KOM.EQ.2 ) OM2 = OM - END IF - 40 CONTINUE -C - IF ( KOM.EQ.0 ) THEN - LOW = SIGMA - ELSE -C -C In exact arithmetic KOM = 1 is impossible, but if tau is -C close enough to one, MB04ZD may miss the initial near zero -C eigenvalue. -C Workspace, real: need 3*N*(N+2); prefer larger; -C complex: need N*(N+3); prefer larger. -C - IF ( KOM.EQ.2 ) THEN - OM = OM1 + ( OM2 - OM1 ) / TWO - ELSE IF ( KOM.EQ.1 .AND. ITNUM.EQ.1 ) THEN - OM = OM1 / TWO - KOM = 2 - END IF -C - CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) - SV = MB03NY( N, OM, DWORK(IGF), N, DWORK(IGF+N2), - $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - IF ( BETA.GT.SV ) THEN - BETA = SV - OMEGA = OM - ELSE - INFO = 1 - RETURN - END IF - END IF - ITNUM = ITNUM + 1 - GO TO 10 -C END WHILE 10 - END IF -C - IF ( BETA .GT. TAU*MAX( TOL1, LOW ) ) THEN -C -C Failed to meet bounds within MAXIT iterations. -C - INFO = 1 - RETURN - END IF -C -C Set optimal real workspace dimension (complex workspace is already -C set by MB03NY). -C - DWORK(1) = LBEST -C - RETURN -C *** Last line of AB13FD *** - END diff --git a/slycot/src/AB13MD.f b/slycot/src/AB13MD.f deleted file mode 100644 index e0e0d472..00000000 --- a/slycot/src/AB13MD.f +++ /dev/null @@ -1,1782 +0,0 @@ - SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, - $ G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an upper bound on the structured singular value for a -C given square complex matrix and a given block structure of the -C uncertainty. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether or not an information from the -C previous call is supplied in the vector X. -C = 'F': On entry, X contains information from the -C previous call. -C = 'N': On entry, X does not contain an information from -C the previous call. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix Z. N >= 0. -C -C Z (input) COMPLEX*16 array, dimension (LDZ,N) -C The leading N-by-N part of this array must contain the -C complex matrix Z for which the upper bound on the -C structured singular value is to be computed. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= max(1,N). -C -C M (input) INTEGER -C The number of diagonal blocks in the block structure of -C the uncertainty. M >= 1. -C -C NBLOCK (input) INTEGER array, dimension (M) -C The vector of length M containing the block structure -C of the uncertainty. NBLOCK(I), I = 1:M, is the size of -C each block. -C -C ITYPE (input) INTEGER array, dimension (M) -C The vector of length M indicating the type of each block. -C For I = 1:M, -C ITYPE(I) = 1 indicates that the corresponding block is a -C real block, and -C ITYPE(I) = 2 indicates that the corresponding block is a -C complex block. -C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. -C -C X (input/output) DOUBLE PRECISION array, dimension -C ( M + MR - 1 ), where MR is the number of the real blocks. -C On entry, if FACT = 'F' and NBLOCK(1) < N, this array -C must contain information from the previous call to AB13MD. -C If NBLOCK(1) = N, this array is not used. -C On exit, if NBLOCK(1) < N, this array contains information -C that can be used in the next call to AB13MD for a matrix -C close to Z. -C -C BOUND (output) DOUBLE PRECISION -C The upper bound on the structured singular value. -C -C D, G (output) DOUBLE PRECISION arrays, dimension (N) -C The vectors of length N containing the diagonal entries -C of the diagonal N-by-N matrices D and G, respectively, -C such that the matrix -C Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2 -C is negative semidefinite. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(4*M-2,N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11. -C For best performance -C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 + -C MAX( 5*N,2*N*NB ) -C where NB is the optimal blocksize returned by ILAENV. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) contains the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The dimension of the array ZWORK. -C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3. -C For best performance -C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 + -C MAX( 3*N,N*NB ) -C where NB is the optimal blocksize returned by ILAENV. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the block sizes must be positive integers; -C = 2: the sum of block sizes must be equal to N; -C = 3: the size of a real block must be equal to 1; -C = 4: the block type must be either 1 or 2; -C = 5: errors in solving linear equations or in matrix -C inversion; -C = 6: errors in computing eigenvalues or singular values. -C -C METHOD -C -C The routine computes the upper bound proposed in [1]. -C -C REFERENCES -C -C [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C. -C Robustness in the presence of mixed parametric uncertainty -C and unmodeled dynamics. -C IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38. -C -C NUMERICAL ASPECTS -C -C The accuracy and speed of computation depend on the value of -C the internal threshold TOL. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, F. Delebecque, D.W. Gu, M.M. Konstantinov and -C S. Steer with the assistance of V. Sima, September 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Universiteit Leuven, February 2001. -C -C KEYWORDS -C -C H-infinity optimal control, Robust control, Structured singular -C value. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 CZERO, CONE, CIMAG - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ), - $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, FIVE, EIGHT, TEN, FORTY, - $ FIFTY - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, FIVE = 5.0D+0, EIGHT = 8.0D+0, - $ TEN = 1.0D+1, FORTY = 4.0D+1, FIFTY = 5.0D+1 - $ ) - DOUBLE PRECISION ALPHA, BETA, THETA - PARAMETER ( ALPHA = 100.0D+0, BETA = 1.0D-2, - $ THETA = 1.0D-2 ) - DOUBLE PRECISION C1, C2, C3, C4, C5, C6, C7, C8, C9 - PARAMETER ( C1 = 1.0D-3, C2 = 1.0D-2, C3 = 0.25D+0, - $ C4 = 0.9D+0, C5 = 1.5D+0, C6 = 1.0D+1, - $ C7 = 1.0D+2, C8 = 1.0D+3, C9 = 1.0D+4 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT - INTEGER INFO, LDWORK, LDZ, LZWORK, M, N - DOUBLE PRECISION BOUND -C .. -C .. Array Arguments .. - INTEGER ITYPE( * ), IWORK( * ), NBLOCK( * ) - COMPLEX*16 Z( LDZ, * ), ZWORK( * ) - DOUBLE PRECISION D( * ), DWORK( * ), G( * ), X( * ) -C .. -C .. Local Scalars .. - INTEGER I, INFO2, ISUM, ITER, IW2, IW3, IW4, IW5, IW6, - $ IW7, IW8, IW9, IW10, IW11, IW12, IW13, IW14, - $ IW15, IW16, IW17, IW18, IW19, IW20, IW21, IW22, - $ IW23, IW24, IW25, IW26, IW27, IW28, IW29, IW30, - $ IW31, IW32, IW33, IWRK, IZ2, IZ3, IZ4, IZ5, - $ IZ6, IZ7, IZ8, IZ9, IZ10, IZ11, IZ12, IZ13, - $ IZ14, IZ15, IZ16, IZ17, IZ18, IZ19, IZ20, IZ21, - $ IZ22, IZ23, IZ24, IZWRK, J, K, L, LWA, LWAMAX, - $ LZA, LZAMAX, MINWRK, MINZRK, MR, MT, NSUM, SDIM - COMPLEX*16 DETF, TEMPIJ, TEMPJI - DOUBLE PRECISION C, COLSUM, DELTA, DLAMBD, E, EMAX, EMIN, EPS, - $ HN, HNORM, HNORM1, PHI, PP, PROD, RAT, RCOND, - $ REGPAR, ROWSUM, SCALE, SNORM, STSIZE, SVLAM, - $ T1, T2, T3, TAU, TEMP, TOL, TOL2, TOL3, TOL4, - $ TOL5, YNORM1, YNORM2, ZNORM, ZNORM2 - LOGICAL GTEST, POS, XFACT -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions - DOUBLE PRECISION DDOT, DLAMCH, DLANGE, ZLANGE - LOGICAL LSAME, SELECT - EXTERNAL DDOT, DLAMCH, DLANGE, LSAME, SELECT, ZLANGE -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLACPY, DLASET, DSCAL, DSYCON, - $ DSYSV, DSYTRF, DSYTRS, XERBLA, ZCOPY, ZGEES, - $ ZGEMM, ZGEMV, ZGESVD, ZGETRF, ZGETRI, ZLACPY, - $ ZLASCL -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DCMPLX, DCONJG, DFLOAT, DREAL, INT, LOG, - $ MAX, SQRT -C .. -C .. Executable Statements .. -C -C Compute workspace. -C - MINWRK = 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11 - MINZRK = 6*N*N*M + 12*N*N + 6*M + 6*N - 3 -C -C Decode and Test input parameters. -C - INFO = 0 - XFACT = LSAME( FACT, 'F' ) - IF( .NOT.XFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( M.LT.1 ) THEN - INFO = -5 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -14 - ELSE IF( LZWORK.LT.MINZRK ) THEN - INFO = -16 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AB13MD', -INFO ) - RETURN - END IF -C - NSUM = 0 - ISUM = 0 - MR = 0 - DO 10 I = 1, M - IF( NBLOCK( I ).LT.1 ) THEN - INFO = 1 - RETURN - END IF - IF( ITYPE( I ).EQ.1 .AND. NBLOCK( I ).GT.1 ) THEN - INFO = 3 - RETURN - END IF - NSUM = NSUM + NBLOCK( I ) - IF( ITYPE( I ).EQ.1 ) MR = MR + 1 - IF( ITYPE( I ).EQ.1 .OR. ITYPE( I ).EQ.2 ) ISUM = ISUM + 1 - 10 CONTINUE - IF( NSUM.NE.N ) THEN - INFO = 2 - RETURN - END IF - IF( ISUM.NE.M ) THEN - INFO = 4 - RETURN - END IF - MT = M + MR - 1 -C - LWAMAX = 0 - LZAMAX = 0 -C -C Set D = In, G = 0. -C - CALL DLASET( 'Full', N, 1, ONE, ONE, D, N ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, G, N ) -C -C Quick return if possible. -C - ZNORM = ZLANGE( 'F', N, N, Z, LDZ, DWORK ) - IF( ZNORM.EQ.ZERO ) THEN - BOUND = ZERO - DWORK( 1 ) = ONE - ZWORK( 1 ) = CONE - RETURN - END IF -C -C Copy Z into ZWORK. -C - CALL ZLACPY( 'Full', N, N, Z, LDZ, ZWORK, N ) -C -C Exact bound for the case NBLOCK( 1 ) = N. -C - IF( NBLOCK( 1 ).EQ.N ) THEN - IF( ITYPE( 1 ).EQ.1 ) THEN -C -C 1-by-1 real block. -C - BOUND = ZERO - DWORK( 1 ) = ONE - ZWORK( 1 ) = CONE - ELSE -C -C N-by-N complex block. -C - CALL ZGESVD( 'N', 'N', N, N, ZWORK, N, DWORK, ZWORK, 1, - $ ZWORK, 1, ZWORK( N*N+1 ), LZWORK, - $ DWORK( N+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - BOUND = DWORK( 1 ) - LZA = N*N + INT( ZWORK( N*N+1 ) ) - DWORK( 1 ) = 5*N - ZWORK( 1 ) = DCMPLX( LZA ) - END IF - RETURN - END IF -C -C Get machine precision. -C - EPS = DLAMCH( 'P' ) -C -C Set tolerances. -C - TOL = C7*SQRT( EPS ) - TOL2 = C9*EPS - TOL3 = C6*EPS - TOL4 = C1 - TOL5 = C1 - REGPAR = C8*EPS -C -C Real workspace usage. -C - IW2 = M*M - IW3 = IW2 + M - IW4 = IW3 + N - IW5 = IW4 + M - IW6 = IW5 + M - IW7 = IW6 + N - IW8 = IW7 + N - IW9 = IW8 + N*( M - 1 ) - IW10 = IW9 + N*N*MT - IW11 = IW10 + MT - IW12 = IW11 + MT*MT - IW13 = IW12 + N - IW14 = IW13 + MT + 1 - IW15 = IW14 + MT + 1 - IW16 = IW15 + MT + 1 - IW17 = IW16 + MT + 1 - IW18 = IW17 + MT + 1 - IW19 = IW18 + MT - IW20 = IW19 + MT - IW21 = IW20 + MT - IW22 = IW21 + N - IW23 = IW22 + M - 1 - IW24 = IW23 + MR - IW25 = IW24 + N - IW26 = IW25 + 2*MT - IW27 = IW26 + MT - IW28 = IW27 + MT - IW29 = IW28 + M - 1 - IW30 = IW29 + MR - IW31 = IW30 + N + 2*MT - IW32 = IW31 + MT*MT - IW33 = IW32 + MT - IWRK = IW33 + MT + 1 -C -C Double complex workspace usage. -C - IZ2 = N*N - IZ3 = IZ2 + N*N - IZ4 = IZ3 + N*N - IZ5 = IZ4 + N*N - IZ6 = IZ5 + N*N - IZ7 = IZ6 + N*N*MT - IZ8 = IZ7 + N*N - IZ9 = IZ8 + N*N - IZ10 = IZ9 + N*N - IZ11 = IZ10 + MT - IZ12 = IZ11 + N*N - IZ13 = IZ12 + N - IZ14 = IZ13 + N*N - IZ15 = IZ14 + N - IZ16 = IZ15 + N*N - IZ17 = IZ16 + N - IZ18 = IZ17 + N*N - IZ19 = IZ18 + N*N*MT - IZ20 = IZ19 + MT - IZ21 = IZ20 + N*N*MT - IZ22 = IZ21 + N*N - IZ23 = IZ22 + N*N - IZ24 = IZ23 + N*N - IZWRK = IZ24 + MT -C -C Compute the cumulative sums of blocks dimensions. -C - IWORK( 1 ) = 0 - DO 20 I = 2, M+1 - IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 ) - 20 CONTINUE -C -C Find Osborne scaling if initial scaling is not given. -C - IF( .NOT.XFACT ) THEN - CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M ) - CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M ) - ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK ) - DO 40 J = 1, M - DO 30 I = 1, M - IF( I.NE.J ) THEN - CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ), - $ IWORK( J+1 )-IWORK( J ), - $ Z( IWORK( I )+1, IWORK( J )+1 ), LDZ, - $ ZWORK( IZ2+1 ), N ) - CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ), - $ IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ), - $ N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1, - $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - ZNORM2 = DWORK( IW3+1 ) - DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2 - END IF - 30 CONTINUE - 40 CONTINUE - CALL DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M ) - 50 DO 60 I = 1, M - DWORK( IW5+I ) = DWORK( IW4+I ) - ONE - 60 CONTINUE - HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK ) - IF( HNORM.LE.TOL2 ) GO TO 120 - DO 110 K = 1, M - COLSUM = ZERO - DO 70 I = 1, M - COLSUM = COLSUM + DWORK( I+(K-1)*M ) - 70 CONTINUE - ROWSUM = ZERO - DO 80 J = 1, M - ROWSUM = ROWSUM + DWORK( K+(J-1)*M ) - 80 CONTINUE - RAT = SQRT( COLSUM / ROWSUM ) - DWORK( IW4+K ) = RAT - DO 90 I = 1, M - DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT - 90 CONTINUE - DO 100 J = 1, M - DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT - 100 CONTINUE - DWORK( IW2+K ) = DWORK( IW2+K )*RAT - 110 CONTINUE - GO TO 50 - 120 SCALE = ONE / DWORK( IW2+1 ) - CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 ) - ELSE - DWORK( IW2+1 ) = ONE - DO 130 I = 2, M - DWORK( IW2+I ) = SQRT( X( I-1 ) ) - 130 CONTINUE - END IF - DO 150 J = 1, M - DO 140 I = 1, M - IF( I.NE.J ) THEN - CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ), - $ IWORK( I+1 )-IWORK( I ), - $ IWORK( J+1 )-IWORK( J ), - $ ZWORK( IWORK( I )+1+IWORK( J )*N ), N, - $ INFO2 ) - END IF - 140 CONTINUE - 150 CONTINUE -C -C Scale Z by its 2-norm. -C - CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N ) - CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ), - $ ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK, - $ DWORK( IWRK+1 ), INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - ZNORM = DWORK( IW3+1 ) - CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 ) -C -C Set BB. -C - CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N ) -C -C Set P. -C - DO 160 I = 1, NBLOCK( 1 ) - DWORK( IW6+I ) = ONE - 160 CONTINUE - DO 170 I = NBLOCK( 1 )+1, N - DWORK( IW6+I ) = ZERO - 170 CONTINUE -C -C Compute P*Z. -C - DO 190 J = 1, N - DO 180 I = 1, N - ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* - $ ZWORK( I+(J-1)*N ) - 180 CONTINUE - 190 CONTINUE -C -C Compute Z'*P*Z. -C - CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N, - $ CZERO, ZWORK( IZ4+1 ), N ) -C -C Copy Z'*P*Z into A0. -C - CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N ) -C -C Copy diag(P) into B0d. -C - CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 ) -C - DO 270 K = 2, M -C -C Set P. -C - DO 200 I = 1, IWORK( K ) - DWORK( IW6+I ) = ZERO - 200 CONTINUE - DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) - DWORK( IW6+I ) = ONE - 210 CONTINUE - IF( K.LT.M ) THEN - DO 220 I = IWORK( K+1 )+1, N - DWORK( IW6+I ) = ZERO - 220 CONTINUE - END IF -C -C Compute P*Z. -C - DO 240 J = 1, N - DO 230 I = 1, N - ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* - $ ZWORK( I+(J-1)*N ) - 230 CONTINUE - 240 CONTINUE -C -C Compute t = Z'*P*Z. -C - CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), - $ N, CZERO, ZWORK( IZ4+1 ), N ) -C -C Copy t(:) into the (k-1)-th column of AA. -C - CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ), - $ 1 ) -C -C Copy diag(P) into the (k-1)-th column of BBd. -C - CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 ) -C -C Copy P(:) into the (k-1)-th column of BB. -C - DO 260 I = 1, N - DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I ) - 260 CONTINUE - 270 CONTINUE -C - L = 0 -C - DO 350 K = 1, M - IF( ITYPE( K ).EQ.1 ) THEN - L = L + 1 -C -C Set P. -C - DO 280 I = 1, IWORK( K ) - DWORK( IW6+I ) = ZERO - 280 CONTINUE - DO 290 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) - DWORK( IW6+I ) = ONE - 290 CONTINUE - IF( K.LT.M ) THEN - DO 300 I = IWORK( K+1 )+1, N - DWORK( IW6+I ) = ZERO - 300 CONTINUE - END IF -C -C Compute P*Z. -C - DO 320 J = 1, N - DO 310 I = 1, N - ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* - $ ZWORK( I+(J-1)*N ) - 310 CONTINUE - 320 CONTINUE -C -C Compute t = sqrt(-1)*( P*Z - Z'*P ). -C - DO 340 J = 1, N - DO 330 I = 1, J - TEMPIJ = ZWORK( IZ3+I+(J-1)*N ) - TEMPJI = ZWORK( IZ3+J+(I-1)*N ) - ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ - - $ DCONJG( TEMPJI ) ) - ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI - - $ DCONJG( TEMPIJ ) ) - 330 CONTINUE - 340 CONTINUE -C -C Copy t(:) into the (m-1+l)-th column of AA. -C - CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, - $ ZWORK( IZ6+1+(M-2+L)*N*N ), 1 ) - END IF - 350 CONTINUE -C -C Set initial X. -C - DO 360 I = 1, M - 1 - X( I ) = ONE - 360 CONTINUE - IF( MR.GT.0 ) THEN - IF( .NOT.XFACT ) THEN - DO 370 I = 1, MR - X( M-1+I ) = ZERO - 370 CONTINUE - ELSE - L = 0 - DO 380 K = 1, M - IF( ITYPE( K ).EQ.1 ) THEN - L = L + 1 - X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2 - END IF - 380 CONTINUE - END IF - END IF -C -C Set constants. -C - SVLAM = ONE / EPS - C = ONE -C -C Set H. -C - CALL DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT ) -C - ITER = -1 -C -C Main iteration loop. -C - 390 ITER = ITER + 1 -C -C Compute A(:) = A0 + AA*x. -C - DO 400 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 400 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( Binv ). -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, - $ DWORK( IW12+1 ), 1 ) - DO 410 I = 1, N - DWORK( IW12+I ) = ONE / DWORK( IW12+I ) - 410 CONTINUE -C -C Compute Binv*A. -C - DO 430 J = 1, N - DO 420 I = 1, N - ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )* - $ ZWORK( IZ7+I+(J-1)*N ) - 420 CONTINUE - 430 CONTINUE -C -C Compute eig( Binv*A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM, - $ ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - E = DREAL( ZWORK( IZ12+1 ) ) - IF( N.GT.1 ) THEN - DO 440 I = 2, N - IF( DREAL( ZWORK( IZ12+I ) ).GT.E ) - $ E = DREAL( ZWORK( IZ12+I ) ) - 440 CONTINUE - END IF -C -C Set tau. -C - IF( MR.GT.0 ) THEN - SNORM = ABS( X( M ) ) - IF( MR.GT.1 ) THEN - DO 450 I = M+1, MT - IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) ) - 450 CONTINUE - END IF - IF( SNORM.GT.FORTY ) THEN - TAU = C7 - ELSE IF( SNORM.GT.EIGHT ) THEN - TAU = FIFTY - ELSE IF( SNORM.GT.FOUR ) THEN - TAU = TEN - ELSE IF( SNORM.GT.ONE ) THEN - TAU = FIVE - ELSE - TAU = TWO - END IF - END IF - IF( ITER.EQ.0 ) THEN - DLAMBD = E + C1 - ELSE - DWORK( IW13+1 ) = E - CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) - DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) + - $ THETA*DWORK( IW14+1 ) - CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 ) - CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 ) - L = 0 - 460 DO 470 I = 1, MT - X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) + - $ ( THETA / TWO**L )*DWORK( IW19+I ) - 470 CONTINUE -C -C Compute At(:) = A0 + AA*x. -C - DO 480 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 480 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 ) -C -C Compute diag(Bt). -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, - $ DWORK( IW21+1 ), 1 ) -C -C Compute W. -C - DO 500 J = 1, N - DO 490 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA* - $ ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO - - $ DLAMBD*DWORK( IW21+I ) ) + - $ ZWORK( IZ9+I+(I-1)*N ) - ELSE - ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N ) - END IF - 490 CONTINUE - 500 CONTINUE -C -C Compute eig( W ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM, - $ ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMAX = DREAL( ZWORK( IZ14+1 ) ) - IF( N.GT.1 ) THEN - DO 510 I = 2, N - IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX ) - $ EMAX = DREAL( ZWORK( IZ14+I ) ) - 510 CONTINUE - END IF - IF( EMAX.LE.ZERO ) THEN - GO TO 515 - ELSE - L = L + 1 - GO TO 460 - END IF - END IF -C -C Set y. -C - 515 DWORK( IW13+1 ) = DLAMBD - CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) -C - IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN - BOUND = SQRT( MAX( E, ZERO ) )*ZNORM - DO 520 I = 1, M - 1 - X( I ) = X( I )*DWORK( IW2+I+1 )**2 - 520 CONTINUE -C -C Compute sqrt( x ). -C - DO 530 I = 1, M-1 - DWORK( IW20+I ) = SQRT( X( I ) ) - 530 CONTINUE -C -C Compute diag( D ). -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW20+1 ), 1, ONE, D, 1 ) -C -C Compute diag( G ). -C - J = 0 - L = 0 - DO 540 K = 1, M - J = J + NBLOCK( K ) - IF( ITYPE( K ).EQ.1 ) THEN - L = L + 1 - X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2 - G( J ) = X( M-1+L ) - END IF - 540 CONTINUE - CALL DSCAL( N, ZNORM, G, 1 ) - DWORK( 1 ) = DFLOAT( MINWRK - 5*N + LWAMAX ) - ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX ) - RETURN - END IF - SVLAM = DLAMBD - DO 800 K = 1, M -C -C Store xD. -C - CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*x. -C - DO 550 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 550 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute B = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute F. -C - DO 556 J = 1, N - DO 555 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 555 CONTINUE - 556 CONTINUE - CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, - $ ZWORK( IZ17+1 ), N ) -C -C Compute det( F ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - DETF = CONE - DO 560 I = 1, N - DETF = DETF*ZWORK( IZ16+I ) - 560 CONTINUE -C -C Compute Finv. -C - CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) -C -C Compute phi. -C - DO 570 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 570 CONTINUE - IF( MR.GT.0 ) THEN - DO 580 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 580 CONTINUE - END IF - PROD = ONE - DO 590 I = 1, 2*MT - PROD = PROD*DWORK( IW25+I ) - 590 CONTINUE - TEMP = DREAL( DETF ) - IF( TEMP.LT.EPS ) TEMP = EPS - PHI = -LOG( TEMP ) - LOG( PROD ) -C -C Compute g. -C - DO 610 J = 1, MT - DO 600 I = 1, N*N - ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* - $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) - 600 CONTINUE - 610 CONTINUE - CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, - $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) - DO 620 I = 1, M-1 - DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - - $ ONE / ( ALPHA - DWORK( IW22+I ) ) - 620 CONTINUE - IF( MR.GT.0 ) THEN - DO 630 I = 1, MR - DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) - $ -ONE / ( TAU - DWORK( IW23+I ) ) - 630 CONTINUE - END IF - DO 640 I = 1, MT - DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - - $ DWORK( IW26+I ) - 640 CONTINUE -C -C Compute h. -C - CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, - $ DWORK( IW31+1 ), MT ) - CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IW27+1 ), MT, DWORK( IWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) - LWAMAX = MAX( LWA, LWAMAX ) - STSIZE = ONE -C -C Store hD. -C - CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 ) -C -C Determine stepsize. -C - L = 0 - DO 650 I = 1, M-1 - IF( DWORK( IW28+I ).GT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I ) - ELSE - TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) / - $ DWORK( IW28+I ) ) - END IF - END IF - 650 CONTINUE - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - L = 0 - DO 660 I = 1, M-1 - IF( DWORK( IW28+I ).LT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( ALPHA - DWORK( IW22+I ) ) / - $ ( -DWORK( IW28+I ) ) - ELSE - TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) / - $ ( -DWORK( IW28+I ) ) ) - END IF - END IF - 660 CONTINUE - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - IF( MR.GT.0 ) THEN -C -C Store hG. -C - CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 ) -C -C Determine stepsize. -C - L = 0 - DO 670 I = 1, MR - IF( DWORK( IW29+I ).GT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( DWORK( IW23+I ) + TAU ) / - $ DWORK( IW29+I ) - ELSE - TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) / - $ DWORK( IW29+I ) ) - END IF - END IF - 670 CONTINUE - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - L = 0 - DO 680 I = 1, MR - IF( DWORK( IW29+I ).LT.ZERO ) THEN - L = L + 1 - IF( L.EQ.1 ) THEN - TEMP = ( TAU - DWORK( IW23+I ) ) / - $ ( -DWORK( IW29+I ) ) - ELSE - TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) / - $ ( -DWORK( IW29+I ) ) ) - END IF - END IF - 680 CONTINUE - END IF - IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) - STSIZE = C4*STSIZE - IF( STSIZE.GE.TOL4 ) THEN -C -C Compute x_new. -C - DO 700 I = 1, MT - DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I ) - 700 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), - $ 1 ) - END IF -C -C Compute A(:) = A0 + AA*x_new. -C - DO 710 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) - 710 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute B = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute lambda*diag(B) - A. -C - DO 730 J = 1, N - DO 720 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = - $ -ZWORK( IZ7+I+(J-1)*N ) - END IF - 720 CONTINUE - 730 CONTINUE -C -C Compute eig( lambda*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, - $ SDIM, ZWORK( IZ16+1 ), ZWORK, N, - $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, - $ DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 740 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 740 CONTINUE - END IF - DO 750 I = 1, N - DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) - 750 CONTINUE - DO 760 I = 1, M-1 - DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA - DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) - 760 CONTINUE - IF( MR.GT.0 ) THEN - DO 770 I = 1, MR - DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - - $ DWORK( IW23+I ) - 770 CONTINUE - END IF - PROD = ONE - DO 780 I = 1, N+2*MT - PROD = PROD*DWORK( IW30+I ) - 780 CONTINUE - IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN - STSIZE = STSIZE / TEN - ELSE - CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 ) - END IF - END IF - IF( STSIZE.LT.TOL4 ) GO TO 810 - 800 CONTINUE -C - 810 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*x. -C - DO 820 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( X( I ) ) - 820 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute F. -C - DO 840 J = 1, N - DO 830 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 830 CONTINUE - 840 CONTINUE - CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, - $ ZWORK( IZ17+1 ), N ) -C -C Compute det( F ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - DETF = CONE - DO 850 I = 1, N - DETF = DETF*ZWORK( IZ16+I ) - 850 CONTINUE -C -C Compute Finv. -C - CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) -C -C Compute the barrier function. -C - DO 860 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 860 CONTINUE - IF( MR.GT.0 ) THEN - DO 870 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 870 CONTINUE - END IF - PROD = ONE - DO 880 I = 1, 2*MT - PROD = PROD*DWORK( IW25+I ) - 880 CONTINUE - TEMP = DREAL( DETF ) - IF( TEMP.LT.EPS ) TEMP = EPS - PHI = -LOG( TEMP ) - LOG( PROD ) -C -C Compute the gradient of the barrier function. -C - DO 900 J = 1, MT - DO 890 I = 1, N*N - ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* - $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) - 890 CONTINUE - 900 CONTINUE - CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, - $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) - DO 910 I = 1, M-1 - DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - - $ ONE / ( ALPHA - DWORK( IW22+I ) ) - 910 CONTINUE - IF( MR.GT.0 ) THEN - DO 920 I = 1, MR - DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) - $ -ONE / ( TAU - DWORK( IW23+I ) ) - 920 CONTINUE - END IF - DO 925 I = 1, MT - DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - - $ DWORK( IW26+I ) - 925 CONTINUE -C -C Compute the Hessian of the barrier function. -C - CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N, - $ ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N ) - - CALL DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ), - $ MT ) - DO 960 K = 1, MT - CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1, - $ ZWORK( IZ22+1 ), 1 ) - DO 940 J = 1, N - DO 930 I = 1, N - ZWORK( IZ23+I+(J-1)*N ) = - $ DCONJG( ZWORK( IZ22+J+(I-1)*N ) ) - 930 CONTINUE - 940 CONTINUE - CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N, - $ ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ), - $ 1 ) - DO 950 J = 1, K - DWORK( IW11+K+(J-1)*MT ) = - $ DREAL( DCONJG( ZWORK( IZ24+J ) ) ) - 950 CONTINUE - 960 CONTINUE - DO 970 I = 1, M-1 - DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 + - $ ONE / ( ALPHA - DWORK( IW22+I ) )**2 - 970 CONTINUE - IF( MR.GT.0 ) THEN - DO 980 I = 1, MR - DWORK( IW10+M-1+I ) = - $ ONE / ( DWORK( IW23+I ) + TAU )**2 + - $ ONE / ( TAU - DWORK( IW23+I ) )**2 - 980 CONTINUE - END IF - DO 990 I = 1, MT - DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + - $ DWORK( IW10+I ) - 990 CONTINUE - DO 1100 J = 1, MT - DO 1000 I = 1, J - IF( I.NE.J ) THEN - T1 = DWORK( IW11+I+(J-1)*MT ) - T2 = DWORK( IW11+J+(I-1)*MT ) - DWORK( IW11+I+(J-1)*MT ) = T1 + T2 - DWORK( IW11+J+(I-1)*MT ) = T1 + T2 - END IF - 1000 CONTINUE - 1100 CONTINUE -C -C Compute norm( H ). -C - 1110 HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK ) -C -C Compute rcond( H ). -C - CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, - $ DWORK( IW31+1 ), MT ) - HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK ) - CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) - LWAMAX = MAX( LWA, LWAMAX ) - CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1, - $ RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 ) - IF( RCOND.LT.TOL3 ) THEN - DO 1120 I = 1, MT - DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + - $ HNORM*REGPAR - 1120 CONTINUE - GO TO 1110 - END IF -C -C Compute the tangent line to path of center. -C - CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IW27+1 ), MT, INFO2 ) -C -C Check if x-h satisfies the Goldstein test. -C - GTEST = .FALSE. - DO 1130 I = 1, MT - DWORK( IW20+I ) = X( I ) - DWORK( IW27+I ) - 1130 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*x_new. -C - DO 1140 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) - 1140 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute lambda*diag(B) - A. -C - DO 1160 J = 1, N - DO 1150 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1150 CONTINUE - 1160 CONTINUE -C -C Compute eig( lambda*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - DO 1190 I = 1, N - DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) - 1190 CONTINUE - DO 1200 I = 1, M-1 - DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA - DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1200 CONTINUE - IF( MR.GT.0 ) THEN - DO 1210 I = 1, MR - DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1210 CONTINUE - END IF - EMIN = DWORK( IW30+1 ) - DO 1220 I = 1, N+2*MT - IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I ) - 1220 CONTINUE - IF( EMIN.LE.ZERO ) THEN - GTEST = .FALSE. - ELSE - PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - PROD = ONE - DO 1230 I = 1, N+2*MT - PROD = PROD*DWORK( IW30+I ) - 1230 CONTINUE - T1 = -LOG( PROD ) - T2 = PHI - C2*PP - T3 = PHI - C4*PP - IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE. - END IF -C -C Use x-h if Goldstein test is satisfied. Otherwise use -C Nesterov-Nemirovsky's stepsize length. -C - PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) - DELTA = SQRT( PP ) - IF( GTEST .OR. DELTA.LE.C3 ) THEN - DO 1240 I = 1, MT - X( I ) = X( I ) - DWORK( IW27+I ) - 1240 CONTINUE - ELSE - DO 1250 I = 1, MT - X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA ) - 1250 CONTINUE - END IF -C -C Analytic center is found if delta is sufficiently small. -C - IF( DELTA.LT.TOL5 ) GO TO 1260 - GO TO 810 -C -C Set yf. -C - 1260 DWORK( IW14+1 ) = DLAMBD - CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 ) -C -C Set yw. -C - CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 ) -C -C Compute Fb. -C - DO 1280 J = 1, N - DO 1270 I = 1, N - ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )* - $ DCONJG( ZWORK( IZ17+J+(I-1)*N ) ) - 1270 CONTINUE - 1280 CONTINUE - CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N, - $ ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 ) - DO 1300 I = 1, MT - DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) ) - 1300 CONTINUE -C -C Compute h1. -C - CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, - $ DWORK( IW31+1 ), MT ) - CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, - $ DWORK( IW32+1 ), MT, DWORK( IWRK+1 ), - $ LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) - LWAMAX = MAX( LWA, LWAMAX ) -C -C Compute hn. -C - HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK ) -C -C Compute y. -C - DWORK( IW13+1 ) = DLAMBD - C / HN - DO 1310 I = 1, MT - DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN - 1310 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*y(2:mt+1). -C - DO 1320 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) - 1320 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute B = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute y(1)*diag(B) - A. -C - DO 1340 J = 1, N - DO 1330 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1330 CONTINUE - 1340 CONTINUE -C -C Compute eig( y(1)*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 1350 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 1350 CONTINUE - END IF - POS = .TRUE. - DO 1360 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1360 CONTINUE - IF( MR.GT.0 ) THEN - DO 1370 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1370 CONTINUE - END IF - TEMP = DWORK( IW25+1 ) - DO 1380 I = 2, 2*MT - IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) - 1380 CONTINUE - IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. - 1390 IF( POS ) THEN -C -C Set y2 = y. -C - CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 ) -C -C Compute y = y + 1.5*( y - yw ). -C - DO 1400 I = 1, MT+1 - DWORK( IW13+I ) = DWORK( IW13+I ) + - $ C5*( DWORK( IW13+I ) - DWORK( IW15+I ) ) - 1400 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, - $ DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*y(2:mt+1). -C - DO 1420 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) - 1420 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Set yw = y2. -C - CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 ) -C -C Compute y(1)*diag(B) - A. -C - DO 1440 J = 1, N - DO 1430 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1430 CONTINUE - 1440 CONTINUE -C -C Compute eig( y(1)*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 1450 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 1450 CONTINUE - END IF - POS = .TRUE. - DO 1460 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1460 CONTINUE - IF( MR.GT.0 ) THEN - DO 1470 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1470 CONTINUE - END IF - TEMP = DWORK( IW25+1 ) - DO 1480 I = 2, 2*MT - IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) - 1480 CONTINUE - IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. - GO TO 1390 - END IF - 1490 CONTINUE -C -C Set y1 = ( y + yw ) / 2. -C - DO 1500 I = 1, MT+1 - DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) ) - $ / TWO - 1500 CONTINUE -C -C Store xD. -C - CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 ) - IF( MR.GT.0 ) THEN -C -C Store xG. -C - CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 ) - END IF -C -C Compute A(:) = A0 + AA*y1(2:mt+1). -C - DO 1510 I = 1, MT - ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) ) - 1510 CONTINUE - CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) - CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, - $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) -C -C Compute diag( B ) = B0d + BBd*xD. -C - CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) - CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, - $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) -C -C Compute y1(1)*diag(B) - A. -C - DO 1530 J = 1, N - DO 1520 I = 1, N - IF( I.EQ.J ) THEN - ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )* - $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) - ELSE - ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) - END IF - 1520 CONTINUE - 1530 CONTINUE -C -C Compute eig( y1(1)*diag(B)-A ). -C - CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, - $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), - $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LZA = INT( ZWORK( IZWRK+1 ) ) - LZAMAX = MAX( LZA, LZAMAX ) - EMIN = DREAL( ZWORK( IZ16+1 ) ) - IF( N.GT.1 ) THEN - DO 1540 I = 2, N - IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) - $ EMIN = DREAL( ZWORK( IZ16+I ) ) - 1540 CONTINUE - END IF - POS = .TRUE. - DO 1550 I = 1, M-1 - DWORK( IW25+I ) = DWORK( IW22+I ) - BETA - DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) - 1550 CONTINUE - IF( MR.GT.0 ) THEN - DO 1560 I = 1, MR - DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU - DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) - 1560 CONTINUE - END IF - TEMP = DWORK( IW25+1 ) - DO 1570 I = 2, 2*MT - IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) - 1570 CONTINUE - IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. - IF( POS ) THEN -C -C Set yw = y1. -C - CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 ) - ELSE -C -C Set y = y1. -C - CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 ) - END IF - DO 1580 I = 1, MT+1 - DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I ) - 1580 CONTINUE - YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) - DO 1590 I = 1, MT+1 - DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I ) - 1590 CONTINUE - YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) - IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600 - GO TO 1490 -C -C Compute c. -C - 1600 DO 1610 I = 1, MT+1 - DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I ) - 1610 CONTINUE - C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) -C -C Set x = yw(2:mt+1). -C - CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 ) - GO TO 390 -C -C *** Last line of AB13MD *** - END diff --git a/slycot/src/AB8NXZ.f b/slycot/src/AB8NXZ.f deleted file mode 100644 index a0976d23..00000000 --- a/slycot/src/AB8NXZ.f +++ /dev/null @@ -1,458 +0,0 @@ - SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, - $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, - $ DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) system -C ( B A ) -C ( D C ) -C an (NU+MU)-by-(M+NU) "reduced" system -C ( B' A') -C ( D' C') -C having the same transmission zeros but with D' of full row rank. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of state variables. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C RO (input/output) INTEGER -C On entry, -C = P for the original system; -C = MAX(P-M, 0) for the pertransposed system. -C On exit, RO contains the last computed rank. -C -C SIGMA (input/output) INTEGER -C On entry, -C = 0 for the original system; -C = M for the pertransposed system. -C On exit, SIGMA contains the last computed value sigma in -C the algorithm. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound input matrix of the system. -C On exit, the leading (NU+MU)-by-(M+NU) part of this array -C contains the reduced compound input matrix of the system. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C NINFZ (input/output) INTEGER -C On entry, the currently computed number of infinite zeros. -C It should be initialized to zero on the first call. -C NINFZ >= 0. -C On exit, the number of infinite zeros. -C -C INFZ (input/output) INTEGER array, dimension (N) -C On entry, INFZ(i) must contain the current number of -C infinite zeros of degree i, where i = 1,2,...,N, found in -C the previous call(s) of the routine. It should be -C initialized to zero on the first call. -C On exit, INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,N. -C -C KRONL (input/output) INTEGER array, dimension (N+1) -C On entry, this array must contain the currently computed -C left Kronecker (row) indices found in the previous call(s) -C of the routine. It should be initialized to zero on the -C first call. -C On exit, the leading NKROL elements of this array contain -C the left Kronecker (row) indices. -C -C MU (output) INTEGER -C The normal rank of the transfer function matrix of the -C original system. -C -C NU (output) INTEGER -C The dimension of the reduced system matrix and the number -C of (finite) invariant zeros if D' is invertible. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), -C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Svaricek, F. -C Computation of the Structural Invariants of Linear -C Multivariable Systems with an Extended Version of -C the Program ZEROS. -C System & Control Letters, 6, pp. 261-266, 1985. -C -C [2] Emami-Naeini, A. and Van Dooren, P. -C Computation of Zeros of Linear Multivariable Systems. -C Automatica, 18, pp. 415-430, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008 with suggestions from P. Gahinet, -C The MathWorks. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION DZERO - PARAMETER ( DZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDABCD, LZWORK, M, MU, N, NINFZ, NKROL, - $ NU, P, RO, SIGMA - DOUBLE PRECISION SVLMAX, TOL -C .. Array Arguments .. - INTEGER INFZ(*), IWORK(*), KRONL(*) - COMPLEX*16 ABCD(LDABCD,*), ZWORK(*) - DOUBLE PRECISION DWORK(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, - $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT - COMPLEX*16 TC, TCCONJ -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL MB3OYZ, MB3PYZ, XERBLA, ZLAPMT, ZLARFG, ZLASET, - $ SLCT_ZLATZM, ZUNMQR, ZUNMRQ -C .. Intrinsic Functions .. - INTRINSIC DCONJG, INT, MAX, MIN -C .. Executable Statements .. -C - NP = N + P - MPM = MIN( P, M ) - INFO = 0 - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN - INFO = -4 - ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.DZERO ) THEN - INFO = -6 - ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN - INFO = -8 - ELSE IF( NINFZ.LT.0 ) THEN - INFO = -9 - ELSE - JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), - $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) - IF( LQUERY ) THEN - IF( M.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, MPM, - $ -1 ) ) - WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) - ELSE - WRKOPT = JWORK - END IF - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', NP, N, MIN( P, N ), - $ -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'LN', N, M+N, - $ MIN( P, N ), -1 ) ) - WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) - ELSE IF( LZWORK.LT.JWORK ) THEN - INFO = -19 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AB8NXZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C - MU = P - NU = N -C - IZ = 0 - IK = 1 - MM1 = M + 1 - ITAU = 1 - NKROL = 0 - WRKOPT = 1 -C -C Main reduction loop: -C -C M NU M NU -C NU [ B A ] NU [ B A ] -C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = -C TAU [ 0 C2 ] row size of RD) -C -C M NU-RO RO -C NU-RO [ B1 A11 A12 ] -C --> RO [ B2 A21 A22 ] (RO = rank(C2) = -C SIGMA [ RD C11 C12 ] col size of LC) -C TAU [ 0 0 LC ] -C -C M NU-RO -C NU-RO [ B1 A11 ] NU := NU - RO -C [----------] MU := RO + SIGMA -C --> RO [ B2 A21 ] D := [B2;RD] -C SIGMA [ RD C11 ] C := [A21;C11] -C - 20 IF ( MU.EQ.0 ) - $ GO TO 80 -C -C (Note: Comments in the code beginning "xWorkspace:", where x is -C I, D, or C, describe the minimal amount of integer, real and -C complex workspace needed at that point in the code, respectively, -C as well as the preferred amount for good performance.) -C - RO1 = RO - MNU = M + NU - IF ( M.GT.0 ) THEN - IF ( SIGMA.NE.0 ) THEN - IROW = NU + 1 -C -C Compress rows of D. First exploit triangular shape. -C CWorkspace: need M+N-1. -C - DO 40 I1 = 1, SIGMA - CALL ZLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, - $ TC ) -C RvP 170623 slicot-specific ZLATZM - TCCONJ = DCONJG( TC ) - CALL SLCT_ZLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, - $ DCONJG( TC ), ABCD(IROW,I1+1), - $ ABCD(IROW+1,I1+1), LDABCD, ZWORK ) - IROW = IROW + 1 - 40 CONTINUE - CALL ZLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, - $ ABCD(NU+2,1), LDABCD ) - END IF -C -C Continue with Householder with column pivoting. -C -C The rank of D is the number of (estimated) singular values -C that are greater than TOL * MAX(SVLMAX,EMSV). This number -C includes the singular values of the first SIGMA columns. -C IWorkspace: need M; -C RWorkspace: need 2*M; -C CWorkspace: need min(RO1,M) + 3*M - 1. RO1 <= P. -C - IF ( SIGMA.LT.M ) THEN - JWORK = ITAU + MIN( RO1, M ) - I1 = SIGMA + 1 - IROW = NU + I1 - CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, - $ SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), DWORK, - $ ZWORK(JWORK), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) -C -C Apply the column permutations to matrices B and part of D. -C - CALL ZLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, - $ IWORK ) -C - IF ( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C CWorkspace: need min(RO1,M) + NU; -C prefer min(RO1,M) + NU*NB. -C - CALL ZUNMQR( 'Left', 'Conjugate', RO1, NU, RANK, - $ ABCD(IROW,I1), LDABCD, ZWORK(ITAU), - $ ABCD(IROW,MM1), LDABCD, ZWORK(JWORK), - $ LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) - IF ( RO1.GT.1 ) - $ CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, - $ ZERO, ABCD(IROW+1,I1), LDABCD ) - RO1 = RO1 - RANK - END IF - END IF - END IF -C - TAU = RO1 - SIGMA = MU - TAU -C -C Determination of the orders of the infinite zeros. -C - IF ( IZ.GT.0 ) THEN - INFZ(IZ) = INFZ(IZ) + RO - TAU - NINFZ = NINFZ + IZ*( RO - TAU ) - END IF - IF ( RO1.EQ.0 ) - $ GO TO 80 - IZ = IZ + 1 -C - IF ( NU.LE.0 ) THEN - MU = SIGMA - NU = 0 - RO = 0 - ELSE -C -C Compress the columns of C2 using RQ factorization with row -C pivoting, P * C2 = R * Q. -C - I1 = NU + SIGMA + 1 - MNTAU = MIN( TAU, NU ) - JWORK = ITAU + MNTAU -C -C The rank of C2 is the number of (estimated) singular values -C greater than TOL * MAX(SVLMAX,EMSV). -C IWorkspace: need TAU; -C RWorkspace: need 2*TAU; -C CWorkspace: need min(TAU,NU) + 3*TAU - 1. -C - CALL MB3PYZ( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, - $ SVAL, IWORK, ZWORK(ITAU), DWORK, ZWORK(JWORK), - $ INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) - IF ( RANK.GT.0 ) THEN - IROW = I1 + TAU - RANK -C -C Apply Q' to the first NU columns of [A; C1] from the right. -C CWorkspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; -C prefer min(TAU,NU) + (NU + SIGMA)*NB. -C - CALL ZUNMRQ( 'Right', 'ConjTranspose', I1-1, NU, RANK, - $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), - $ ABCD(1,MM1), LDABCD, ZWORK(JWORK), - $ LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C Apply Q to the first NU rows and M + NU columns of [ B A ] -C from the left. -C CWorkspace: need min(TAU,NU) + M + NU; -C prefer min(TAU,NU) + (M + NU)*NB. -C - CALL ZUNMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, - $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), - $ ABCD, LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C - CALL ZLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, - $ ABCD(IROW,MM1), LDABCD ) - IF ( RANK.GT.1 ) - $ CALL ZLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, - $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) - END IF -C - RO = RANK - END IF -C -C Determine the left Kronecker indices (row indices). -C - KRONL(IK) = KRONL(IK) + TAU - RO - NKROL = NKROL + KRONL(IK) - IK = IK + 1 -C -C C and D are updated to [A21 ; C11] and [B2 ; RD]. -C - NU = NU - RO - MU = SIGMA + RO - IF ( RO.NE.0 ) - $ GO TO 20 -C - 80 CONTINUE - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AB8NXZ *** - END diff --git a/slycot/src/AG07BD.f b/slycot/src/AG07BD.f deleted file mode 100644 index 5a7ab4c5..00000000 --- a/slycot/src/AG07BD.f +++ /dev/null @@ -1,273 +0,0 @@ - SUBROUTINE AG07BD( JOBE, N, M, A, LDA, E, LDE, B, LDB, C, LDC, - $ D, LDD, AI, LDAI, EI, LDEI, BI, LDBI, CI, LDCI, - $ DI, LDDI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the inverse (Ai-lambda*Ei,Bi,Ci,Di) of a given -C descriptor system (A-lambda*E,B,C,D). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBE CHARACTER*1 -C Specifies whether E is a general square or an identity -C matrix as follows: -C = 'G': E is a general square matrix; -C = 'I': E is the identity matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrices A and E; -C also the number of rows of matrix B and the number of -C columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The number of system inputs and outputs, i.e., the number -C of columns of matrices B and D and the number of rows of -C matrices C and D. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the original system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'G', the leading N-by-N part of this array must -C contain the descriptor matrix E of the original system. -C If JOBE = 'I', then E is assumed to be the identity -C matrix and is not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. -C LDE >= MAX(1,N), if JOBE = 'G'; -C LDE >= 1, if JOBE = 'I'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the original system. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading M-by-N part of this array must contain the -C output matrix C of the original system. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,M). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading M-by-M part of this array must contain the -C feedthrough matrix D of the original system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,M). -C -C AI (output) DOUBLE PRECISION array, dimension (LDAI,N+M) -C The leading (N+M)-by-(N+M) part of this array contains -C the state matrix Ai of the inverse system. -C If LDAI = LDA >= N+M, then AI and A can share the same -C storage locations. -C -C LDAI INTEGER -C The leading dimension of the array AI. -C LDAI >= MAX(1,N+M). -C -C EI (output) DOUBLE PRECISION array, dimension (LDEI,N+M) -C The leading (N+M)-by-(N+M) part of this array contains -C the descriptor matrix Ei of the inverse system. -C If LDEI = LDE >= N+M, then EI and E can share the same -C storage locations. -C -C LDEI INTEGER -C The leading dimension of the array EI. -C LDEI >= MAX(1,N+M). -C -C BI (output) DOUBLE PRECISION array, dimension (LDBI,M) -C The leading (N+M)-by-M part of this array contains -C the input matrix Bi of the inverse system. -C If LDBI = LDB >= N+M, then BI and B can share the same -C storage locations. -C -C LDBI INTEGER -C The leading dimension of the array BI. -C LDBI >= MAX(1,N+M). -C -C CI (output) DOUBLE PRECISION array, dimension (LDCI,N+M) -C The leading M-by-(N+M) part of this array contains -C the output matrix Ci of the inverse system. -C If LDCI = LDC, CI and C can share the same storage -C locations. -C -C LDCI INTEGER -C The leading dimension of the array CI. LDCI >= MAX(1,M). -C -C DI (output) DOUBLE PRECISION array, dimension (LDDI,M) -C The leading M-by-M part of this array contains -C the feedthrough matrix Di = 0 of the inverse system. -C DI and D can share the same storage locations. -C -C LDDI INTEGER -C The leading dimension of the array DI. LDDI >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices of the inverse system are computed with the formulas -C -C ( E 0 ) ( A B ) ( 0 ) -C Ei = ( ) , Ai = ( ) , Bi = ( ), -C ( 0 0 ) ( C D ) ( -I ) -C -C Ci = ( 0 I ), Di = 0. -C -C FURTHER COMMENTS -C -C The routine does not perform an invertibility test. This check can -C be performed by using the SLICOT routines AB08NX or AG08BY. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C KEYWORDS -C -C Descriptor system, inverse system, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBE - INTEGER INFO, LDA, LDAI, LDB, LDBI, LDC, LDCI, - $ LDD, LDDI, LDE, LDEI, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), AI(LDAI,*), B(LDB,*), BI(LDBI,*), - $ C(LDC,*), CI(LDCI,*), D(LDD,*), DI(LDDI,*), - $ E(LDE,*), EI(LDEI,*) -C .. Local Scalars .. - LOGICAL UNITE -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - UNITE = LSAME( JOBE, 'I' ) - IF( .NOT. ( LSAME( JOBE, 'G' ) .OR. UNITE ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDAI.LT.MAX( 1, N+M ) ) THEN - INFO = -15 - ELSE IF( LDEI.LT.MAX( 1, N+M ) ) THEN - INFO = -17 - ELSE IF( LDBI.LT.MAX( 1, N+M ) ) THEN - INFO = -19 - ELSE IF( LDCI.LT.MAX( 1, M ) ) THEN - INFO = -21 - ELSE IF( LDDI.LT.MAX( 1, M ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AG07BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C -C Form Ai. -C - CALL DLACPY( 'Full', N, N, A, LDA, AI, LDAI ) - CALL DLACPY( 'Full', M, N, C, LDC, AI(N+1,1), LDAI ) - CALL DLACPY( 'Full', N, M, B, LDB, AI(1,N+1), LDAI ) - CALL DLACPY( 'Full', M, M, D, LDD, AI(N+1,N+1), LDAI ) -C -C Form Ei. -C - IF( UNITE ) THEN - CALL DLASET( 'Full', N+M, N, ZERO, ONE, EI, LDEI ) - ELSE - CALL DLACPY( 'Full', N, N, E, LDE, EI, LDEI ) - CALL DLASET( 'Full', M, N, ZERO, ZERO, EI(N+1,1), LDEI ) - END IF - CALL DLASET( 'Full', N+M, M, ZERO, ZERO, EI(1,N+1), LDEI ) -C -C Form Bi. -C - CALL DLASET( 'Full', N, M, ZERO, ZERO, BI, LDBI ) - CALL DLASET( 'Full', M, M, ZERO, -ONE, BI(N+1,1), LDBI ) -C -C Form Ci. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, CI, LDCI ) - CALL DLASET( 'Full', M, M, ZERO, ONE, CI(1,N+1), LDCI ) -C -C Set Di. -C - CALL DLASET( 'Full', M, M, ZERO, ZERO, DI, LDDI ) -C - RETURN -C *** Last line of AG07BD *** - END diff --git a/slycot/src/AG08BD.f b/slycot/src/AG08BD.f deleted file mode 100644 index ff0cdcc8..00000000 --- a/slycot/src/AG08BD.f +++ /dev/null @@ -1,628 +0,0 @@ - SUBROUTINE AG08BD( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, - $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the system pencil -C -C ( A-lambda*E B ) -C S(lambda) = ( ) -C ( C D ) -C -C a regular pencil Af-lambda*Ef which has the finite Smith zeros of -C S(lambda) as generalized eigenvalues. The routine also computes -C the orders of the infinite Smith zeros and determines the singular -C and infinite Kronecker structure of system pencil, i.e., the right -C and left Kronecker indices, and the multiplicities of infinite -C eigenvalues. -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the system -C matrix as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Af of the reduced pencil. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Ef of the reduced pencil. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B of the system. -C On exit, this matrix does not contain useful information. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0; -C LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C of the system. -C On exit, this matrix does not contain useful information. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NFZ (output) INTEGER -C The number of finite zeros. -C -C NRANK (output) INTEGER -C The normal rank of the system pencil. -C -C NIZ (output) INTEGER -C The number of infinite zeros. -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite Smith zeros. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NINFE (output) INTEGER -C The number of elementary infinite blocks. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N+1) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors of -C degree i in the Smith form, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (N+M+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) -C The leading NINFE elements of INFE contain the -C multiplicities of infinite eigenvalues. -C -C KRONL (output) INTEGER array, dimension (L+P+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then default tolerances are -C used instead, as follows: TOLDEF = L*N*EPS in TG01FD -C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS -C in the rest, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension N+max(1,M) -C On output, IWORK(1) contains the normal rank of the -C transfer function matrix. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 4*(L+N), LDW ), if EQUIL = 'S', -C LDWORK >= LDW, if EQUIL = 'N', where -C LDW = max(L+P,M+N)*(M+N) + max(1,5*max(L+P,M+N)). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a descriptor -C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which -C has the finite zeros of the system as generalized eigenvalues. -C The procedure has the following main computational steps: -C -C (a) construct the (L+P)-by-(N+M) system pencil -C -C S(lambda) = ( B A )-lambda*( 0 E ); -C ( D C ) ( 0 0 ) -C -C (b) reduce S(lambda) to S1(lambda) with the same finite -C zeros and right Kronecker structure but with E -C upper triangular and nonsingular; -C -C (c) reduce S1(lambda) to S2(lambda) with the same finite -C zeros and right Kronecker structure but with D of -C full row rank; -C -C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros -C and with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C -C S3(lambda) = (A-lambda*E B) in order to reduce it to -C ( C D) -C -C (Af-lambda*Ef X), with Y and Ef square invertible; -C ( 0 Y) -C -C (f) compute the right and left Kronecker indices of the system -C matrix, which together with the multiplicities of the -C finite and infinite eigenvalues constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [1]). -C -C FURTHER COMMENTS -C -C In order to compute the finite Smith zeros of the system -C explicitly, a call to this routine may be followed by a -C call to the LAPACK Library routines DGEGV or DGGEV. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C May 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, -C Jan. 2009, Mar. 2009, Apr. 2009. -C A. Varga, DLR Oberpfaffenhofen, Nov. 1999, Feb. 2002, Mar. 2002. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LDWORK, - $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), E(LDE,*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, - $ LABCD2, LDABCD, LDW, MM, MU, N2, NB, NN, NSINFE, - $ NU, NUMU, PP, WRKOPT - DOUBLE PRECISION SVLMAX, TOLER -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL AG08BY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD, - $ MA02CD, TB01XD, TG01AD, TG01FD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LDABCD = MAX( L+P, N+M ) - LABCD2 = LDABCD*( N+M ) - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -27 - ELSE - I0 = MIN( L+P, M+N ) - I1 = MIN( L, N ) - II = MIN( M, P ) - LDW = LABCD2 + MAX( 1, 5*LDABCD ) - IF( LEQUIL ) - $ LDW = MAX( 4*( L + N ), LDW ) - IF( LQUERY ) THEN - CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, - $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, - $ IWORK, DWORK, -1, INFO ) - WRKOPT = MAX( LDW, INT( DWORK(1) ) ) - SVLMAX = ZERO - CALL AG08BY( .TRUE., I1, M+N, P+L, SVLMAX, DWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) - CALL AG08BY( .FALSE., I1, II, M+N, SVLMAX, DWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) - NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', I1, I1+II, II, - $ -1 ) ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) - ELSE IF( LDWORK.LT.LDW ) THEN - INFO = -30 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AG08BD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C - NIZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF( MAX( L, N, M, P ).EQ.0 ) THEN - NFZ = 0 - DINFZ = 0 - NINFE = 0 - NRANK = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - WRKOPT = 1 - KABCD = 1 - JWORK = KABCD + LABCD2 -C -C If required, balance the system pencil. -C Workspace: need 4*(L+N). -C - IF( LEQUIL ) THEN - CALL TG01AD( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, - $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) - WRKOPT = 4*(L+N) - END IF - SVLMAX = DLANGE( 'Frobenius', L, N, E, LDE, DWORK ) -C -C Reduce the system matrix to QR form, -C -C ( A11-lambda*E11 A12 B1 ) -C ( A21 A22 B2 ) , -C ( C1 C2 D ) -C -C with E11 invertible and upper triangular. -C Real workspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); -C prefer larger. -C Integer workspace: N. -C - CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Construct the system pencil -C -C MM NN -C ( B1 A12 A11-lambda*E11 ) NN -C S1(lambda) = ( B2 A22 A21 ) L-NN -C ( D C2 C1 ) P -C -C of dimension (L+P)-by-(M+N). -C Workspace: need LABCD2 = max( L+P, N+M )*( N+M ). -C - N2 = N - NN - MM = M + N2 - PP = P + ( L - NN ) - CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KABCD), LDABCD ) - CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+L), LDABCD ) - CALL DLACPY( 'Full', L, N2, A(1,NN+1), LDA, - $ DWORK(KABCD+LDABCD*M), LDABCD ) - CALL DLACPY( 'Full', P, N2, C(1,NN+1), LDC, - $ DWORK(KABCD+LDABCD*M+L), LDABCD ) - CALL DLACPY( 'Full', L, NN, A, LDA, - $ DWORK(KABCD+LDABCD*MM), LDABCD ) - CALL DLACPY( 'Full', P, NN, C, LDC, - $ DWORK(KABCD+LDABCD*MM+L), LDABCD ) -C -C If required, set tolerance. -C - TOLER = TOL - IF( TOLER.LE.ZERO ) THEN - TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) - END IF - SVLMAX = MAX( SVLMAX, - $ DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), - $ LDABCD, DWORK(JWORK) ) ) -C -C Extract the reduced pencil S2(lambda) -C -C ( Bc Ac-lambda*Ec ) -C ( Dc Cc ) -C -C having the same finite Smith zeros as the system pencil -C S(lambda) but with Dc, a MU-by-MM full row rank -C left upper trapezoidal matrix, and Ec, an NU-by-NU -C upper triangular nonsingular matrix. -C -C Real workspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), -C 5*(P+L), 1 ) + LABCD2; -C prefer larger. -C Integer workspace: MM, MM <= M+N; PP <= P+L. -C - CALL AG08BY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Set the number of simple (nondynamic) infinite eigenvalues -C and the normal rank of the system pencil. -C - NSINFE = MU - NRANK = NN + MU -C -C Pertranspose the system. -C - CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), - $ DWORK(KABCD+LDABCD*MM), LDABCD, - $ DWORK(KABCD), LDABCD, - $ DWORK(KABCD+LDABCD*MM+NU), LDABCD, - $ DWORK(KABCD+NU), LDABCD, INFO ) - CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD), LDABCD ) - CALL MA02BD( 'Left', MM, NU+MM, DWORK(KABCD+NU), LDABCD ) - CALL MA02CD( NU, 0, MAX( 0, NU-1 ), E, LDE ) -C - IF( MU.NE.MM ) THEN - NN = NU - PP = MM - MM = MU - KABCD = KABCD + ( PP - MM )*LDABCD -C -C Extract the reduced pencil S3(lambda), -C -C ( Br Ar-lambda*Er ) , -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil S(lambda), -C but with Dr, an MU-by-MU invertible upper triangular matrix, -C and Er, an NU-by-NU upper triangular nonsingular matrix. -C -C Workspace: need max( 1, 5*(M+N) ) + LABCD2. -C prefer larger. -C No integer workspace necessary. -C - CALL AG08BY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, - $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( Br Ar-lambda*Er ) -C ( Dr Cr ) -C in order to reduce it to -C ( * Af-lambda*Ef ) -C ( Y 0 ) -C with Y and Ef square invertible. -C -C Compute Af by reducing ( Br Ar ) to ( * Af ) . -C ( Dr Cr ) ( Y 0 ) -C - NUMU = NU + MU - IPD = KABCD + NU - ITAU = JWORK - JWORK = ITAU + MU -C -C Workspace: need LABCD2 + 2*min(M,P); -C prefer LABCD2 + min(M,P) + min(M,P)*NB. -C - CALL DTZRZF( MU, NUMU, DWORK(IPD), LDABCD, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need LABCD2 + min(M,P) + min(L,N); -C prefer LABCD2 + min(M,P) + min(L,N)*NB. -C - CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, - $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), - $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Save Af. -C - CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, A, - $ LDA ) -C -C Compute Ef by applying the saved transformations from previous -C reduction to ( 0 Er ) . -C - CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD ) - CALL DLACPY( 'Full', NU, NU, E, LDE, DWORK(KABCD+LDABCD*MU), - $ LDABCD ) -C - CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, - $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), - $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C -C Save Ef. -C - CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, E, - $ LDE ) - END IF -C - NFZ = NU -C -C Set right Kronecker indices (column indices). -C - DO 10 I = 1, NKROR - IWORK(I) = KRONR(I) - 10 CONTINUE -C - J = 0 - DO 30 I = 1, NKROR - DO 20 II = J + 1, J + IWORK(I) - KRONR(II) = I - 1 - 20 CONTINUE - J = J + IWORK(I) - 30 CONTINUE -C - NKROR = J -C -C Set left Kronecker indices (row indices). -C - DO 40 I = 1, NKROL - IWORK(I) = KRONL(I) - 40 CONTINUE -C - J = 0 - DO 60 I = 1, NKROL - DO 50 II = J + 1, J + IWORK(I) - KRONL(II) = I - 1 - 50 CONTINUE - J = J + IWORK(I) - 60 CONTINUE -C - NKROL = J -C -C Determine the number of simple infinite blocks -C as the difference between the number of infinite blocks -C of order greater than one and the order of Dr. -C - NINFE = 0 - DO 70 I = 1, DINFZ - NINFE = NINFE + INFZ(I) - 70 CONTINUE - NINFE = NSINFE - NINFE - DO 80 I = 1, NINFE - INFE(I) = 1 - 80 CONTINUE -C -C Set the structure of infinite eigenvalues. -C - DO 100 I = 1, DINFZ - DO 90 II = NINFE + 1, NINFE + INFZ(I) - INFE(II) = I + 1 - 90 CONTINUE - NINFE = NINFE + INFZ(I) - 100 CONTINUE -C - IWORK(1) = NSINFE - DWORK(1) = WRKOPT - RETURN -C *** Last line of AG08BD *** - END diff --git a/slycot/src/AG08BY.f b/slycot/src/AG08BY.f deleted file mode 100644 index d6517dea..00000000 --- a/slycot/src/AG08BY.f +++ /dev/null @@ -1,682 +0,0 @@ - SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, - $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) descriptor system pencil -C -C S(lambda) = ( B A - lambda*E ) -C ( D C ) -C -C with E nonsingular and upper triangular a -C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil -C -C ( Br Ar-lambda*Er ) -C Sr(lambda) = ( ) -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil -C S(lambda) but with Dr, a PR-by-M full row rank -C left upper trapezoidal matrix, and Er, an NR-by-NR -C upper triangular nonsingular matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C FIRST LOGICAL -C Specifies if AG08BY is called first time or it is called -C for an already reduced system, with D full column rank -C with the last M rows in upper triangular form: -C FIRST = .TRUE., first time called; -C FIRST = .FALSE., not first time called. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of matrix B, the number of columns of -C matrix C and the order of square matrices A and E. -C N >= 0. -C -C M (input) INTEGER -C The number of columns of matrices B and D. M >= 0. -C M <= P if FIRST = .FALSE. . -C -C P (input) INTEGER -C The number of rows of matrices C and D. P >= 0. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) DOUBLE PRECISION array, dimension -C (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound matrix -C ( B A ) , -C ( D C ) -C where A is an N-by-N matrix, B is an N-by-M matrix, -C C is a P-by-N matrix and D is a P-by-M matrix. -C If FIRST = .FALSE., then D must be a full column -C rank matrix with the last M rows in upper triangular form. -C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD -C contains the reduced compound matrix -C ( Br Ar ) , -C ( Dr Cr ) -C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, -C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank -C left upper trapezoidal matrix with the first PR columns -C in upper triangular form. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular nonsingular matrix E. -C On exit, the leading NR-by-NR part contains the reduced -C upper triangular nonsingular matrix Er. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C NR (output) INTEGER -C The order of the reduced matrices Ar and Er; also the -C number of rows of the reduced matrix Br and the number -C of columns of the reduced matrix Cr. -C If Dr is invertible, NR is also the number of finite -C Smith zeros. -C -C PR (output) INTEGER -C The rank of the resulting matrix Dr; also the number of -C rows of reduced matrices Cr and Dr. -C -C NINFZ (output) INTEGER -C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite zeros. -C DINFZ = 0 if FIRST = .FALSE. . -C -C NKRONL (output) INTEGER -C The maximal dimension of left elementary Kronecker blocks. -C -C INFZ (output) INTEGER array, dimension (N) -C INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,DINFZ. -C INFZ is not referenced if FIRST = .FALSE. . -C -C KRONL (output) INTEGER array, dimension (N+1) -C KRONL(i) contains the number of left elementary Kronecker -C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used -C instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C If FIRST = .FALSE., IWORK is not referenced. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if P = 0; otherwise -C LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ), -C if FIRST = .TRUE.; -C LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. . -C The second term is not needed if M = 0. -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithm of [1]. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( (P+N)*(M+N)*N ) floating point operations. -C -C FURTHER COMMENTS -C -C The number of infinite zeros is computed as -C -C DINFZ -C NINFZ = Sum (INFZ(i)*i) . -C i=1 -C Note that each infinite zero of multiplicity k corresponds to -C an infinite eigenvalue of multiplicity k+1. -C The multiplicities of the infinite eigenvalues can be determined -C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: -C -C DINFZ -C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; -C i=1 -C -C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, -C for i = 1, ..., DINFZ. -C -C The left Kronecker indices are: -C -C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] -C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C May 1999. Based on the RASP routine SRISEP. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, -C Jan. 2009, Apr. 2009. -C A. Varga, DLR Oberpfaffenhofen, March 2002. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, orthogonal transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ONE, P05, ZERO - PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DINFZ, INFO, LDABCD, LDE, LDWORK, M, N, NINFZ, - $ NKRONL, NR, P, PR - DOUBLE PRECISION SVLMAX, TOL - LOGICAL FIRST -C .. Array Arguments .. - INTEGER INFZ( * ), IWORK(*), KRONL( * ) - DOUBLE PRECISION ABCD( LDABCD, * ), DWORK( * ), E( LDE, * ) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, - $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, - $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, - $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT - DOUBLE PRECISION C, C1, C2, RCOND, S, S1, S2, SMAX, SMAXPR, - $ SMIN, SMINPR, T, TT -C .. Local Arrays .. - DOUBLE PRECISION DUM(1), SVAL(3) -C .. External Functions .. - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL DLAMCH, DNRM2, IDAMAX, ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DLAIC1, DLAPMT, DLARFG, DLARTG, DLASET, - $ SLCT_DLATZM, DORMQR, DROT, DSWAP, MB03OY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C -C Test the input parameters. -C - LQUERY = ( LDWORK.EQ.-1 ) - INFO = 0 - PN = P + N - MN = M + N - MPM = MIN( P, M ) - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -17 - ELSE - WRKOPT = MAX( 1, 5*P ) - IF( P.GT.0 ) THEN - IF( M.GT.0 ) THEN - WRKOPT = MAX( WRKOPT, MN-1 ) - IF( FIRST ) THEN - WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, - $ MPM, -1 ) ) - WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) - END IF - END IF - END IF - END IF - IF( LDWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN - INFO = -20 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AG08BY', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize output variables. -C - PR = P - NR = N - DINFZ = 0 - NINFZ = 0 - NKRONL = 0 -C -C Quick return if possible. -C - IF( P.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF - IF( N.EQ.0 .AND. M.EQ.0 ) THEN - PR = 0 - NKRONL = 1 - KRONL(1) = P - DWORK(1) = ONE - RETURN - END IF -C - RCOND = TOL - IF( RCOND.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) - END IF -C -C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and -C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. -C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column -C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. -C - IF( FIRST ) THEN - SIGMA = 0 - ELSE - SIGMA = M - END IF - RO = P - SIGMA - MP1 = M + 1 - MUI = 0 - DUM(1) = ZERO -C - ITAU = 1 - JWORK1 = ITAU + MPM - ISMIN = 2*P + 1 - ISMAX = ISMIN + P - JWORK2 = ISMAX + P - NBLCKS = 0 - WRKOPT = 1 -C - 10 IF( PR.EQ.0 ) GO TO 90 -C -C (NR+1,ICOL+1) points to the current position of matrix D. -C - RO1 = RO - MNR = M + NR - IF( M.GT.0 ) THEN -C -C Compress rows of D; first exploit the trapezoidal shape of the -C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; -C compress the first SIGMA columns without column pivoting: -C -C ( x x x x x ) ( x x x x x ) -C ( x x x x x ) ( 0 x x x x ) -C ( x x x x x ) - > ( 0 0 x x x ) -C ( 0 x x x x ) ( 0 0 0 x x ) -C ( 0 0 x x x ) ( 0 0 0 x x ) -C -C where SIGMA = 3 and RO = 2. -C Workspace: need maximum M+N-1. -C - IROW = NR - DO 20 ICOL = 1, SIGMA - IROW = IROW + 1 - CALL DLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, - $ T ) - CALL SLCT_DLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), - $ 1, T, - $ ABCD(IROW,ICOL+1), ABCD(IROW+1,ICOL+1), - $ LDABCD, DWORK ) - CALL DCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) - 20 CONTINUE - WRKOPT = MAX( WRKOPT, MN - 1 ) -C - IF( FIRST ) THEN -C -C Continue with Householder with column pivoting. -C -C ( x x x x x ) ( x x x x x ) -C ( 0 x x x x ) ( 0 x x x x ) -C ( 0 0 x x x ) - > ( 0 0 x x x ) -C ( 0 0 0 x x ) ( 0 0 0 x x ) -C ( 0 0 0 x x ) ( 0 0 0 0 0 ) -C -C Real workspace: need maximum min(P,M)+3*M-1; -C Integer workspace: need maximum M. -C - IROW = MIN( NR+SIGMA+1, PN ) - ICOL = MIN( SIGMA+1, M ) - CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, - $ RCOND, SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), - $ DWORK(JWORK1), INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) -C -C Apply the column permutations to B and part of D. -C - CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), - $ LDABCD, IWORK ) -C - IF( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C Workspace: need maximum min(P,M) + N; -C prefer maximum min(P,M) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK, - $ ABCD(IROW,ICOL), LDABCD, DWORK(ITAU), - $ ABCD(IROW,MP1), LDABCD, DWORK(JWORK1), - $ LDWORK-JWORK1+1, INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + INT( DWORK(JWORK1) ) - 1 ) - CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, - $ ZERO, ABCD(MIN( IROW+1, PN ),ICOL), LDABCD ) - RO1 = RO1 - RANK - END IF - END IF -C -C Terminate if Dr has maximal row rank. -C - IF( RO1.EQ.0 ) GO TO 90 -C - END IF -C -C Update SIGMA. -C - SIGMA = PR - RO1 -C - NBLCKS = NBLCKS + 1 - TAUI = RO1 -C -C Compress the columns of current C to separate a TAUI-by-MUI -C full column rank block. -C - IF( NR.EQ.0 ) THEN -C -C Finish for zero state dimension. -C - PR = SIGMA - RANK = 0 - ELSE -C -C Perform RQ-decomposition with row pivoting on the current C -C while keeping E upper triangular. -C The current C is the TAUI-by-NR matrix delimited by rows -C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. -C The rank of current C is computed in MUI. -C Workspace: need maximum 5*P. -C - IRC = NR + SIGMA - N1 = NR - IF( TAUI.GT.1 ) THEN -C -C Compute norms. -C - DO 30 I = 1, TAUI - DWORK(I) = DNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) - DWORK(P+I) = DWORK(I) - 30 CONTINUE - END IF -C - RANK = 0 - MNTAU = MIN( TAUI, NR ) -C -C ICOL and IROW will point to the current pivot position in C. -C - ILAST = NR + PR - JLAST = M + NR - IROW = ILAST - ICOL = JLAST - I = TAUI - 40 IF( RANK.LT.MNTAU ) THEN - MN1 = M + N1 -C -C Pivot if necessary. -C - IF( I.NE.1 ) THEN - J = IDAMAX( I, DWORK, 1 ) - IF( J.NE.I ) THEN - DWORK(J) = DWORK(I) - DWORK(P+J) = DWORK(P+I) - CALL DSWAP( N1, ABCD(IROW,MP1), LDABCD, - $ ABCD(IRC+J,MP1), LDABCD ) - END IF - END IF -C -C Zero elements left to ABCD(IROW,ICOL). -C - DO 50 K = 1, N1-1 - J = M + K -C -C Rotate columns J, J+1 to zero ABCD(IROW,J). -C - T = ABCD(IROW,J+1) - CALL DLARTG( T, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) - ABCD(IROW,J) = ZERO - CALL DROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) - CALL DROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) -C -C Rotate rows K, K+1 to zero E(K+1,K). -C - T = E(K,K) - CALL DLARTG( T, E(K+1,K), C, S, E(K,K) ) - E(K+1,K) = ZERO - CALL DROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) - CALL DROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, - $ C, S ) - 50 CONTINUE -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( ABCD(ILAST,JLAST) ) - IF ( SMAX.EQ.ZERO ) GO TO 80 - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, - $ DWORK(JWORK2), 1 ) - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, - $ DWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, - $ C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, - $ DWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, - $ C2 ) - WRKOPT = MAX( WRKOPT, 5*P ) - END IF -C -C Check the rank; finish the loop if rank loss occurs. -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Finish the loop if last row. -C - IF( N1.EQ.0 ) THEN - RANK = RANK + 1 - GO TO 80 - END IF -C - IF( N1.GT.1 ) THEN -C -C Update norms. -C - IF( I-1.GT.1 ) THEN - DO 60 J = 1, I - 1 - IF( DWORK(J).NE.ZERO ) THEN - T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) - $ /DWORK(J) )**2 - T = MAX( T, ZERO ) - TT = ONE + - $ P05*T*( DWORK(J)/DWORK(P+J) )**2 - IF( TT.NE.ONE ) THEN - DWORK(J) = DWORK(J)*SQRT( T ) - ELSE - DWORK(J) = DNRM2( N1-1, - $ ABCD(IRC+J,MP1), LDABCD ) - DWORK(P+J) = DWORK(J) - END IF - END IF - 60 CONTINUE - END IF - END IF -C - DO 70 J = 1, RANK - DWORK( ISMIN+J-1 ) = S1*DWORK( ISMIN+J-1 ) - DWORK( ISMAX+J-1 ) = S2*DWORK( ISMAX+J-1 ) - 70 CONTINUE -C - DWORK( ISMIN+RANK ) = C1 - DWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - ICOL = ICOL - 1 - IROW = IROW - 1 - N1 = N1 - 1 - I = I - 1 - GO TO 40 - END IF - END IF - END IF - END IF - END IF -C - 80 CONTINUE - MUI = RANK - NR = NR - MUI - PR = SIGMA + MUI -C -C Set number of left Kronecker blocks of order (i-1)-by-i. -C - KRONL(NBLCKS) = TAUI - MUI -C -C Set number of infinite divisors of order i-1. -C - IF( FIRST .AND. NBLCKS.GT.1 ) - $ INFZ(NBLCKS-1) = MUIM1 - TAUI - MUIM1 = MUI - RO = MUI -C -C Continue reduction if rank of current C is positive. -C - IF( MUI.GT.0 ) - $ GO TO 10 -C -C Determine the maximal degree of infinite zeros and -C the number of infinite zeros. -C - 90 CONTINUE - IF( FIRST ) THEN - IF( MUI.EQ.0 ) THEN - DINFZ = MAX( 0, NBLCKS - 1 ) - ELSE - DINFZ = NBLCKS - INFZ(NBLCKS) = MUI - END IF - K = DINFZ - DO 100 I = K, 1, -1 - IF( INFZ(I).NE.0 ) GO TO 110 - DINFZ = DINFZ - 1 - 100 CONTINUE - 110 CONTINUE - DO 120 I = 1, DINFZ - NINFZ = NINFZ + INFZ(I)*I - 120 CONTINUE - END IF -C -C Determine the maximal order of left elementary Kronecker blocks. -C - NKRONL = NBLCKS - DO 130 I = NBLCKS, 1, -1 - IF( KRONL(I).NE.0 ) GO TO 140 - NKRONL = NKRONL - 1 - 130 CONTINUE - 140 CONTINUE -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of AG08BY *** - END diff --git a/slycot/src/AG08BZ.f b/slycot/src/AG08BZ.f deleted file mode 100644 index 6292b055..00000000 --- a/slycot/src/AG08BZ.f +++ /dev/null @@ -1,641 +0,0 @@ - SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, - $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, - $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the system pencil -C -C ( A-lambda*E B ) -C S(lambda) = ( ) -C ( C D ) -C -C a regular pencil Af-lambda*Ef which has the finite Smith zeros of -C S(lambda) as generalized eigenvalues. The routine also computes -C the orders of the infinite Smith zeros and determines the singular -C and infinite Kronecker structure of system pencil, i.e., the right -C and left Kronecker indices, and the multiplicities of infinite -C eigenvalues. -C -C ARGUMENTS -C -C Mode Parameters -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the system -C matrix as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Af of the reduced pencil. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E of the system. -C On exit, the leading NFZ-by-NFZ part of this array -C contains the matrix Ef of the reduced pencil. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B of the system. -C On exit, this matrix does not contain useful information. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0; -C LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C of the system. -C On exit, this matrix does not contain useful information. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) COMPLEX*16 array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct transmission matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NFZ (output) INTEGER -C The number of finite zeros. -C -C NRANK (output) INTEGER -C The normal rank of the system pencil. -C -C NIZ (output) INTEGER -C The number of infinite zeros. -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite Smith zeros. -C -C NKROR (output) INTEGER -C The number of right Kronecker indices. -C -C NINFE (output) INTEGER -C The number of elementary infinite blocks. -C -C NKROL (output) INTEGER -C The number of left Kronecker indices. -C -C INFZ (output) INTEGER array, dimension (N+1) -C The leading DINFZ elements of INFZ contain information -C on the infinite elementary divisors as follows: -C the system has INFZ(i) infinite elementary divisors of -C degree i in the Smith form, where i = 1,2,...,DINFZ. -C -C KRONR (output) INTEGER array, dimension (N+M+1) -C The leading NKROR elements of this array contain the -C right Kronecker (column) indices. -C -C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) -C The leading NINFE elements of INFE contain the -C multiplicities of infinite eigenvalues. -C -C KRONL (output) INTEGER array, dimension (L+P+1) -C The leading NKROL elements of this array contain the -C left Kronecker (row) indices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then default tolerances are -C used instead, as follows: TOLDEF = L*N*EPS in TG01FZ -C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS -C in the rest, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension N+max(1,M) -C On output, IWORK(1) contains the normal rank of the -C transfer function matrix. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S', -C LDWORK >= 2*max(L+P,M+N)), if EQUIL = 'N'. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= max( max(L+P,M+N)*(M+N) + -C max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1), -C 3*(L+P), 1)) -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine extracts from the system matrix of a descriptor -C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which -C has the finite zeros of the system as generalized eigenvalues. -C The procedure has the following main computational steps: -C -C (a) construct the (L+P)-by-(N+M) system pencil -C -C S(lambda) = ( B A )-lambda*( 0 E ); -C ( D C ) ( 0 0 ) -C -C (b) reduce S(lambda) to S1(lambda) with the same finite -C zeros and right Kronecker structure but with E -C upper triangular and nonsingular; -C -C (c) reduce S1(lambda) to S2(lambda) with the same finite -C zeros and right Kronecker structure but with D of -C full row rank; -C -C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros -C and with D square invertible; -C -C (e) perform a unitary transformation on the columns of -C -C S3(lambda) = (A-lambda*E B) in order to reduce it to -C ( C D) -C -C (Af-lambda*Ef X), with Y and Ef square invertible; -C ( 0 Y) -C -C (f) compute the right and left Kronecker indices of the system -C matrix, which together with the multiplicities of the -C finite and infinite eigenvalues constitute the -C complete set of structural invariants under strict -C equivalence transformations of a linear system. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable (see [1]). -C -C FURTHER COMMENTS -C -C In order to compute the finite Smith zeros of the system -C explicitly, a call to this routine may be followed by a -C call to the LAPACK Library routines ZGEGV or ZGGEV. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C May 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - CHARACTER EQUIL - INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LZWORK, - $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) - DOUBLE PRECISION DWORK(*) - COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ E(LDE,*), ZWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LQUERY - INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, - $ LABCD2, LDABCD, LZW, MM, MU, N2, NB, NN, NSINFE, - $ NU, NUMU, PP, WRKOPT - DOUBLE PRECISION SVLMAX, TOLER -C .. Local Arrays .. - COMPLEX*16 DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL AG8BYZ, MA02BZ, MA02CZ, TB01XZ, TG01AZ, TG01FZ, - $ XERBLA, ZLACPY, ZLASET, ZTZRZF, ZUNMRZ -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LDABCD = MAX( L+P, N+M ) - LABCD2 = LDABCD*( N+M ) - LEQUIL = LSAME( EQUIL, 'S' ) - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input scalar arguments. -C - IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -27 - ELSE - I0 = MIN( L+P, M+N ) - I1 = MIN( L, N ) - II = MIN( M, P ) - LZW = MAX( 1, LABCD2 + MAX( I0 + MAX( I1, 3*( M+N ) - 1 ), - $ 3*( L+P ) ) ) - IF( LQUERY ) THEN - CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, - $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, - $ IWORK, DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( LZW, INT( ZWORK(1) ) ) - SVLMAX = ZERO - CALL AG8BYZ( .TRUE., I1, M+N, P+L, SVLMAX, ZWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) - CALL AG8BYZ( .FALSE., I1, II, M+N, SVLMAX, ZWORK, LDABCD+I1, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) - WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) - NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', I1, I1+II, II, - $ -1 ) ) - WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) - ELSE IF( LZWORK.LT.LZW ) THEN - INFO = -31 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'AG08BZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C - NIZ = 0 - NKROL = 0 - NKROR = 0 -C -C Quick return if possible. -C - IF( MAX( L, N, M, P ).EQ.0 ) THEN - NFZ = 0 - DINFZ = 0 - NINFE = 0 - NRANK = 0 - IWORK(1) = 0 - ZWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "CWorkspace:", "RWorkspace:" -C and "IWorkspace:" describe the minimal amount of complex, real and -C integer workspace, respectively, needed at that point in the code, -C as well as the preferred amount for good performance.) -C - WRKOPT = 1 - KABCD = 1 - JWORK = KABCD + LABCD2 -C -C If required, balance the system pencil. -C RWorkspace: need 4*(L+N). -C - IF( LEQUIL ) THEN - CALL TG01AZ( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, - $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) - END IF - SVLMAX = ZLANGE( 'Frobenius', L, N, E, LDE, DWORK ) -C -C Reduce the system matrix to QR form, -C -C ( A11-lambda*E11 A12 B1 ) -C ( A21 A22 B2 ) , -C ( C1 C2 D ) -C -C with E11 invertible and upper triangular. -C IWorkspace: need N. -C RWorkspace: need 2*N. -C CWorkspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); -C prefer larger. -C - CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, - $ ZWORK, LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) -C -C Construct the system pencil -C -C MM NN -C ( B1 A12 A11-lambda*E11 ) NN -C S1(lambda) = ( B2 A22 A21 ) L-NN -C ( D C2 C1 ) P -C -C of dimension (L+P)-by-(M+N). -C CWorkspace: need LABCD2 = max( L+P, N+M )*( N+M ). -C - N2 = N - NN - MM = M + N2 - PP = P + ( L - NN ) - CALL ZLACPY( 'Full', L, M, B, LDB, ZWORK(KABCD), LDABCD ) - CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(KABCD+L), LDABCD ) - CALL ZLACPY( 'Full', L, N2, A(1,NN+1), LDA, - $ ZWORK(KABCD+LDABCD*M), LDABCD ) - CALL ZLACPY( 'Full', P, N2, C(1,NN+1), LDC, - $ ZWORK(KABCD+LDABCD*M+L), LDABCD ) - CALL ZLACPY( 'Full', L, NN, A, LDA, - $ ZWORK(KABCD+LDABCD*MM), LDABCD ) - CALL ZLACPY( 'Full', P, NN, C, LDC, - $ ZWORK(KABCD+LDABCD*MM+L), LDABCD ) -C -C If required, set tolerance. -C - TOLER = TOL - IF( TOLER.LE.ZERO ) THEN - TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) - END IF - SVLMAX = MAX( SVLMAX, - $ ZLANGE( 'Frobenius', NN+PP, NN+MM, ZWORK(KABCD), - $ LDABCD, DWORK ) ) -C -C Extract the reduced pencil S2(lambda) -C -C ( Bc Ac-lambda*Ec ) -C ( Dc Cc ) -C -C having the same finite Smith zeros as the system pencil -C S(lambda) but with Dc, a MU-by-MM full row rank -C left upper trapezoidal matrix, and Ec, an NU-by-NU -C upper triangular nonsingular matrix. -C -C IWorkspace: need MM, MM <= M+N; -C RWorkspace: need 2*max(MM,PP); PP <= P+L; -C CWorkspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), -C 3*(P+L), 1 ) + LABCD2; -C prefer larger. -C - CALL AG8BYZ( .TRUE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, - $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, - $ INFO ) -C - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C Set the number of simple (nondynamic) infinite eigenvalues -C and the normal rank of the system pencil. -C - NSINFE = MU - NRANK = NN + MU -C -C Pertranspose the system. -C - CALL TB01XZ( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), - $ ZWORK(KABCD+LDABCD*MM), LDABCD, - $ ZWORK(KABCD), LDABCD, - $ ZWORK(KABCD+LDABCD*MM+NU), LDABCD, - $ ZWORK(KABCD+NU), LDABCD, INFO ) - CALL MA02BZ( 'Right', NU+MM, MM, ZWORK(KABCD), LDABCD ) - CALL MA02BZ( 'Left', MM, NU+MM, ZWORK(KABCD+NU), LDABCD ) - CALL MA02CZ( NU, 0, MAX( 0, NU-1 ), E, LDE ) -C - IF( MU.NE.MM ) THEN - NN = NU - PP = MM - MM = MU - KABCD = KABCD + ( PP - MM )*LDABCD -C -C Extract the reduced pencil S3(lambda), -C -C ( Br Ar-lambda*Er ) , -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil S(lambda), -C but with Dr, an MU-by-MU invertible upper triangular matrix, -C and Er, an NU-by-NU upper triangular nonsingular matrix. -C -C IWorkspace: need 0; -C RWorkspace: need 2*(M+N); -C CWorkspace: need max( 1, 3*(M+N) ) + LABCD2. -C prefer larger. -C - CALL AG8BYZ( .FALSE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, - $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, - $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, - $ INFO ) -C - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF( NU.NE.0 ) THEN -C -C Perform a unitary transformation on the columns of -C ( Br Ar-lambda*Er ) -C ( Dr Cr ) -C in order to reduce it to -C ( * Af-lambda*Ef ) -C ( Y 0 ) -C with Y and Ef square invertible. -C -C Compute Af by reducing ( Br Ar ) to ( * Af ) . -C ( Dr Cr ) ( Y 0 ) -C - NUMU = NU + MU - IPD = KABCD + NU - ITAU = JWORK - JWORK = ITAU + MU -C -C CWorkspace: need LABCD2 + 2*min(M,P); -C prefer LABCD2 + min(M,P) + min(M,P)*NB. -C - CALL ZTZRZF( MU, NUMU, ZWORK(IPD), LDABCD, ZWORK(ITAU), - $ ZWORK(JWORK), LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C CWorkspace: need LABCD2 + min(M,P) + min(L,N); -C prefer LABCD2 + min(M,P) + min(L,N)*NB. -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, - $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), - $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) -C -C Save Af. -C - CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, A, - $ LDA ) -C -C Compute Ef by applying the saved transformations from previous -C reduction to ( 0 Er ) . -C - CALL ZLASET( 'Full', NU, MU, CZERO, CZERO, ZWORK(KABCD), - $ LDABCD ) - CALL ZLACPY( 'Full', NU, NU, E, LDE, ZWORK(KABCD+LDABCD*MU), - $ LDABCD ) -C - CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, - $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), - $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) -C -C Save Ef. -C - CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, E, - $ LDE ) - END IF -C - NFZ = NU -C -C Set right Kronecker indices (column indices). -C - DO 10 I = 1, NKROR - IWORK(I) = KRONR(I) - 10 CONTINUE -C - J = 0 - DO 30 I = 1, NKROR - DO 20 II = J + 1, J + IWORK(I) - KRONR(II) = I - 1 - 20 CONTINUE - J = J + IWORK(I) - 30 CONTINUE -C - NKROR = J -C -C Set left Kronecker indices (row indices). -C - DO 40 I = 1, NKROL - IWORK(I) = KRONL(I) - 40 CONTINUE -C - J = 0 - DO 60 I = 1, NKROL - DO 50 II = J + 1, J + IWORK(I) - KRONL(II) = I - 1 - 50 CONTINUE - J = J + IWORK(I) - 60 CONTINUE -C - NKROL = J -C -C Determine the number of simple infinite blocks -C as the difference between the number of infinite blocks -C of order greater than one and the order of Dr. -C - NINFE = 0 - DO 70 I = 1, DINFZ - NINFE = NINFE + INFZ(I) - 70 CONTINUE - NINFE = NSINFE - NINFE - DO 80 I = 1, NINFE - INFE(I) = 1 - 80 CONTINUE -C -C Set the structure of infinite eigenvalues. -C - DO 100 I = 1, DINFZ - DO 90 II = NINFE + 1, NINFE + INFZ(I) - INFE(II) = I + 1 - 90 CONTINUE - NINFE = NINFE + INFZ(I) - 100 CONTINUE -C - IWORK(1) = NSINFE - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AG08BZ *** - END diff --git a/slycot/src/AG8BYZ.f b/slycot/src/AG8BYZ.f deleted file mode 100644 index 4f08c12e..00000000 --- a/slycot/src/AG8BYZ.f +++ /dev/null @@ -1,694 +0,0 @@ - SUBROUTINE AG8BYZ( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, - $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, - $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To extract from the (N+P)-by-(M+N) descriptor system pencil -C -C S(lambda) = ( B A - lambda*E ) -C ( D C ) -C -C with E nonsingular and upper triangular a -C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil -C -C ( Br Ar-lambda*Er ) -C Sr(lambda) = ( ) -C ( Dr Cr ) -C -C having the same finite Smith zeros as the pencil -C S(lambda) but with Dr, a PR-by-M full row rank -C left upper trapezoidal matrix, and Er, an NR-by-NR -C upper triangular nonsingular matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C FIRST LOGICAL -C Specifies if AG8BYZ is called first time or it is called -C for an already reduced system, with D full column rank -C with the last M rows in upper triangular form: -C FIRST = .TRUE., first time called; -C FIRST = .FALSE., not first time called. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of matrix B, the number of columns of -C matrix C and the order of square matrices A and E. -C N >= 0. -C -C M (input) INTEGER -C The number of columns of matrices B and D. M >= 0. -C M <= P if FIRST = .FALSE. . -C -C P (input) INTEGER -C The number of rows of matrices C and D. P >= 0. -C -C SVLMAX (input) DOUBLE PRECISION -C During each reduction step, the rank-revealing QR -C factorization of a matrix stops when the estimated minimum -C singular value is smaller than TOL * MAX(SVLMAX,EMSV), -C where EMSV is the estimated maximum singular value. -C SVLMAX >= 0. -C -C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) -C On entry, the leading (N+P)-by-(M+N) part of this array -C must contain the compound matrix -C ( B A ) , -C ( D C ) -C where A is an N-by-N matrix, B is an N-by-M matrix, -C C is a P-by-N matrix and D is a P-by-M matrix. -C If FIRST = .FALSE., then D must be a full column -C rank matrix with the last M rows in upper triangular form. -C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD -C contains the reduced compound matrix -C ( Br Ar ) , -C ( Dr Cr ) -C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, -C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank -C left upper trapezoidal matrix with the first PR columns -C in upper triangular form. -C -C LDABCD INTEGER -C The leading dimension of array ABCD. -C LDABCD >= MAX(1,N+P). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular nonsingular matrix E. -C On exit, the leading NR-by-NR part contains the reduced -C upper triangular nonsingular matrix Er. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C NR (output) INTEGER -C The order of the reduced matrices Ar and Er; also the -C number of rows of the reduced matrix Br and the number -C of columns of the reduced matrix Cr. -C If Dr is invertible, NR is also the number of finite -C Smith zeros. -C -C PR (output) INTEGER -C The rank of the resulting matrix Dr; also the number of -C rows of reduced matrices Cr and Dr. -C -C NINFZ (output) INTEGER -C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . -C -C DINFZ (output) INTEGER -C The maximal multiplicity of infinite zeros. -C DINFZ = 0 if FIRST = .FALSE. . -C -C NKRONL (output) INTEGER -C The maximal dimension of left elementary Kronecker blocks. -C -C INFZ (output) INTEGER array, dimension (N) -C INFZ(i) contains the number of infinite zeros of -C degree i, where i = 1,2,...,DINFZ. -C INFZ is not referenced if FIRST = .FALSE. . -C -C KRONL (output) INTEGER array, dimension (N+1) -C KRONL(i) contains the number of left elementary Kronecker -C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used in rank decisions to determine the -C effective rank, which is defined as the order of the -C largest leading (or trailing) triangular submatrix in the -C QR (or RQ) factorization with column (or row) pivoting -C whose estimated condition number is less than 1/TOL. -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used -C instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C NOTE that when SVLMAX > 0, the estimated ranks could be -C less than those defined above (see SVLMAX). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C If FIRST = .FALSE., IWORK is not referenced. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= 2*MAX(M,P), if FIRST = .TRUE.; -C LDWORK >= 2*P, if FIRST = .FALSE. . -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= 1, if P = 0; otherwise -C LZWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 3*P ), -C if FIRST = .TRUE.; -C LZWORK >= MAX( 1, N+M-1, 3*P ), if FIRST = .FALSE. . -C The second term is not needed if M = 0. -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithm of [1]. -C -C REFERENCES -C -C [1] P. Misra, P. Van Dooren and A. Varga. -C Computation of structural invariants of generalized -C state-space systems. -C Automatica, 30, pp. 1921-1936, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( (P+N)*(M+N)*N ) floating point operations. -C -C FURTHER COMMENTS -C -C The number of infinite zeros is computed as -C -C DINFZ -C NINFZ = Sum (INFZ(i)*i) . -C i=1 -C Note that each infinite zero of multiplicity k corresponds to -C an infinite eigenvalue of multiplicity k+1. -C The multiplicities of the infinite eigenvalues can be determined -C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: -C -C DINFZ -C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; -C i=1 -C -C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, -C for i = 1, ..., DINFZ. -C -C The left Kronecker indices are: -C -C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] -C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C May 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, multivariable -C system, unitary transformation, structural invariant. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ONE, P05, ZERO - PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) - COMPLEX*16 CONE, CZERO - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), - $ CZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER DINFZ, INFO, LDABCD, LDE, LZWORK, M, N, NINFZ, - $ NKRONL, NR, P, PR - DOUBLE PRECISION SVLMAX, TOL - LOGICAL FIRST -C .. Array Arguments .. - INTEGER INFZ( * ), IWORK(*), KRONL( * ) - DOUBLE PRECISION DWORK( * ) - COMPLEX*16 ABCD( LDABCD, * ), E( LDE, * ), ZWORK( * ) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, - $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, - $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, - $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT - DOUBLE PRECISION C, RCOND, SMAX, SMAXPR, SMIN, SMINPR, T, TT - COMPLEX*16 C1, C2, S, S1, S2, TC -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) - COMPLEX*16 DUM(1) -C .. External Functions .. - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DZNRM2 - EXTERNAL DLAMCH, DZNRM2, IDAMAX, ILAENV -C .. External Subroutines .. - EXTERNAL MB3OYZ, XERBLA, ZCOPY, ZLAIC1, ZLAPMT, ZLARFG, - $ ZLARTG, ZLASET, SLCT_ZLATZM, ZROT, ZSWAP, - $ ZUNMQR -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C -C Test the input parameters. -C - LQUERY = ( LZWORK.EQ.-1 ) - INFO = 0 - PN = P + N - MN = M + N - MPM = MIN( P, M ) - IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -17 - ELSE - WRKOPT = MAX( 1, 3*P ) - IF( P.GT.0 ) THEN - IF( M.GT.0 ) THEN - WRKOPT = MAX( WRKOPT, MN-1 ) - IF( FIRST ) THEN - WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, - $ MPM, -1 ) ) - WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) - END IF - END IF - END IF - END IF - IF( LZWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN - INFO = -21 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'AG8BYZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize output variables. -C - PR = P - NR = N - DINFZ = 0 - NINFZ = 0 - NKRONL = 0 -C -C Quick return if possible. -C - IF( P.EQ.0 ) THEN - ZWORK(1) = CONE - RETURN - END IF - IF( N.EQ.0 .AND. M.EQ.0 ) THEN - PR = 0 - NKRONL = 1 - KRONL(1) = P - ZWORK(1) = CONE - RETURN - END IF -C - RCOND = TOL - IF( RCOND.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) - END IF -C -C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and -C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. -C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column -C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. -C - IF( FIRST ) THEN - SIGMA = 0 - ELSE - SIGMA = M - END IF - RO = P - SIGMA - MP1 = M + 1 - MUI = 0 - DUM(1) = CZERO -C - ITAU = 1 - JWORK1 = ITAU + MPM - ISMIN = 1 - ISMAX = ISMIN + P - JWORK2 = ISMAX + P - NBLCKS = 0 - WRKOPT = 1 -C - 10 IF( PR.EQ.0 ) GO TO 90 -C -C (NR+1,ICOL+1) points to the current position of matrix D. -C - RO1 = RO - MNR = M + NR - IF( M.GT.0 ) THEN -C -C Compress rows of D; first exploit the trapezoidal shape of the -C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; -C compress the first SIGMA columns without column pivoting: -C -C ( x x x x x ) ( x x x x x ) -C ( x x x x x ) ( 0 x x x x ) -C ( x x x x x ) - > ( 0 0 x x x ) -C ( 0 x x x x ) ( 0 0 0 x x ) -C ( 0 0 x x x ) ( 0 0 0 x x ) -C -C where SIGMA = 3 and RO = 2. -C Complex workspace: need maximum M+N-1. -C - IROW = NR - DO 20 ICOL = 1, SIGMA - IROW = IROW + 1 - CALL ZLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, - $ TC ) -C RvP, replaced by slicot replacement for obsolete lapack routine - CALL SLCT_ZLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, - $ DCONJG( TC ), ABCD(IROW,ICOL+1), - $ ABCD(IROW+1,ICOL+1), LDABCD, ZWORK ) - CALL ZCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) - 20 CONTINUE - WRKOPT = MAX( WRKOPT, MN - 1 ) -C - IF( FIRST ) THEN -C -C Continue with Householder with column pivoting. -C -C ( x x x x x ) ( x x x x x ) -C ( 0 x x x x ) ( 0 x x x x ) -C ( 0 0 x x x ) - > ( 0 0 x x x ) -C ( 0 0 0 x x ) ( 0 0 0 x x ) -C ( 0 0 0 x x ) ( 0 0 0 0 0 ) -C -C Real workspace: need maximum 2*M; -C Complex workspace: need maximum min(P,M)+3*M-1; -C Integer workspace: need maximum M. -C - IROW = MIN( NR+SIGMA+1, PN ) - ICOL = MIN( SIGMA+1, M ) - CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, - $ RCOND, SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), - $ DWORK, ZWORK(JWORK1), INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) -C -C Apply the column permutations to B and part of D. -C - CALL ZLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), - $ LDABCD, IWORK ) -C - IF( RANK.GT.0 ) THEN -C -C Apply the Householder transformations to the submatrix C. -C Complex workspace: need maximum min(P,M) + N; -C prefer maximum min(P,M) + N*NB. -C - CALL ZUNMQR( 'Left', 'ConjTranspose', RO1, NR, RANK, - $ ABCD(IROW,ICOL), LDABCD, ZWORK(ITAU), - $ ABCD(IROW,MP1), LDABCD, ZWORK(JWORK1), - $ LZWORK-JWORK1+1, INFO ) - WRKOPT = MAX( WRKOPT, JWORK1 + INT( ZWORK(JWORK1) ) - 1 ) - CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), CZERO, - $ CZERO, ABCD(MIN( IROW+1, PN ),ICOL), - $ LDABCD ) - RO1 = RO1 - RANK - END IF - END IF -C -C Terminate if Dr has maximal row rank. -C - IF( RO1.EQ.0 ) GO TO 90 -C - END IF -C -C Update SIGMA. -C - SIGMA = PR - RO1 -C - NBLCKS = NBLCKS + 1 - TAUI = RO1 -C -C Compress the columns of current C to separate a TAUI-by-MUI -C full column rank block. -C - IF( NR.EQ.0 ) THEN -C -C Finish for zero state dimension. -C - PR = SIGMA - RANK = 0 - ELSE -C -C Perform RQ-decomposition with row pivoting on the current C -C while keeping E upper triangular. -C The current C is the TAUI-by-NR matrix delimited by rows -C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. -C The rank of current C is computed in MUI. -C Real workspace: need maximum 2*P; -C Complex workspace: need maximum 3*P. -C - IRC = NR + SIGMA - N1 = NR - IF( TAUI.GT.1 ) THEN -C -C Compute norms. -C - DO 30 I = 1, TAUI - DWORK(I) = DZNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) - DWORK(P+I) = DWORK(I) - 30 CONTINUE - END IF -C - RANK = 0 - MNTAU = MIN( TAUI, NR ) -C -C ICOL and IROW will point to the current pivot position in C. -C - ILAST = NR + PR - JLAST = M + NR - IROW = ILAST - ICOL = JLAST - I = TAUI - 40 IF( RANK.LT.MNTAU ) THEN - MN1 = M + N1 -C -C Pivot if necessary. -C - IF( I.NE.1 ) THEN - J = IDAMAX( I, DWORK, 1 ) - IF( J.NE.I ) THEN - DWORK(J) = DWORK(I) - DWORK(P+J) = DWORK(P+I) - CALL ZSWAP( N1, ABCD(IROW,MP1), LDABCD, - $ ABCD(IRC+J,MP1), LDABCD ) - END IF - END IF -C -C Zero elements left to ABCD(IROW,ICOL). -C - DO 50 K = 1, N1-1 - J = M + K -C -C Rotate columns J, J+1 to zero ABCD(IROW,J). -C - TC = ABCD(IROW,J+1) - CALL ZLARTG( TC, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) - ABCD(IROW,J) = CZERO - CALL ZROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) - CALL ZROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) -C -C Rotate rows K, K+1 to zero E(K+1,K). -C - TC = E(K,K) - CALL ZLARTG( TC, E(K+1,K), C, S, E(K,K) ) - E(K+1,K) = CZERO - CALL ZROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) - CALL ZROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, - $ C, S ) - 50 CONTINUE -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( ABCD(ILAST,JLAST) ) - IF ( SMAX.EQ.ZERO ) GO TO 80 - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = CONE - C2 = CONE - ELSE -C -C One step of incremental condition estimation. -C Complex workspace: need maximum 3*P. -C - CALL ZCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, - $ ZWORK(JWORK2), 1 ) - CALL ZLAIC1( IMIN, RANK, ZWORK(ISMIN), SMIN, - $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, - $ C1 ) - CALL ZLAIC1( IMAX, RANK, ZWORK(ISMAX), SMAX, - $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, - $ C2 ) - WRKOPT = MAX( WRKOPT, 3*P ) - END IF -C -C Check the rank; finish the loop if rank loss occurs. -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Finish the loop if last row. -C - IF( N1.EQ.0 ) THEN - RANK = RANK + 1 - GO TO 80 - END IF -C - IF( N1.GT.1 ) THEN -C -C Update norms. -C - IF( I-1.GT.1 ) THEN - DO 60 J = 1, I - 1 - IF( DWORK(J).NE.ZERO ) THEN - T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) - $ /DWORK(J) )**2 - T = MAX( T, ZERO ) - TT = ONE + - $ P05*T*( DWORK(J)/DWORK(P+J) )**2 - IF( TT.NE.ONE ) THEN - DWORK(J) = DWORK(J)*SQRT( T ) - ELSE - DWORK(J) = DZNRM2( N1-1, - $ ABCD(IRC+J,MP1), LDABCD ) - DWORK(P+J) = DWORK(J) - END IF - END IF - 60 CONTINUE - END IF - END IF -C - DO 70 J = 1, RANK - ZWORK(ISMIN+J-1) = S1*ZWORK(ISMIN+J-1) - ZWORK(ISMAX+J-1) = S2*ZWORK(ISMAX+J-1) - 70 CONTINUE -C - ZWORK(ISMIN+RANK) = C1 - ZWORK(ISMAX+RANK) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - ICOL = ICOL - 1 - IROW = IROW - 1 - N1 = N1 - 1 - I = I - 1 - GO TO 40 - END IF - END IF - END IF - END IF - END IF -C - 80 CONTINUE - MUI = RANK - NR = NR - MUI - PR = SIGMA + MUI -C -C Set number of left Kronecker blocks of order (i-1)-by-i. -C - KRONL(NBLCKS) = TAUI - MUI -C -C Set number of infinite divisors of order i-1. -C - IF( FIRST .AND. NBLCKS.GT.1 ) - $ INFZ(NBLCKS-1) = MUIM1 - TAUI - MUIM1 = MUI - RO = MUI -C -C Continue reduction if rank of current C is positive. -C - IF( MUI.GT.0 ) - $ GO TO 10 -C -C Determine the maximal degree of infinite zeros and -C the number of infinite zeros. -C - 90 CONTINUE - IF( FIRST ) THEN - IF( MUI.EQ.0 ) THEN - DINFZ = MAX( 0, NBLCKS - 1 ) - ELSE - DINFZ = NBLCKS - INFZ(NBLCKS) = MUI - END IF - K = DINFZ - DO 100 I = K, 1, -1 - IF( INFZ(I).NE.0 ) GO TO 110 - DINFZ = DINFZ - 1 - 100 CONTINUE - 110 CONTINUE - DO 120 I = 1, DINFZ - NINFZ = NINFZ + INFZ(I)*I - 120 CONTINUE - END IF -C -C Determine the maximal order of left elementary Kronecker blocks. -C - NKRONL = NBLCKS - DO 130 I = NBLCKS, 1, -1 - IF( KRONL(I).NE.0 ) GO TO 140 - NKRONL = NKRONL - 1 - 130 CONTINUE - 140 CONTINUE -C - ZWORK(1) = WRKOPT - RETURN -C *** Last line of AG8BYZ *** - END diff --git a/slycot/src/BB01AD.f b/slycot/src/BB01AD.f deleted file mode 100644 index 8eafe1f3..00000000 --- a/slycot/src/BB01AD.f +++ /dev/null @@ -1,1286 +0,0 @@ - SUBROUTINE BB01AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, - 1 A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, - 2 DWORK, LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate the benchmark examples for the numerical solution of -C continuous-time algebraic Riccati equations (CAREs) of the form -C -C 0 = Q + A'X + XA - XGX -C -C corresponding to the Hamiltonian matrix -C -C ( A G ) -C H = ( T ). -C ( Q -A ) -C -C A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may -C be given in factored form -C -C -1 T T -C (I) G = B R B , (II) Q = C W C . -C -C Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W -C and R are symmetric. In linear-quadratic optimal control problems, -C usually W is positive semidefinite and R positive definite. The -C factorized form can be used if the CARE is solved using the -C deflating subspaces of the extended Hamiltonian pencil -C -C ( A 0 B ) ( I 0 0 ) -C ( T ) ( ) -C H - s K = ( Q A 0 ) - s ( 0 -I 0 ) , -C ( T ) ( ) -C ( 0 B R ) ( 0 0 0 ) -C -C where I and 0 denote the identity and zero matrix, respectively, -C of appropriate dimensions. -C -C NOTE: the formulation of the CARE and the related matrix (pencils) -C used here does not include CAREs as they arise in robust -C control (H_infinity optimization). -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER -C This parameter specifies if the default parameters are -C to be used or not. -C = 'N' or 'n' : The parameters given in the input vectors -C xPAR (x = 'D', 'I', 'B', 'CH') are used. -C = 'D' or 'd' : The default parameters for the example -C are used. -C This parameter is not meaningful if NR(1) = 1. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C This array determines the example for which CAREX returns -C data. NR(1) is the group of examples. -C NR(1) = 1 : parameter-free problems of fixed size. -C NR(1) = 2 : parameter-dependent problems of fixed size. -C NR(1) = 3 : parameter-free problems of scalable size. -C NR(1) = 4 : parameter-dependent problems of scalable size. -C NR(2) is the number of the example in group NR(1). -C Let NEXi be the number of examples in group i. Currently, -C NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4. -C 1 <= NR(1) <= 4; -C 1 <= NR(2) <= NEXi , where i = NR(1). -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (7) -C Double precision parameter vector. For explanation of the -C parameters see [1]. -C DPAR(1) : defines the parameters -C 'delta' for NR(1) = 3, -C 'q' for NR(1).NR(2) = 4.1, -C 'a' for NR(1).NR(2) = 4.2, and -C 'mu' for NR(1).NR(2) = 4.3. -C DPAR(2) : defines parameters -C 'r' for NR(1).NR(2) = 4.1, -C 'b' for NR(1).NR(2) = 4.2, and -C 'delta' for NR(1).NR(2) = 4.3. -C DPAR(3) : defines parameters -C 'c' for NR(1).NR(2) = 4.2 and -C 'kappa' for NR(1).NR(2) = 4.3. -C DPAR(j), j=4,5,6,7: These arguments are only used to -C generate Example 4.2 and define in -C consecutive order the intervals -C ['beta_1', 'beta_2'], -C ['gamma_1', 'gamma_2']. -C NOTE that if DEF = 'D' or 'd', the values of DPAR entries -C on input are ignored and, on output, they are overwritten -C with the default parameters. -C -C IPAR (input/output) INTEGER array, dimension (3) -C On input, IPAR(1) determines the actual state dimension, -C i.e., the order of the matrix A as follows, where -C NO = NR(1).NR(2). -C NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored. -C NO = 2.9 : IPAR(1) = 1 generates the CARE for -C optimal state feedback (default); -C IPAR(1) = 2 generates the Kalman -C filter CARE. -C NO = 3.1 : IPAR(1) is the number of vehicles -C (parameter 'l' in the description -C in [1]). -C NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix -C A. -C NO = 4.3 or 4.4 : IPAR(1) determines the dimension of -C the second-order system, i.e., the -C order of the stiffness matrix for -C Examples 4.3 and 4.4 (parameter 'l' -C in the description in [1]). -C -C The order of the output matrix A is N = 2*IPAR(1) for -C Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4. -C NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For -C the other examples, IPAR(1) is overwritten if the default -C parameters are to be used. -C On output, IPAR(1) contains the order of the matrix A. -C -C On input, IPAR(2) is the number of colums in the matrix B -C in (I) (in control problems, the number of inputs of the -C system). Currently, IPAR(2) is fixed or determined by -C IPAR(1) for all examples and thus is not referenced on -C input. -C On output, IPAR(2) is the number of columns of the -C matrix B from (I). -C NOTE that currently IPAR(2) is overwritten and that -C rank(G) <= IPAR(2). -C -C On input, IPAR(3) is the number of rows in the matrix C -C in (II) (in control problems, the number of outputs of the -C system). Currently, IPAR(3) is fixed or determined by -C IPAR(1) for all examples and thus is not referenced on -C input. -C On output, IPAR(3) contains the number of rows of the -C matrix C in (II). -C NOTE that currently IPAR(3) is overwritten and that -C rank(Q) <= IPAR(3). -C -C BPAR (input) BOOLEAN array, dimension (6) -C This array defines the form of the output of the examples -C and the storage mode of the matrices G and Q. -C BPAR(1) = .TRUE. : G is returned. -C BPAR(1) = .FALSE. : G is returned in factored form, i.e., -C B and R from (I) are returned. -C BPAR(2) = .TRUE. : The matrix returned in array G (i.e., -C G if BPAR(1) = .TRUE. and R if -C BPAR(1) = .FALSE.) is stored as full -C matrix. -C BPAR(2) = .FALSE. : The matrix returned in array G is -C provided in packed storage mode. -C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix -C returned in array G is stored in upper -C packed mode, i.e., the upper triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C G(i,j) is stored in the array entry -C G(i+j*(j-1)/2) for i <= j. -C Otherwise, this entry is ignored. -C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix -C returned in array G is stored in lower -C packed mode, i.e., the lower triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C G(i,j) is stored in the array entry -C G(i+(2*n-j)*(j-1)/2) for j <= i. -C Otherwise, this entry is ignored. -C BPAR(4) = .TRUE. : Q is returned. -C BPAR(4) = .FALSE. : Q is returned in factored form, i.e., -C C and W from (II) are returned. -C BPAR(5) = .TRUE. : The matrix returned in array Q (i.e., -C Q if BPAR(4) = .TRUE. and W if -C BPAR(4) = .FALSE.) is stored as full -C matrix. -C BPAR(5) = .FALSE. : The matrix returned in array Q is -C provided in packed storage mode. -C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix -C returned in array Q is stored in upper -C packed mode (see above). -C Otherwise, this entry is ignored. -C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix -C returned in array Q is stored in lower -C packed mode (see above). -C Otherwise, this entry is ignored. -C NOTE that there are no default values for BPAR. If all -C entries are declared to be .TRUE., then matrices G and Q -C are returned in conventional storage mode, i.e., as -C N-by-N arrays where the array element Z(I,J) contains the -C matrix entry Z_{i,j}. -C -C CHPAR (input/output) CHARACTER*255 -C On input, this is the name of a data file supplied by the -C user. -C In the current version, only Example 4.4 allows a -C user-defined data file. This file must contain -C consecutively DOUBLE PRECISION vectors mu, delta, gamma, -C and kappa. The length of these vectors is determined by -C the input value for IPAR(1). -C If on entry, IPAR(1) = L, then mu and delta must each -C contain L DOUBLE PRECISION values, and gamma and kappa -C must each contain L-1 DOUBLE PRECISION values. -C On output, this string contains short information about -C the chosen example. -C -C VEC (output) LOGICAL array, dimension (9) -C Flag vector which displays the availability of the output -C data: -C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and -C are always .TRUE. -C VEC(4) refers to A and is always .TRUE. -C VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B -C and R from (I) are returned. -C VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C -C and W from (II) are returned. -C VEC(7) refers to G and is always .TRUE. -C VEC(8) refers to Q and is always .TRUE. -C VEC(9) refers to X and is .TRUE. if the exact solution -C matrix is available. -C NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit -C INFO .NE. 0. -C -C N (output) INTEGER -C The order of the matrices A, X, G if BPAR(1) = .TRUE., and -C Q if BPAR(4) = .TRUE. -C -C M (output) INTEGER -C The number of columns in the matrix B (or the dimension of -C the control input space of the underlying dynamical -C system). -C -C P (output) INTEGER -C The number of rows in the matrix C (or the dimension of -C the output space of the underlying dynamical system). -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C coefficient matrix A of the CARE. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If (BPAR(1) = .FALSE.), then the leading N-by-M part of -C this array contains the matrix B of the factored form (I) -C of G. Otherwise, B is used as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C If (BPAR(4) = .FALSE.), then the leading P-by-N part of -C this array contains the matrix C of the factored form (II) -C of Q. Otherwise, C is used as workspace. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= P, where P is the number of rows of the matrix C, -C i.e., the output value of IPAR(3). (For all examples, -C P <= N, where N equals the output value of the argument -C IPAR(1), i.e., LDC >= LDA is always safe.) -C -C G (output) DOUBLE PRECISION array, dimension (NG) -C If (BPAR(2) = .TRUE.) then NG = LDG*N. -C If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2. -C If (BPAR(1) = .TRUE.), then array G contains the -C coefficient matrix G of the CARE. -C If (BPAR(1) = .FALSE.), then array G contains the 'control -C weighting matrix' R of G's factored form as in (I). (For -C all examples, M <= N.) The symmetric matrix contained in -C array G is stored according to BPAR(2) and BPAR(3). -C -C LDG INTEGER -C If conventional storage mode is used for G, i.e., -C BPAR(2) = .TRUE., then G is stored like a 2-dimensional -C array with leading dimension LDG. If packed symmetric -C storage mode is used, then LDG is not referenced. -C LDG >= N if BPAR(2) = .TRUE.. -C -C Q (output) DOUBLE PRECISION array, dimension (NQ) -C If (BPAR(5) = .TRUE.) then NQ = LDQ*N. -C If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2. -C If (BPAR(4) = .TRUE.), then array Q contains the -C coefficient matrix Q of the CARE. -C If (BPAR(4) = .FALSE.), then array Q contains the 'output -C weighting matrix' W of Q's factored form as in (II). -C The symmetric matrix contained in array Q is stored -C according to BPAR(5) and BPAR(6). -C -C LDQ INTEGER -C If conventional storage mode is used for Q, i.e., -C BPAR(5) = .TRUE., then Q is stored like a 2-dimensional -C array with leading dimension LDQ. If packed symmetric -C storage mode is used, then LDQ is not referenced. -C LDQ >= N if BPAR(5) = .TRUE.. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1)) -C If an exact solution is available (NR = 1.1, 1.2, 2.1, -C 2.3-2.6, 3.2), then the leading N-by-N part of this array -C contains the solution matrix X in conventional storage -C mode. Otherwise, X is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 1, and -C LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= N*MAX(4,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0 : successful exit; -C < 0 : if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : data file could not be opened or had wrong format; -C = 2 : division by zero; -C = 3 : G can not be computed as in (I) due to a singular R -C matrix. -C -C REFERENCES -C -C [1] Abels, J. and Benner, P. -C CAREX - A Collection of Benchmark Examples for Continuous-Time -C Algebraic Riccati Equations (Version 2.0). -C SLICOT Working Note 1999-14, November 1999. Available from -C http://www.win.tue.nl/niconet/NIC2/reports.html. -C -C This is an updated and extended version of -C -C [2] Benner, P., Laub, A.J., and Mehrmann, V. -C A Collection of Benchmark Examples for the Numerical Solution -C of Algebraic Riccati Equations I: Continuous-Time Case. -C Technical Report SPC 95_22, Fak. f. Mathematik, -C TU Chemnitz-Zwickau (Germany), October 1995. -C -C NUMERICAL ASPECTS -C -C If the original data as taken from the literature is given via -C matrices G and Q, but factored forms are requested as output, then -C these factors are obtained from Cholesky or LDL' decompositions of -C G and Q, i.e., the output data will be corrupted by roundoff -C errors. -C -C FURTHER COMMENTS -C -C Some benchmark examples read data from the data files provided -C with the collection. -C -C CONTRIBUTOR -C -C Peter Benner (Universitaet Bremen), November 15, 1999. -C -C For questions concerning the collection or for the submission of -C test examples, please send e-mail to benner@math.uni-bremen.de. -C -C REVISIONS -C -C 1999, December 23 (V. Sima). -C -C KEYWORDS -C -C Algebraic Riccati equation, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. -C . # of examples available , # of examples with fixed size. . - INTEGER NEX1, NEX2, NEX3, NEX4, NMAX - PARAMETER ( NMAX = 9, NEX1 = 6, NEX2 = 9, NEX3 = 2, - 1 NEX4 = 4 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, - 2 PI = .3141592653589793D1 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N, - $ P - CHARACTER DEF -C -C .. Array Arguments .. - INTEGER IPAR(3), NR(2) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), - 1 G(*), Q(*), X(LDX,*) - CHARACTER CHPAR*255 - LOGICAL BPAR(6), VEC(9) -C -C .. Local Scalars .. - INTEGER GDIMM, I, IOS, ISYMM, J, K, L, MSYMM, NSYMM, POS, - 1 PSYMM, QDIMM - DOUBLE PRECISION APPIND, B1, B2, C1, C2, SUM, TEMP, TTEMP -C -C ..Local Arrays .. - INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) - DOUBLE PRECISION PARDEF(4,NMAX) - CHARACTER IDENT*4 - CHARACTER*255 NOTES(4,NMAX) -C -C .. External Functions .. -C . BLAS . - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C . LAPACK . - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL LSAME, DLAPY2 -C -C .. External Subroutines .. -C . BLAS . - EXTERNAL DCOPY, DGEMV, DSCAL, DSPMV, DSPR, DSYMM, DSYRK -C . LAPACK . - EXTERNAL DLASET, DPPTRF, DPPTRI, DPTTRF, DPTTRS, XERBLA -C . SLICOT . - EXTERNAL MA02DD, MA02ED -C -C .. Intrinsic Functions .. - INTRINSIC COS, MAX, MIN, MOD, SQRT -C -C .. Data Statements .. -C . default values for dimensions . - DATA (NEX(I), I = 1, 4) /NEX1, NEX2, NEX3, NEX4/ - DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 30/ - DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 2, 2, 3, 4, 4, 55/ - DATA (NDEF(3,I), I = 1, NEX3) /20, 64/ - DATA (NDEF(4,I), I = 1, NEX4) /21, 100, 30, 211/ - DATA (MDEF(1,I), I = 1, NEX1) /1, 1, 2, 2, 3, 3/ - DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 2, 1, 3, 1, 1, 2/ - DATA (PDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 5/ - DATA (PDEF(2,I), I = 1, NEX2) /1, 1, 2, 2, 2, 3, 2, 1, 10/ -C . default values for parameters . - DATA (PARDEF(1,I), I = 1, NEX1) /ZERO, ZERO, ZERO, ZERO, ZERO, - 1 ZERO/ - DATA (PARDEF(2,I), I = 1, NEX2) /.1D-5, .1D-7, .1D7, .1D-6, ZERO, - 1 .1D7, .1D-5, .1D-5, .1D1/ - DATA (PARDEF(3,I), I = 1, NEX3) /ZERO, ZERO/ - DATA (PARDEF(4,I), I = 1, NEX4) /ONE, .1D-1, FOUR, ZERO/ -C . comments on examples . - DATA (NOTES(1,I), I = 1, NEX1) / - 1'Laub 1979, Ex.1', 'Laub 1979, Ex.2: uncontrollable-unobservable d - 2ata', 'Beale/Shafai 1989: model of L-1011 aircraft', 'Bhattacharyy - 3a et al. 1983: binary distillation column', 'Patnaik et al. 1980: - 4tubular ammonia reactor', 'Davison/Gesing 1978: J-100 jet engine'/ - DATA (NOTES(2,I), I = 1, NEX2) / - 1'Arnold/Laub 1984, Ex.1: (A,B) unstabilizable as EPS -> 0', 'Arnol - 2d/Laub 1984, Ex.3: control weighting matrix singular as EPS -> 0', - 3'Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo', - 4'Bai/Qian 1994: ill-conditioned Hamiltonian for EPS -> 0', 'Laub 1 - 5992: H-infinity problem, eigenvalues +/- EPS +/- i', 'Petkov et a - 6l. 1987: increasingly badly scaled Hamiltonian as EPS -> oo', 'Cho - 7w/Kokotovic 1976: magnetic tape control system', 'Arnold/Laub 1984 - 8, Ex.2: poor sep. of closed-loop spectrum as EPS -> 0', 'IFAC Benc - 9hmark Problem #90-06: LQG design for modified Boing B-767 at flutt - 1er condition'/ - DATA (NOTES(3,I), I = 1, NEX3) / - 1'Laub 1979, Ex.4: string of high speed vehicles', 'Laub 1979, Ex.5 - 2: circulant matrices'/ - DATA (NOTES(4,I), I = 1, NEX4) / - 1'Laub 1979, Ex.6: ill-conditioned Riccati equation', 'Rosen/Wang 1 - 2992: lq control of 1-dimensional heat flow','Hench et al. 1995: co - 3upled springs, dashpots and masses','Lang/Penzl 1994: rotating axl - 4e' / -C -C .. Executable Statements .. -C - INFO = 0 - DO 5 I = 1, 9 - VEC(I) = .FALSE. - 5 CONTINUE -C - IF ((NR(1) .NE. 1) .AND. (.NOT. (LSAME(DEF,'N') - 1 .OR. LSAME(DEF,'D')))) THEN - INFO = -1 - ELSE IF ((NR(1) .LT. 1) .OR. (NR(2) .LT. 1) .OR. - 1 (NR(1) .GT. 4) .OR. (NR(2) .GT. NEX(NR(1)))) THEN - INFO = -2 - ELSE IF (NR(1) .GT. 2) THEN - IF (.NOT. LSAME(DEF,'N')) IPAR(1) = NDEF(NR(1),NR(2)) - IF (NR(1) .EQ. 3) THEN - IF (NR(2) .EQ. 1) THEN - IPAR(2) = IPAR(1) - IPAR(3) = IPAR(1) - 1 - IPAR(1) = 2*IPAR(1) - 1 - ELSE IF (NR(2) .EQ. 2) THEN - IPAR(2) = IPAR(1) - IPAR(3) = IPAR(1) - ELSE - IPAR(2) = 1 - IPAR(3) = 1 - END IF - ELSE IF (NR(1) .EQ. 4) THEN - IF (NR(2) .EQ. 3) THEN - L = IPAR(1) - IPAR(2) = 2 - IPAR(3) = 2*L - IPAR(1) = 2*L - ELSE IF (NR(2) .EQ. 4) THEN - L = IPAR(1) - IPAR(2) = L - IPAR(3) = L - IPAR(1) = 2*L-1 - ELSE - IPAR(2) = 1 - IPAR(3) = 1 - END IF - END IF - ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 9) .AND. - 1 (IPAR(1) . EQ. 2)) THEN - IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = MDEF(NR(1),NR(2)) - IPAR(3) = 3 - ELSE - IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = MDEF(NR(1),NR(2)) - IPAR(3) = PDEF(NR(1),NR(2)) - END IF - IF (INFO .NE. 0) GOTO 7 -C - IF (IPAR(1) .LT. 1) THEN - INFO = -4 - ELSE IF (IPAR(1) .GT. LDA) THEN - INFO = -12 - ELSE IF (IPAR(1) .GT. LDB) THEN - INFO = -14 - ELSE IF (IPAR(3) .GT. LDC) THEN - INFO = -16 - ELSE IF (BPAR(2) .AND. (IPAR(1).GT. LDG)) THEN - INFO = -18 - ELSE IF (BPAR(5) .AND. (IPAR(1).GT. LDQ)) THEN - INFO = -20 - ELSE IF (LDX.LT.1) THEN - INFO = -22 - ELSE IF ((NR(1) .EQ. 1) .AND. - $ ((NR(2) .EQ. 1) .OR. (NR(2) .EQ.2))) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 1)) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF ((NR(1) .EQ. 2) .AND. ((NR(2) .GE. 3) .AND. - 1 (NR(2) .LE. 6))) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF ((NR(1) .EQ. 3) .AND. (NR(2) .EQ. 2)) THEN - IF (IPAR(1) .GT. LDX) INFO = -22 - ELSE IF (LDWORK .LT. N*(MAX(4,N))) THEN - INFO = -24 - END IF -C - 7 CONTINUE - IF (INFO .NE. 0) THEN - CALL XERBLA( 'BB01AD', -INFO ) - RETURN - END IF -C - NSYMM = (IPAR(1)*(IPAR(1)+1))/2 - MSYMM = (IPAR(2)*(IPAR(2)+1))/2 - PSYMM = (IPAR(3)*(IPAR(3)+1))/2 - IF (.NOT. LSAME(DEF,'N')) DPAR(1) = PARDEF(NR(1),NR(2)) -C - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) - CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) - CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) - CALL DLASET('L', MSYMM, 1, ZERO, ZERO, G, 1) - CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) -C - IF (NR(1) .EQ. 1) THEN - IF (NR(2) .EQ. 1) THEN - A(1,2) = ONE - B(2,1) = ONE - Q(1) = ONE - Q(3) = TWO - IDENT = '0101' - CALL DLASET('A', IPAR(1), IPAR(1), ONE, TWO, X, LDX) -C - ELSE IF (NR(2) .EQ. 2) THEN - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = THREE - A(2,2) = -.35D1 - CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) - Q(1) = 9.0D0 - Q(2) = 6.0D0 - Q(3) = FOUR - IDENT = '0101' - TEMP = ONE + SQRT(TWO) - CALL DLASET('A', IPAR(1), IPAR(1), 6.0D0*TEMP, FOUR*TEMP, X, - 1 LDX) - X(1,1) = 9.0D0*TEMP -C - ELSE IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)) THEN - WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', - 1 NR(2) , '.dat' - IF ((NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4)) THEN - IDENT = '0101' - ELSE IF (NR(2) .EQ. 5) THEN - IDENT = '0111' - ELSE IF (NR(2) .EQ. 6) THEN - IDENT = '0011' - END IF - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE IF (NR(2) .LE. 6) THEN - DO 10 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(I,J), J = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 10 CONTINUE - DO 20 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (B(I,J), J = 1, IPAR(2)) - IF (IOS .NE. 0) INFO = 1 - 20 CONTINUE - IF (NR(2) .LE. 4) THEN - DO 30 I = 1, IPAR(1) - POS = (I-1)*IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) (DWORK(POS+J), - 1 J = 1,IPAR(1)) - 30 CONTINUE - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) - END IF - ELSE IF (NR(2) .EQ. 6) THEN - DO 35 I = 1, IPAR(3) - READ (1, FMT = *, IOSTAT = IOS) - 1 (C(I,J), J = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 35 CONTINUE - END IF - CLOSE(1) - END IF - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (NR(2) .EQ. 1) THEN - A(1,1) = ONE - A(2,2) = -TWO - B(1,1) = DPAR(1) - CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) - IDENT = '0011' - IF (DPAR(1) .NE. ZERO) THEN - TEMP = DLAPY2(ONE, DPAR(1)) - X(1,1) = (ONE + TEMP)/DPAR(1)/DPAR(1) - X(2,1) = ONE/(TWO + TEMP) - X(1,2) = X(2,1) - TTEMP = DPAR(1)*X(1,2) - TEMP = (ONE - TTEMP) * (ONE + TTEMP) - X(2,2) = TEMP / FOUR - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 2) THEN - A(1,1) = -.1D0 - A(2,2) = -.2D-1 - B(1,1) = .1D0 - B(2,1) = .1D-2 - B(2,2) = .1D-1 - CALL DLASET('L', MSYMM, 1, ONE, ONE, G, MSYMM) - G(1) = G(1) + DPAR(1) - C(1,1) = .1D2 - C(1,2) = .1D3 - IDENT = '0010' -C - ELSE IF (NR(2) .EQ. 3) THEN - A(1,2) = DPAR(1) - B(2,1) = ONE - IDENT = '0111' - IF (DPAR(1) .NE. ZERO) THEN - TEMP = SQRT(ONE + TWO*DPAR(1)) - CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, X, LDX) - X(1,1) = X(1,1)/DPAR(1) - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 4) THEN - TEMP = DPAR(1) + ONE - CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, A, LDA) - Q(1) = DPAR(1)**2 - Q(3) = Q(1) - IDENT = '1101' - X(1,1) = TWO*TEMP + SQRT(TWO)*(SQRT(TEMP**2 + ONE) + DPAR(1)) - X(1,1) = X(1,1)/TWO - X(2,2) = X(1,1) - TTEMP = X(1,1) - TEMP - IF (TTEMP .NE. ZERO) THEN - X(2,1) = X(1,1) / TTEMP - X(1,2) = X(2,1) - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 5) THEN - A(1,1) = THREE - DPAR(1) - A(2,1) = FOUR - A(1,2) = ONE - A(2,2) = TWO - DPAR(1) - CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) - Q(1) = FOUR*DPAR(1) - 11.0D0 - Q(2) = TWO*DPAR(1) - 5.0D0 - Q(3) = TWO*DPAR(1) - TWO - IDENT = '0101' - CALL DLASET('A', IPAR(1), IPAR(1), ONE, ONE, X, LDX) - X(1,1) = TWO -C - ELSE IF (NR(2) .EQ. 6) THEN - IF (DPAR(1) .NE. ZERO) THEN - A(1,1) = DPAR(1) - A(2,2) = DPAR(1)*TWO - A(3,3) = DPAR(1)*THREE -C .. set C = V .. - TEMP = TWO/THREE - CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, - 1 C, LDC) - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, A, LDA) -C .. G = R ! .. - G(1) = DPAR(1) - G(4) = DPAR(1) - G(6) = DPAR(1) - Q(1) = ONE/DPAR(1) - Q(4) = ONE - Q(6) = DPAR(1) - IDENT = '1000' - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) - TEMP = DPAR(1)**2 - X(1,1) = TEMP + SQRT(TEMP**2 + ONE) - X(2,2) = TEMP*TWO + SQRT(FOUR*TEMP**2 + DPAR(1)) - X(3,3) = TEMP*THREE + DPAR(1)*SQRT(9.0D0*TEMP + ONE) - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, X, LDX) - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 7) THEN - IF (DPAR(1) .NE. ZERO) THEN - A(1,2) = .400D0 - A(2,3) = .345D0 - A(3,2) = -.524D0/DPAR(1) - A(3,3) = -.465D0/DPAR(1) - A(3,4) = .262D0/DPAR(1) - A(4,4) = -ONE/DPAR(1) - B(4,1) = ONE/DPAR(1) - C(1,1) = ONE - C(2,3) = ONE - IDENT = '0011' - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 8) THEN - A(1,1) = -DPAR(1) - A(2,1) = -ONE - A(1,2) = ONE - A(2,2) = -DPAR(1) - A(3,3) = DPAR(1) - A(4,3) = -ONE - A(3,4) = ONE - A(4,4) = DPAR(1) - CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) - CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) - IDENT = '0011' -C - ELSE IF (NR(2) .EQ. 9) THEN - IF (IPAR(3) .EQ. 10) THEN -C .. read LQR CARE ... - WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', - 1 NR(2), '1.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - DO 36 I = 1, 27, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 36 CONTINUE - DO 37 I = 30, 44, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 37 CONTINUE - DO 38 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(I,J), J = 46, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 38 CONTINUE - A(29,29) = -.5301D1 - B(48,1) = .8D06 - B(51,2) = .8D06 - G(1) = .3647D03 - G(3) = .1459D02 - DO 39 I = 1,6 - READ (1, FMT = *, IOSTAT = IOS) - 1 (C(I,J), J = 1,45) - IF (IOS .NE. 0) INFO = 1 - 39 CONTINUE - C(7,47) = ONE - C(8,46) = ONE - C(9,50) = ONE - C(10,49) = ONE - Q(11) = .376D-13 - Q(20) = .120D-12 - Q(41) = .245D-11 - END IF - ELSE -C .. read Kalman filter CARE .. - WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', - 1 NR(2), '2.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - DO 40 I = 1, 27, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 40 CONTINUE - DO 41 I = 30, 44, 2 - READ (1, FMT = *, IOSTAT = IOS) - 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) - IF (IOS .NE. 0) INFO = 1 - 41 CONTINUE - DO 42 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(J,I), J = 46, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 42 CONTINUE - A(29,29) = -.5301D1 - DO 43 J = 1, IPAR(2) - READ (1, FMT = *, IOSTAT = IOS) - 1 (B(I,J), I = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 43 CONTINUE - G(1) = .685D-5 - G(3) = .373D3 - C(1,52) = .3713 - C(1,53) = .1245D1 - C(2,48) = .8D6 - C(2,54) = ONE - C(3,51) = .8D6 - C(3,55) = ONE - Q(1) = .28224D5 - Q(4) = .2742D-4 - Q(6) = .6854D-3 - END IF - END IF - CLOSE(1) - IDENT = '0000' - END IF -C - ELSE IF (NR(1) .EQ. 3) THEN - IF (NR(2) .EQ. 1) THEN - DO 45 I = 1, IPAR(1) - IF (MOD(I,2) .EQ. 1) THEN - A(I,I) = -ONE - B(I,(I+1)/2) = ONE - ELSE - A(I,I-1) = ONE - A(I,I+1) = -ONE - C(I/2,I) = ONE - END IF - 45 CONTINUE - ISYMM = 1 - DO 50 I = IPAR(3), 1, -1 - Q(ISYMM) = 10.0D0 - ISYMM = ISYMM + I - 50 CONTINUE - IDENT = '0001' -C - ELSE IF (NR(2) .EQ. 2) THEN - DO 60 I = 1, IPAR(1) - A(I,I) = -TWO - IF (I .LT. IPAR(1)) THEN - A(I,I+1) = ONE - A(I+1,I) = ONE - END IF - 60 CONTINUE - A(1,IPAR(1)) = ONE - A(IPAR(1),1) = ONE - IDENT = '1111' - TEMP = TWO * PI / DBLE(IPAR(1)) - DO 70 I = 1, IPAR(1) - DWORK(I) = COS(TEMP*DBLE(I-1)) - DWORK(IPAR(1)+I) = -TWO + TWO*DWORK(I) + - 1 SQRT(5.0D0 + FOUR*DWORK(I)*(DWORK(I) - TWO)) - 70 CONTINUE - DO 90 J = 1, IPAR(1) - DO 80 I = 1, IPAR(1) - DWORK(2*IPAR(1)+I) = COS(TEMP*DBLE(I-1)*DBLE(J-1)) - 80 CONTINUE - X(J,1) = DDOT(IPAR(1), DWORK(IPAR(1)+1), 1, - 1 DWORK(2*IPAR(1)+1), 1)/DBLE(IPAR(1)) - 90 CONTINUE -C .. set up circulant solution matrix .. - DO 100 I = 2, IPAR(1) - CALL DCOPY(IPAR(1)-I+1, X(1,1), 1, X(I,I), 1) - CALL DCOPY(I-1, X(IPAR(1)-I+2,1), 1, X(1,I), 1) - 100 CONTINUE - END IF -C - ELSE IF (NR(1) .EQ. 4) THEN - IF (NR(2) .EQ. 1) THEN -C .. set up remaining parameter .. - IF (.NOT. LSAME(DEF,'N')) THEN - DPAR(1) = ONE - DPAR(2) = ONE - END IF - CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) - B(IPAR(1),1) = ONE - C(1,1) = ONE - Q(1) = DPAR(1) - G(1) = DPAR(2) - IDENT = '0000' -C - ELSE IF (NR(2) .EQ. 2) THEN -C .. set up remaining parameters .. - APPIND = DBLE(IPAR(1) + 1) - IF (.NOT. LSAME(DEF,'N')) THEN - DPAR(1) = PARDEF(NR(1), NR(2)) - DPAR(2) = ONE - DPAR(3) = ONE - DPAR(4) = .2D0 - DPAR(5) = .3D0 - DPAR(6) = .2D0 - DPAR(7) = .3D0 - END IF -C .. set up stiffness matrix .. - TEMP = -DPAR(1)*APPIND - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, TWO*TEMP, A, LDA) - DO 110 I = 1, IPAR(1) - 1 - A(I+1,I) = -TEMP - A(I,I+1) = -TEMP - 110 CONTINUE -C .. set up Gramian, stored by diagonals .. - TEMP = ONE/(6.0D0*APPIND) - CALL DLASET('L', IPAR(1), 1, FOUR*TEMP, FOUR*TEMP, DWORK, - 1 IPAR(1)) - CALL DLASET('L', IPAR(1)-1, 1, TEMP, TEMP, DWORK(IPAR(1)+1), - 1 IPAR(1)) - CALL DPTTRF(IPAR(1), DWORK(1), DWORK(IPAR(1)+1), INFO) -C .. A = (inverse of Gramian) * (stiffness matrix) .. - CALL DPTTRS(IPAR(1), IPAR(1), DWORK(1), DWORK(IPAR(1)+1), - 1 A, LDA, INFO) -C .. compute B, C .. - DO 120 I = 1, IPAR(1) - B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) - B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) - C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) - C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) - IF (B1 .GE. B2) THEN - B(I,1) = ZERO - ELSE - B(I,1) = B2 - B1 - TEMP = MIN(B2, DBLE(I)/APPIND) - IF (B1 .LT. TEMP) THEN - B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO - B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) - END IF - TEMP = MAX(B1, DBLE(I)/APPIND) - IF (TEMP .LT. B2) THEN - B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO - B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) - END IF - END IF - IF (C1 .GE. C2) THEN - C(1,I) = ZERO - ELSE - C(1,I) = C2 - C1 - TEMP = MIN(C2, DBLE(I)/APPIND) - IF (C1 .LT. TEMP) THEN - C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO - C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) - END IF - TEMP = MAX(C1, DBLE(I)/APPIND) - IF (TEMP .LT. C2) THEN - C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO - C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) - END IF - END IF - 120 CONTINUE - CALL DSCAL(IPAR(1), DPAR(2), B(1,1), 1) - CALL DSCAL(IPAR(1), DPAR(3), C(1,1), LDC) - CALL DPTTRS(IPAR(1), 1, DWORK(1), DWORK(IPAR(1)+1), B, LDB, - 1 INFO) - IDENT = '0011' -C - ELSE IF (NR(2) .EQ. 3) THEN -C .. set up remaining parameters .. - IF (.NOT. LSAME(DEF,'N')) THEN - DPAR(1) = PARDEF(NR(1),NR(2)) - DPAR(2) = FOUR - DPAR(3) = ONE - END IF - IF (DPAR(1) . NE. 0) THEN - CALL DLASET('A', L, L, ZERO, ONE, A(1,L+1), LDA) - TEMP = DPAR(3) / DPAR(1) - A(L+1,1) = -TEMP - A(L+1,2) = TEMP - A(IPAR(1),L-1) = TEMP - A(IPAR(1),L) = -TEMP - TTEMP = TWO*TEMP - DO 130 I = 2, L-1 - A(L+I,I) = -TTEMP - A(L+I,I+1) = TEMP - A(L+I,I-1) = TEMP - 130 CONTINUE - CALL DLASET('A', L, L, ZERO, -DPAR(2)/DPAR(1), A(L+1,L+1), - 1 LDA) - B(L+1,1) = ONE / DPAR(1) - B(IPAR(1),IPAR(2)) = -ONE / DPAR(1) - IDENT = '0111' - ELSE - INFO = 2 - END IF -C - ELSE IF (NR(2) .EQ. 4) THEN - IF (.NOT. LSAME(DEF,'N')) WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') - 1 'BB01', NR(1), '0', NR(2), '.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - READ (1, FMT = *, IOSTAT = IOS) (DWORK(I), I = 1, 4*L-2) - IF (IOS .NE. 0) INFO = 1 - END IF - CLOSE(1) - IF (INFO .EQ. 0) THEN - CALL DLASET('A', L-1, L-1, ZERO, ONE, A(L+1,2), LDA) - POS = 2*L + 1 - A(1,2) = - DWORK(POS) / DWORK(1) - DO 140 I = 2, L - TEMP = DWORK(POS) / DWORK(I-1) - TTEMP = DWORK(POS) / DWORK(I) - IF (I .GT. 2) A(I-1,I) = TEMP - A(I,I) = -(TEMP + TTEMP) - IF (I .LT. L) A(I+1,I) = TTEMP - POS = POS + 1 - 140 CONTINUE - POS = L - TEMP = DWORK(POS+1) / DWORK(1) - A(1,1) = -TEMP - DO 160 I = 2, L - TTEMP = TEMP - TEMP = DWORK(POS+I) / DWORK(I) - SUM = TTEMP - TEMP - A(I,1) = -SUM - A(I,I) = A(I,I) - TEMP - DO 150 J = 2, I-2 - A(I,J) = SUM - 150 CONTINUE - IF (I .GT. 2) A(I,I-1) = A(I,I-1) + SUM - 160 CONTINUE - POS = 3*L - A(1,L+1) = -DWORK(3*L)/DWORK(1) - DO 170 I = 2, L - TEMP = DWORK(POS) / DWORK(I-1) - TTEMP = DWORK(POS) / DWORK(I) - IF (I .GT. 2) A(I-1,L+I-1) = TEMP - A(I,L+I-1) = -(TEMP + TTEMP) - IF (I .LT. L) A(I+1,L+I-1) = TTEMP - POS = POS + 1 - 170 CONTINUE - B(1,1) = ONE/DWORK(1) - DO 180 I = 1, L - TEMP = ONE/DWORK(I) - IF (I .GT. 1) B(I,I) = -TEMP - IF (I .LT. L) B(I+1,I) = TEMP - 180 CONTINUE - C(1,1) = ONE - Q(1) = ONE - POS = 2*L - 1 - ISYMM = L + 1 - DO 190 I = 2, L - TEMP = DWORK(POS+I) - TTEMP = DWORK(POS+L+I-1) - C(I,I) = TEMP - C(I,L+I-1) = TTEMP - Q(ISYMM) = ONE / (TEMP*TEMP + TTEMP*TTEMP) - ISYMM = ISYMM + L - I + 1 - 190 CONTINUE - IDENT = '0001' - END IF - END IF - END IF -C - IF (INFO .NE. 0) GOTO 2001 -C .. set up data in required format .. -C - IF (BPAR(1)) THEN -C .. G is to be returned in product form .. - GDIMM = IPAR(1) - IF (IDENT(4:4) .EQ. '0') THEN -C .. invert R using Cholesky factorization, store in G .. - CALL DPPTRF('L', IPAR(2), G, INFO) - IF (INFO .EQ. 0) THEN - CALL DPPTRI('L', IPAR(2), G, INFO) - IF (IDENT(1:1) .EQ. '0') THEN -C .. B is not identity matrix .. - DO 200 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(2), ONE, G, B(I,1), LDB, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 200 CONTINUE - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(1,1), LDB, ZERO, G, 1) - ISYMM = IPAR(1) + 1 - DO 210 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(I,1), LDB, ZERO, B(1,1), LDB) - CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, G(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 210 CONTINUE - END IF - ELSE - IF (INFO .GT. 0) THEN - INFO = 3 - GOTO 2001 - END IF - END IF - ELSE -C .. R = identity .. - IF (IDENT(1:1) .EQ. '0') THEN -C .. B is not identity matrix .. - IF (IPAR(2) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, G, 1) - CALL DSPR('L', IPAR(1), ONE, B, 1, G) - ELSE - CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, - 1 B, LDB, ZERO, DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), G) - END IF - ELSE -C .. B = R = identity .. - ISYMM = 1 - DO 220 I = IPAR(1), 1, -1 - G(ISYMM) = ONE - ISYMM = ISYMM + I - 220 CONTINUE - END IF - END IF - ELSE - GDIMM = IPAR(2) - IF (IDENT(1:1) .EQ. '1') - 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) - IF (IDENT(4:4) .EQ. '1') THEN - ISYMM = 1 - DO 230 I = IPAR(2), 1, -1 - G(ISYMM) = ONE - ISYMM = ISYMM + I - 230 CONTINUE - END IF - END IF -C - IF (BPAR(4)) THEN -C .. Q is to be returned in product form .. - QDIMM = IPAR(1) - IF (IDENT(3:3) .EQ. '0') THEN - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - DO 240 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 240 CONTINUE -C .. use Q(1:IPAR(1)) as workspace and compute the first column -C of Q in the end .. - ISYMM = IPAR(1) + 1 - DO 250 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,I), 1, ZERO, Q(1), 1) - CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 250 CONTINUE - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,1), 1, ZERO, Q, 1) - END IF - ELSE -C .. Q = identity .. - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - IF (IPAR(3) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) - CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) - ELSE - CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, - 1 ZERO, DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) - END IF - ELSE -C .. C = Q = identity .. - ISYMM = 1 - DO 260 I = IPAR(1), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 260 CONTINUE - END IF - END IF - ELSE - QDIMM = IPAR(3) - IF (IDENT(2:2) .EQ. '1') - 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) - IF (IDENT(3:3) .EQ. '1') THEN - ISYMM = 1 - DO 270 I = IPAR(3), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 270 CONTINUE - END IF - END IF -C -C .. unpack symmetric matrices if desired .. - IF (BPAR(2)) THEN - ISYMM = (GDIMM * (GDIMM + 1)) / 2 - CALL DCOPY(ISYMM, G, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', GDIMM, G, LDG, DWORK) - CALL MA02ED('Lower', GDIMM, G, LDG) - ELSE IF (BPAR(3)) THEN - CALL MA02DD('Unpack', 'Lower', GDIMM, DWORK, GDIMM, G) - CALL MA02ED('Lower', GDIMM, DWORK, GDIMM) - CALL MA02DD('Pack', 'Upper', GDIMM, DWORK, GDIMM, G) - END IF - IF (BPAR(5)) THEN - ISYMM = (QDIMM * (QDIMM + 1)) / 2 - CALL DCOPY(ISYMM, Q, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) - CALL MA02ED('Lower', QDIMM, Q, LDQ) - ELSE IF (BPAR(6)) THEN - CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) - CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) - CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) - END IF -C -C ...set VEC... - VEC(1) = .TRUE. - VEC(2) = .TRUE. - VEC(3) = .TRUE. - VEC(4) = .TRUE. - VEC(5) = .NOT. BPAR(1) - VEC(6) = .NOT. BPAR(4) - VEC(7) = .TRUE. - VEC(8) = .TRUE. - IF (NR(1) .EQ. 1) THEN - IF ((NR(2) .EQ. 1) .OR. (NR(2) .EQ. 2)) VEC(9) = .TRUE. - ELSE IF (NR(1) .EQ. 2) THEN - IF ((NR(2) .EQ. 1) .OR. ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6))) - 1 VEC(9) = .TRUE. - ELSE IF (NR(1) .EQ. 3) THEN - IF (NR(2) .EQ. 2) VEC(9) = .TRUE. - END IF - CHPAR = NOTES(NR(1),NR(2)) - N = IPAR(1) - M = IPAR(2) - P = IPAR(3) - 2001 CONTINUE - RETURN -C *** Last line of BB01AD *** - END diff --git a/slycot/src/BB02AD.f b/slycot/src/BB02AD.f deleted file mode 100644 index b9edfa34..00000000 --- a/slycot/src/BB02AD.f +++ /dev/null @@ -1,1017 +0,0 @@ - SUBROUTINE BB02AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, - 1 A, LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, - 2 X, LDX, DWORK, LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate the benchmark examples for the numerical solution of -C discrete-time algebraic Riccati equations (DAREs) of the form -C -C T T T -1 T T -C 0 = A X A - X - (A X B + S) (R + B X B) (B X A + S ) + Q -C -C as presented in [1]. Here, A,Q,X are real N-by-N matrices, B,S are -C N-by-M, and R is M-by-M. The matrices Q and R are symmetric and Q -C may be given in factored form -C -C T -C (I) Q = C Q0 C . -C -C Here, C is P-by-N and Q0 is P-by-P. If R is nonsingular and S = 0, -C the DARE can be rewritten equivalently as -C -C T -1 -C 0 = X - A X (I_n + G X) A - Q, -C -C where I_n is the N-by-N identity matrix and -C -C -1 T -C (II) G = B R B . -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER -C This parameter specifies if the default parameters are -C to be used or not. -C = 'N' or 'n' : The parameters given in the input vectors -C xPAR (x = 'D', 'I', 'B', 'CH') are used. -C = 'D' or 'd' : The default parameters for the example -C are used. -C This parameter is not meaningful if NR(1) = 1. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C This array determines the example for which DAREX returns -C data. NR(1) is the group of examples. -C NR(1) = 1 : parameter-free problems of fixed size. -C NR(1) = 2 : parameter-dependent problems of fixed size. -C NR(1) = 3 : parameter-free problems of scalable size. -C NR(1) = 4 : parameter-dependent problems of scalable size. -C NR(2) is the number of the example in group NR(1). -C Let NEXi be the number of examples in group i. Currently, -C NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1. -C 1 <= NR(1) <= 4; -C 0 <= NR(2) <= NEXi, where i = NR(1). -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (4) -C Double precision parameter vector. For explanation of the -C parameters see [1]. -C DPAR(1) defines the parameter 'epsilon' for -C examples NR = 2.2,2.3,2.4, the parameter 'tau' -C for NR = 2.5, and the 1-by-1 matrix R for NR = 2.1,4.1. -C For Example 2.5, DPAR(2) - DPAR(4) define in -C consecutive order 'D', 'K', and 'r'. -C NOTE that DPAR is overwritten with default values -C if DEF = 'D' or 'd'. -C -C IPAR (input/output) INTEGER array, dimension (3) -C On input, IPAR(1) determines the actual state dimension, -C i.e., the order of the matrix A as follows: -C NR(1) = 1, NR(1) = 2 : IPAR(1) is ignored. -C NR = NR(1).NR(2) = 4.1 : IPAR(1) determines the order of -C the output matrix A. -C NOTE that IPAR(1) is overwritten for Examples 1.1-2.3. For -C the other examples, IPAR(1) is overwritten if the default -C parameters are to be used. -C On output, IPAR(1) contains the order of the matrix A. -C -C On input, IPAR(2) is the number of colums in the matrix B -C and the order of the matrix R (in control problems, the -C number of inputs of the system). Currently, IPAR(2) is -C fixed for all examples and thus is not referenced on -C input. -C On output, IPAR(2) is the number of columns of the -C matrix B from (I). -C -C On input, IPAR(3) is the number of rows in the matrix C -C (in control problems, the number of outputs of the -C system). Currently, IPAR(3) is fixed for all examples -C and thus is not referenced on input. -C On output, IPAR(3) is the number of rows of the matrix C -C from (I). -C -C NOTE that IPAR(2) and IPAR(3) are overwritten and -C IPAR(2) <= IPAR(1) and IPAR(3) <= IPAR(1) for all -C examples. -C -C BPAR (input) LOGICAL array, dimension (7) -C This array defines the form of the output of the examples -C and the storage mode of the matrices Q, G or R. -C BPAR(1) = .TRUE. : Q is returned. -C BPAR(1) = .FALSE. : Q is returned in factored form, i.e., -C Q0 and C from (I) are returned. -C BPAR(2) = .TRUE. : The matrix returned in array Q (i.e., -C Q if BPAR(1) = .TRUE. and Q0 if -C BPAR(1) = .FALSE.) is stored as full -C matrix. -C BPAR(2) = .FALSE. : The matrix returned in array Q is -C provided in packed storage mode. -C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix -C returned in array Q is stored in upper -C packed mode, i.e., the upper triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C Q(i,j) is stored in the array entry -C Q(i+j*(j-1)/2) for i <= j. -C Otherwise, this entry is ignored. -C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix -C returned in array Q is stored in lower -C packed mode, i.e., the lower triangle -C of a symmetric n-by-n matrix is stored -C by columns, e.g., the matrix entry -C Q(i,j) is stored in the array entry -C Q(i+(2*n-j)*(j-1)/2) for j <= i. -C Otherwise, this entry is ignored. -C BPAR(4) = .TRUE. : The product G in (II) is returned. -C BPAR(4) = .FALSE. : G is returned in factored form, i.e., -C B and R from (II) are returned. -C BPAR(5) = .TRUE. : The matrix returned in array R (i.e., -C G if BPAR(4) = .TRUE. and R if -C BPAR(4) = .FALSE.) is stored as full -C matrix. -C BPAR(5) = .FALSE. : The matrix returned in array R is -C provided in packed storage mode. -C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix -C returned in array R is stored in upper -C packed mode (see above). -C Otherwise, this entry is ignored. -C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix -C returned in array R is stored in lower -C packed mode (see above). -C Otherwise, this entry is ignored. -C BPAR(7) = .TRUE. : The coefficient matrix S of the DARE -C is returned in array S. -C BPAR(7) = .FALSE. : The coefficient matrix S of the DARE -C is not returned. -C NOTE that there are no default values for BPAR. If all -C entries are declared to be .TRUE., then matrices Q, G or R -C are returned in conventional storage mode, i.e., as -C N-by-N or M-by-M arrays where the array element Z(I,J) -C contains the matrix entry Z_{i,j}. -C -C CHPAR (output) CHARACTER*255 -C On output, this string contains short information about -C the chosen example. -C -C VEC (output) LOGICAL array, dimension (10) -C Flag vector which displays the availability of the output -C data: -C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and -C are always .TRUE. -C VEC(4) refers to A and is always .TRUE. -C VEC(5) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors B -C and R from (II) are returned. -C VEC(6) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors C -C and Q0 from (I) are returned. -C VEC(7) refers to Q and is always .TRUE. -C VEC(8) refers to R and is always .TRUE. -C VEC(9) is .TRUE. if BPAR(7) = .TRUE., i.e., the matrix S -C is returned. -C VEC(10) refers to X and is .TRUE. if the exact solution -C matrix is available. -C NOTE that VEC(i) = .FALSE. for i = 1 to 10 if on exit -C INFO .NE. 0. -C -C N (output) INTEGER -C The order of the matrices A, X, G if BPAR(4) = .TRUE., and -C Q if BPAR(1) = .TRUE. -C -C M (output) INTEGER -C The number of columns in the matrix B (or the dimension of -C the control input space of the underlying dynamical -C system). -C -C P (output) INTEGER -C The number of rows in the matrix C (or the dimension of -C the output space of the underlying dynamical system). -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C coefficient matrix A of the DARE. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If (BPAR(4) = .FALSE.), then the leading N-by-M part -C of this array contains the coefficient matrix B of -C the DARE. Otherwise, B is used as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C If (BPAR(1) = .FALSE.), then the leading P-by-N part -C of this array contains the matrix C of the factored -C form (I) of Q. Otherwise, C is used as workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= P. -C -C Q (output) DOUBLE PRECISION array, dimension (NQ) -C If (BPAR(1) = .TRUE.) and (BPAR(2) = .TRUE.), then -C NQ = LDQ*N. -C IF (BPAR(1) = .TRUE.) and (BPAR(2) = .FALSE.), then -C NQ = N*(N+1)/2. -C If (BPAR(1) = .FALSE.) and (BPAR(2) = .TRUE.), then -C NQ = LDQ*P. -C IF (BPAR(1) = .FALSE.) and (BPAR(2) = .FALSE.), then -C NQ = P*(P+1)/2. -C The symmetric matrix contained in array Q is stored -C according to BPAR(2) and BPAR(3). -C -C LDQ INTEGER -C If conventional storage mode is used for Q, i.e., -C BPAR(2) = .TRUE., then Q is stored like a 2-dimensional -C array with leading dimension LDQ. If packed symmetric -C storage mode is used, then LDQ is irrelevant. -C LDQ >= N if BPAR(1) = .TRUE.; -C LDQ >= P if BPAR(1) = .FALSE.. -C -C R (output) DOUBLE PRECISION array, dimension (MR) -C If (BPAR(4) = .TRUE.) and (BPAR(5) = .TRUE.), then -C MR = LDR*N. -C IF (BPAR(4) = .TRUE.) and (BPAR(5) = .FALSE.), then -C MR = N*(N+1)/2. -C If (BPAR(4) = .FALSE.) and (BPAR(5) = .TRUE.), then -C MR = LDR*M. -C IF (BPAR(4) = .FALSE.) and (BPAR(5) = .FALSE.), then -C MR = M*(M+1)/2. -C The symmetric matrix contained in array R is stored -C according to BPAR(5) and BPAR(6). -C -C LDR INTEGER -C If conventional storage mode is used for R, i.e., -C BPAR(5) = .TRUE., then R is stored like a 2-dimensional -C array with leading dimension LDR. If packed symmetric -C storage mode is used, then LDR is irrelevant. -C LDR >= N if BPAR(4) = .TRUE.; -C LDR >= M if BPAR(4) = .FALSE.. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,M) -C If (BPAR(7) = .TRUE.), then the leading N-by-M part of -C this array contains the coefficient matrix S of the DARE. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= 1, and -C LDS >= N if BPAR(7) = .TRUE.. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,NX) -C If an exact solution is available (NR = 1.1,1.3,1.4,2.1, -C 2.3,2.4,2.5,4.1), then NX = N and the leading N-by-N part -C of this array contains the solution matrix X. -C Otherwise, X is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 1, and -C LDX >= N if an exact solution is available. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= N*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0 : successful exit; -C < 0 : if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : data file could not be opened or had wrong format; -C = 2 : division by zero; -C = 3 : G can not be computed as in (II) due to a singular R -C matrix. This error can only occur if -C BPAR(4) = .TRUE.. -C -C REFERENCES -C -C [1] Abels, J. and Benner, P. -C DAREX - A Collection of Benchmark Examples for Discrete-Time -C Algebraic Riccati Equations (Version 2.0). -C SLICOT Working Note 1999-16, November 1999. Available from -C http://www.win.tue.nl/niconet/NIC2/reports.html. -C -C This is an updated and extended version of -C -C [2] Benner, P., Laub, A.J., and Mehrmann, V. -C A Collection of Benchmark Examples for the Numerical Solution -C of Algebraic Riccati Equations II: Discrete-Time Case. -C Technical Report SPC 95_23, Fak. f. Mathematik, -C TU Chemnitz-Zwickau (Germany), December 1995. -C -C FURTHER COMMENTS -C -C Some benchmark examples read data from the data files provided -C with the collection. -C -C CONTRIBUTOR -C -C Peter Benner (Universitaet Bremen), November 25, 1999. -C -C For questions concerning the collection or for the submission of -C test examples, please send e-mail to benner@math.uni-bremen.de. -C -C REVISIONS -C -C 1999, December 23 (V. Sima). -C -C KEYWORDS -C -C Discrete-time algebraic Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. -C . # of examples available , # of examples with fixed size. . - INTEGER NEX1, NEX2, NEX3, NEX4, NMAX - PARAMETER ( NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1 ) - PARAMETER ( NMAX = 13 ) - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, FIVE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, FIVE = 5.0D0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDQ, LDR, LDS, LDWORK, LDX, - $ M, N, P - CHARACTER DEF -C -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), - 1 Q(*), R(*), S(LDS,*), X(LDX,*) - INTEGER IPAR(3), NR(2) - CHARACTER CHPAR*255 - LOGICAL BPAR(7), VEC(10) -C -C .. Local Scalars .. - INTEGER I, IOS, ISYMM, J, MSYMM, NSYMM, PSYMM, QDIMM, - 1 RDIMM - DOUBLE PRECISION ALPHA, BETA, TEMP -C -C ..Local Arrays .. - INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) - CHARACTER IDENT*4 - CHARACTER*255 NOTES(4,NMAX) -C -C .. External Functions .. -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C -C .. External Subroutines .. -C . BLAS . - EXTERNAL DCOPY, DGEMV, DSPMV, DSPR, DSYMM, DSYRK -C . LAPACK . - EXTERNAL DLASET, DPPTRF, DPPTRI, DRSCL, XERBLA -C . SLICOT . - EXTERNAL MA02DD, MA02ED -C -C .. Intrinsic Functions .. - INTRINSIC SQRT -C -C .. Data Statements .. -C . default values for dimensions . - DATA NEX /NEX1, NEX2, NEX3, NEX4/ - DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 2, 3, 4, 4, 4, 5, 6, 9, - 1 11, 13, 26/ - DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 4/ - DATA (NDEF(4,I), I = 1, NEX4) /100/ - DATA (MDEF(1,I), I = 1, NEX1) /1, 2, 1, 2, 2, 2, 4, 2, 2, 3, - 1 2, 2, 6/ - DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 3, 1/ - DATA (PDEF(1,I), I = 1, NEX1) /1, 2, 2, 3, 4, 4, 4, 5, 2, 2, - 1 4, 4, 12/ - DATA (PDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 1/ -C . comments on examples . - DATA (NOTES(1,I), I = 1, 10) / - 1'Van Dooren 1981, Ex. II: singular R matrix', 'Ionescu/Weiss 1992 - 2: singular R matrix, nonzero S matrix', 'Jonckheere 1981: (A,B) co - 3ntrollable, no solution X <= 0', 'Sun 1998: R singular, Q non-defi - 4nite', 'Ackerson/Fu 1970 : satellite control problem', 'Litkouhi 1 - 5983 : system with slow and fast modes', 'Lu/Lin 1993, Ex. 4.3', 'G - 6ajic/Shen 1993, Section 2.7.4: chemical plant', 'Davison/Wang 1974 - 7: nonzero S matrix', 'Patnaik et al. 1980: tubular ammonia reactor - 8'/ - DATA (NOTES(1,I), I = 11, NEX1) / - 1'Sima 1996, Sec. 1.2.2: paper machine model error integrators', 'S - 2ima 1996, Ex. 2.6: paper machine model with with disturbances', 'P - 3ower plant model, Katayama et al., 1985'/ - DATA (NOTES(2,I), I = 1, NEX2) / - 1'Laub 1979, Ex. 2: uncontrollable-unobservable data', 'Laub 1979, - 2Ex. 3: increasingly ill-conditioned R-matrix', 'increasingly bad s - 3caled system as eps -> oo','Petkov et. al. 1989 : increasingly bad - 4 scaling as eps -> oo', 'Pappas et al. 1980: process control of pa - 5per machine'/ - DATA (NOTES(4,I), I = 1, NEX4) /'Pappas et al. 1980, Ex. 3'/ -C -C .. Executable Statements .. -C - INFO = 0 - DO 1 I = 1, 10 - VEC(I) = .FALSE. - 1 CONTINUE -C - IF (NR(1) .GE. 3) THEN - IF (LSAME(DEF, 'D')) IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = 1 - IPAR(3) = IPAR(1) - ELSE - IPAR(1) = NDEF(NR(1),NR(2)) - IPAR(2) = MDEF(NR(1),NR(2)) - IPAR(3) = PDEF(NR(1),NR(2)) - END IF -C - IF ((NR(1) .GE. 2) .AND. .NOT. ((LSAME(DEF,'D')) .OR. - $ (LSAME(DEF,'N')))) THEN - INFO = -1 - ELSE IF ((NR(1) .LT. 1) .OR. (NR(1) .GT. 4) .OR. (NR(2) .LT. 0) - 1 .OR. (NR(2) .GT. NEX(NR(1)))) THEN - INFO = -2 - ELSE IF (IPAR(1) .LT. 1) THEN - INFO = -4 - ELSE IF (IPAR(1) .GT. LDA) THEN - INFO = -12 - ELSE IF (IPAR(1) .GT. LDB) THEN - INFO = -14 - ELSE IF (IPAR(3) .GT. LDC) THEN - INFO = -16 - ELSE IF (BPAR(2) .AND. (((.NOT. BPAR(1)) .AND. - 1 (IPAR(3) .GT. LDQ)) .OR. (BPAR(1) .AND. - 2 (IPAR(1) .GT. LDQ)))) THEN - INFO = -18 - ELSE IF (BPAR(5) .AND. ((BPAR(4) .AND. (IPAR(1) .GT. LDR)) .OR. - 1 ((.NOT. BPAR(4)) .AND. (IPAR(2) .GT. LDR)))) THEN - INFO = -20 - ELSE IF (LDS .LT. 1 .OR. (BPAR(7) .AND. (IPAR(1) .GT. LDS))) THEN - INFO = -22 - ELSE IF (LDX .LT. 1) THEN - INFO = -24 - ELSE IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. - 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. - 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. - 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN -C .. solution X available .. - IF (IPAR(1) .GT. LDX) THEN - INFO = -24 - ELSE - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) - END IF - ELSE IF (LDWORK .LT. N*N) THEN - INFO = -26 - END IF - IF (INFO .NE. 0) THEN - CALL XERBLA( 'BB02AD', -INFO ) - RETURN - END IF -C - NSYMM = (IPAR(1)*(IPAR(1)+1))/2 - MSYMM = (IPAR(2)*(IPAR(2)+1))/2 - PSYMM = (IPAR(3)*(IPAR(3)+1))/2 -C - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) - CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) - CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) - CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) - CALL DLASET('L', MSYMM, 1, ZERO, ZERO, R, 1) - IF (BPAR(7)) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, - 1 S, LDS) -C - IF(NR(1) .EQ. 1) THEN -C - IF (NR(2) .EQ. 1) THEN - A(1,1) = TWO - A(2,1) = ONE - A(1,2) = -ONE - B(1,1) = ONE - Q(1) = ONE - C(1,2) = ONE - R(1) = ZERO - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) - IDENT = '0000' -C - ELSE IF (NR(2) .EQ. 2) THEN - A(1,2) = ONE - A(2,2) = -ONE - B(1,1) = ONE - B(2,1) = TWO - B(2,2) = ONE - R(1) = 9.0D0 - R(2) = THREE - R(3) = ONE - CALL DLASET('A', PSYMM, 1, -FOUR, -FOUR, Q, PSYMM) - Q(3) = 7.0D0 - CALL DRSCL(MSYMM, 11.0D0, Q, 1) - IF (BPAR(7)) THEN - S(1,1) = THREE - S(2,1) = -ONE - S(1,2) = ONE - S(2,2) = 7.0D0 - END IF - IDENT = '0100' -C - ELSE IF (NR(2) .EQ. 3) THEN - A(1,2) = ONE - B(2,1) = ONE - Q(1) = ONE - Q(2) = TWO - Q(3) = FOUR - X(1,1) = ONE - X(2,1) = TWO - X(1,2) = TWO - X(2,2) = TWO + SQRT(FIVE) - IDENT = '0101' -C - ELSE IF (NR(2) .EQ. 4) THEN - A(1,2) = .1000D+00 - A(2,3) = .0100D+00 - B(1,1) = ONE - B(3,2) = ONE - R(3) = ONE - Q(1) = .1D+06 - Q(4) = .1D+04 - Q(6) = -.1D+02 - X(1,1) = .1D+06 - X(2,2) = .1D+04 - IDENT = '0100' -C - ELSE IF (((NR(2) .GE. 5) .AND. (NR(2) .LE. 8)) .OR. - 1 (NR(2) .EQ. 10) .OR. (NR(2) .EQ. 11) .OR. - 2 (NR(2) .EQ. 13)) THEN - IF (NR(2) .LT. 10) THEN - WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') - 1 'BB02', NR(1), '0', NR(2), '.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - ELSE - WRITE (CHPAR(1:11), '(A,I1,I2,A)') - 1 'BB02', NR(1), NR(2), '.dat' - OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) - END IF - IF (IOS .NE. 0) THEN - INFO = 1 - ELSE - IF (.NOT. (NR(2) .EQ. 13)) THEN - DO 10 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) (A(I,J), J = 1, IPAR(1)) - IF (IOS .NE. 0) INFO = 1 - 10 CONTINUE - DO 20 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = IOS) (B(I,J), J = 1, IPAR(2)) - IF (IOS .NE. 0) INFO = 1 - 20 CONTINUE - END IF - IF (NR(2) .EQ. 5) THEN - Q(1) = .187D1 - Q(4) = -.244D0 - Q(5) = .744D0 - Q(6) = .205D0 - Q(8) = .589D0 - Q(10) = .1048D1 - ELSE IF (NR(2) .EQ. 6) THEN - Q(1) = .1D-1 - Q(5) = .1D-1 - Q(8) = .1D-1 - Q(10) = .1D-1 - ELSE IF (NR(2) .EQ. 7) THEN - CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) - C(1,3) = TWO - C(1,4) = FOUR - C(2,4) = TWO - Q(1) = TWO - Q(2) = -ONE - Q(5) = TWO - Q(6) = -ONE - Q(8) = TWO - ELSE IF (NR(2) .EQ. 10) THEN - C(1,1) = ONE - C(2,5) = ONE - Q(1) = 50.0D0 - Q(3) = 50.0D0 - ELSE IF (NR(2) .EQ. 11) THEN - A(10,10) = ONE - A(11,11) = ONE - C(1,6) = 15.0D0 - C(2,7) = 7.0D0 - C(2,8) = -.5357D+01 - C(2,9) = -.3943D+01 - C(3,10) = ONE - C(4,11) = ONE - Q(1) = 0.5D0 - Q(5) = 5.0D0 - Q(8) = 0.5D0 - Q(10) = 5.0D0 - R(1) = 400.0D0 - R(3) = 700.0D0 - IDENT = '0000' -C - ELSE IF (NR(2) .EQ. 13) THEN - DO 24 I = 1, IPAR(1)-6 - READ (1, FMT = *, IOSTAT = IOS) - 1 (A(I,J), J = 1, IPAR(1)-6) - IF (IOS .NE. 0) INFO = 1 - 24 CONTINUE - DO 25 I = 1, IPAR(1)-6 - READ (1, FMT = *, IOSTAT = IOS) - 1 (B(I,J), J = 1, IPAR(2)) - IF (IOS .NE. 0) INFO = 1 - 25 CONTINUE - DO 26 I = 1, IPAR(2) - READ (1, FMT = *, IOSTAT = IOS) - 1 (C(I,J), J = 1, IPAR(1)-6) - IF (IOS .NE. 0) INFO = 1 - 26 CONTINUE - DO 27 I = 1, 6 - A(20+I,20+I) = ONE - C(6+I,20+I) = ONE - 27 CONTINUE - J = 58 - DO 28 I = 7, 12 - READ (1, FMT = *, IOSTAT = IOS) Q(J) - IF (IOS .NE. 0) INFO = 1 - J = J + (13 - I) - 28 CONTINUE - J = 1 - DO 29 I = 1, 6 - READ (1, FMT = *, IOSTAT = IOS) R(J) - IF (IOS .NE. 0) INFO = 1 - J = J + (7 - I) - 29 CONTINUE - DO 31 I = 1, 6 - DO 30 J = 1, 20 - A(I+20,J) = -C(I,J) - 30 CONTINUE - 31 CONTINUE - IDENT = '0000' - END IF - END IF - CLOSE(1) - IF ((NR(2) .EQ. 5) .OR. (NR(2) .EQ. 6)) THEN - IDENT = '0101' - ELSE IF ((NR(2) .EQ. 7) .OR. (NR(2) .EQ. 10)) THEN - IDENT = '0001' - ELSE IF (NR(2) .EQ. 8) THEN - IDENT = '0111' - END IF -C - ELSE IF (NR(2). EQ. 9) THEN - A(1,2) = ONE - A(2,3) = ONE - A(4,5) = ONE - A(5,6) = ONE - B(3,1) = ONE - B(6,2) = ONE - C(1,1) = ONE - C(1,2) = ONE - C(2,4) = ONE - C(2,5) = -ONE - R(1) = THREE - R(3) = ONE - IF (BPAR(7)) THEN - S(1,1) = ONE - S(2,1) = ONE - S(4,1) = ONE - S(5,1) = -ONE - END IF - IDENT = '0010' - ELSE IF (NR(2) .EQ. 12) THEN - DO 32 I = 1, 10 - A(I,I+1) = ONE - 32 CONTINUE - A(6,7) = ZERO - A(8,9) = ZERO - A(12,12) = ONE - A(13,13) = ONE - A(12,1) = -.3318D+01 - A(13,1) = -.15484D+01 - A(6,6) = .7788D+00 - A(8,7) = -.4724D+00 - A(13,7) = .3981D+00 - A(8,8) = .13746D+01 - A(13,8) = .5113D+00 - A(13,9) = .57865D+01 - A(11,11) = .8071D+00 - B(6,1) = ONE - B(8,2) = ONE - C(1,1) = .3318D+01 - C(2,1) = .15484D+01 - C(2,7) = -.3981D+00 - C(2,8) = -.5113D+00 - C(2,9) = -.57865D+01 - C(3,12) = ONE - C(4,13) = ONE - Q(1) = 0.5D0 - Q(5) = 5.0D0 - Q(8) = 0.5D0 - Q(10) = 5.0D0 - R(1) = 400.0D0 - R(3) = 700.0D0 - IDENT = '0000' - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (NR(2) .EQ. 1) THEN - IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = THREE - A(2,2) = -.35D1 - CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) - R(1) = DPAR(1) - Q(1) = 9.0D0 - Q(2) = 6.0D0 - Q(3) = FOUR - TEMP = (ONE + SQRT(ONE+FOUR*DPAR(1))) / TWO - X(1,1) = TEMP*Q(1) - X(2,1) = TEMP*Q(2) - X(1,2) = X(2,1) - X(2,2) = TEMP*Q(3) - IDENT = '0100' -C - ELSE IF (NR(2) .EQ. 2) THEN - IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 - IF (DPAR(1) .EQ. ZERO) THEN - INFO = 2 - ELSE - A(1,1) = .9512D0 - A(2,2) = .9048D0 - CALL DLASET('A', 1, IPAR(2), .4877D1, .4877D1, B, LDB) - B(2,1) = -.11895D1 - B(2,2) = .3569D1 - R(1) = ONE / (THREE*DPAR(1)) - R(3) = THREE*DPAR(1) - Q(1) = .5D-2 - Q(3) = .2D-1 - IDENT = '0100' - END IF -C - ELSE IF (NR(2) .EQ. 3) THEN - IF (LSAME(DEF,'D')) DPAR(1) = .1D7 - A(1,2) = DPAR(1) - B(2,1) = ONE - X(1,1) = ONE - X(2,2) = ONE + DPAR(1)*DPAR(1) - IDENT = '0111' -C - ELSE IF (NR(2) .EQ. 4) THEN - IF (LSAME(DEF,'D')) DPAR(1) = .1D7 - A(2,2) = ONE - A(3,3) = THREE - R(1) = DPAR(1) - R(4) = DPAR(1) - R(6) = DPAR(1) -C .. set C = V .. - TEMP = TWO/THREE - CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, C, LDC) -C .. and compute A <- C' A C - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, A, LDA) - Q(1) = DPAR(1) - Q(4) = DPAR(1) - Q(6) = DPAR(1) - X(1,1) = DPAR(1) - X(2,2) = DPAR(1) * (ONE + SQRT(FIVE)) / TWO - X(3,3) = DPAR(1) * (9.0D0 + SQRT(85.0D0)) / TWO - CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, - 1 ZERO, DWORK, IPAR(1)) - CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, - 1 IPAR(1), ZERO, X, LDX) - IDENT = '1000' -C - ELSE IF (NR(2) .EQ. 5) THEN - IF (LSAME(DEF, 'D')) THEN - DPAR(4) = .25D0 - DPAR(3) = ONE - DPAR(2) = ONE - DPAR(1) = .1D9 - END IF - IF (DPAR(1) .EQ. ZERO) THEN - INFO = 2 - ELSE - TEMP = DPAR(2) / DPAR(1) - BETA = DPAR(3) * TEMP - ALPHA = ONE - TEMP - A(1,1) = ALPHA - CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(2,1), - 1 LDA) - B(1,1) = BETA - C(1,4) = ONE - R(1) = DPAR(4) - IF (BETA .EQ. ZERO) THEN - INFO = 2 - ELSE - CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) - BETA = BETA * BETA - TEMP = DPAR(4) * (ALPHA + ONE) * (ALPHA - ONE) + BETA - X(1,1) = (TEMP + SQRT(TEMP*TEMP + FOUR*BETA*DPAR(4))) - X(1,1) = X(1,1) / TWO / BETA - END IF - IDENT = '0010' - END IF - END IF -C - ELSE IF (NR(1) .EQ. 4) THEN - IF (NR(2) .EQ. 1) THEN - IF (LSAME(DEF,'D')) DPAR(1) = ONE - CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) - B(IPAR(1),1) = ONE - R(1) = DPAR(1) - DO 40 I = 1, IPAR(1) - X(I,I) = DBLE(I) - 40 CONTINUE - IDENT = '0110' - END IF - END IF -C - IF (INFO .NE. 0) GOTO 2001 -C .. set up data in required format .. -C - IF (BPAR(4)) THEN -C .. G is to be returned in product form .. - RDIMM = IPAR(1) - IF (IDENT(4:4) .EQ. '0') THEN -C .. invert R using Cholesky factorization, .. - CALL DPPTRF('L', IPAR(2), R, INFO) - IF (INFO .EQ. 0) THEN - CALL DPPTRI('L', IPAR(2), R, INFO) - IF (IDENT(1:1) .EQ. '0') THEN -C .. B is not identity matrix .. - DO 100 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(2), ONE, R, B(I,1), LDB, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 100 CONTINUE - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(1,1), LDB, ZERO, R, 1) - ISYMM = IPAR(1) + 1 - DO 110 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), - 1 B(I,1), LDB, ZERO, B(1,1), LDB) - CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, R(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 110 CONTINUE - END IF - ELSE - IF (INFO .GT. 0) THEN - INFO = 3 - GOTO 2001 - END IF - END IF - ELSE -C .. R = identity .. - IF (IDENT(1:1) .EQ. '0') THEN -C .. B not identity matrix .. - IF (IPAR(2) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, R, 1) - CALL DSPR('L', IPAR(1), ONE, B, 1, R) - ELSE - CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, B, LDB, ZERO, - 1 DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), R) - END IF - ELSE -C .. B = R = identity .. - ISYMM = 1 - DO 120 I = IPAR(1), 1, -1 - R(ISYMM) = ONE - ISYMM = ISYMM + I - 120 CONTINUE - END IF - END IF - ELSE - RDIMM = IPAR(2) - IF (IDENT(1:1) .EQ. '1') - 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) - IF (IDENT(4:4) .EQ. '1') THEN - ISYMM = 1 - DO 130 I = IPAR(2), 1, -1 - R(ISYMM) = ONE - ISYMM = ISYMM + I - 130 CONTINUE - END IF - END IF -C - IF (BPAR(1)) THEN -C .. Q is to be returned in product form .. - QDIMM = IPAR(1) - IF (IDENT(3:3) .EQ. '0') THEN - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - DO 140 I = 1, IPAR(1) - CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, - 1 DWORK((I-1)*IPAR(1)+1), 1) - 140 CONTINUE -C .. use Q(1:IPAR(1)) as workspace and compute the first column -C of Q at the end .. - ISYMM = IPAR(1) + 1 - DO 150 I = 2, IPAR(1) - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,I), 1, ZERO, Q(1), 1) - CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) - ISYMM = ISYMM + (IPAR(1) - I + 1) - 150 CONTINUE - CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), - 1 C(1,1), 1, ZERO, Q, 1) - END IF - ELSE -C .. Q = identity .. - IF (IDENT(2:2) .EQ. '0') THEN -C .. C is not identity matrix .. - IF (IPAR(3) .EQ. 1) THEN - CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) - CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) - ELSE - CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, ZERO, - 1 DWORK, IPAR(1)) - CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) - END IF - ELSE -C .. C = Q = identity .. - ISYMM = 1 - DO 160 I = IPAR(1), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 160 CONTINUE - END IF - END IF - ELSE - QDIMM = IPAR(3) - IF (IDENT(2:2) .EQ. '1') - 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) - IF (IDENT(3:3) .EQ. '1') THEN - ISYMM = 1 - DO 170 I = IPAR(3), 1, -1 - Q(ISYMM) = ONE - ISYMM = ISYMM + I - 170 CONTINUE - END IF - END IF -C -C .. unpack symmetric matrices if required .. - IF (BPAR(2)) THEN - ISYMM = (QDIMM * (QDIMM + 1)) / 2 - CALL DCOPY(ISYMM, Q, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) - CALL MA02ED('Lower', QDIMM, Q, LDQ) - ELSE IF (BPAR(3)) THEN - CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) - CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) - CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) - END IF - IF (BPAR(5)) THEN - ISYMM = (RDIMM * (RDIMM + 1)) / 2 - CALL DCOPY(ISYMM, R, 1, DWORK, 1) - CALL MA02DD('Unpack', 'Lower', RDIMM, R, LDR, DWORK) - CALL MA02ED('Lower', RDIMM, R, LDR) - ELSE IF (BPAR(6)) THEN - CALL MA02DD('Unpack', 'Lower', RDIMM, DWORK, RDIMM, R) - CALL MA02ED('Lower', RDIMM, DWORK, RDIMM) - CALL MA02DD('Pack', 'Upper', RDIMM, DWORK, RDIMM, R) - END IF -C -C ...set VEC... - VEC(1) = .TRUE. - VEC(2) = .TRUE. - VEC(3) = .TRUE. - VEC(4) = .TRUE. - VEC(5) = .NOT. BPAR(4) - VEC(6) = .NOT. BPAR(1) - VEC(7) = .TRUE. - VEC(8) = .TRUE. - VEC(9) = BPAR(7) - IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. - 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. - 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. - 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN - VEC(10) = .TRUE. - END IF - CHPAR = NOTES(NR(1),NR(2)) - N = IPAR(1) - M = IPAR(2) - P = IPAR(3) -C - 2001 CONTINUE - RETURN -C *** Last line of BB02AD *** - END diff --git a/slycot/src/BB03AD.f b/slycot/src/BB03AD.f deleted file mode 100644 index d19c1910..00000000 --- a/slycot/src/BB03AD.f +++ /dev/null @@ -1,490 +0,0 @@ - SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, - 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, - 2 LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples of (generalized) continuous-time -C Lyapunov equations -C -C T T -C A X E + E X A = Y . -C -C In some examples, the right hand side has the form -C -C T -C Y = - B B -C -C and the solution can be represented as a product of Cholesky -C factors -C -C T -C X = U U . -C -C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note -C that E can be the identity matrix. For some examples, B, X, or U -C are not provided. -C -C This routine is an implementation of the benchmark library -C CTLEX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C DEF = 'D' or 'd': Default values are used. -C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension 2 -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension 2 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on real parameters, then the array DPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', -C respectively. -C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and -C 's', respectively. -C For Examples 4.3 and 4.4, DPAR(1) defines the parameter -C 't'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on real parameters, then the array DPAR is -C overwritten by the default values given in [1]. -C -C IPAR (input/output) INTEGER array of DIMENSION at least 1 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on integer parameters, then the array IPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. -C For Example 4.4, IPAR(1) defines 'q'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on integer parameters, then the array IPAR is -C overwritten by the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension 8 -C Flag vector which displays the availability of the output -C data: -C VEC(1) and VEC(2) refer to N and M, respectively, and are -C always .TRUE. -C VEC(3) is .TRUE. iff E is NOT the identity matrix. -C VEC(4) and VEC(5) refer to A and Y, respectively, and are -C always .TRUE. -C VEC(6) is .TRUE. iff B is provided. -C VEC(7) is .TRUE. iff the solution matrix X is provided. -C VEC(8) is .TRUE. iff the Cholesky factor U is provided. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of rows in the matrix B. If B is not provided -C for the desired example, M = 0 is returned. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(3) = .FALSE. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the -C matrix Y. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= M. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the -C matrix X. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= N. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C matrix U. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is -C required. -C For the other examples, no workspace is needed, i.e., -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value. -C -C REFERENCES -C -C [1] D. Kressner, V. Mehrmann, and T. Penzl. -C CTLEX - a Collection of Benchmark Examples for Continuous- -C Time Lyapunov Equations. -C SLICOT Working Note 1999-6, 1999. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C continuous-time Lyapunov equations -C -C ******************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR - PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, - 1 THREE = .3D1, FOUR = .4D1) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), - 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) -C .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION TEMP, TTM1, TTP1, TWOBYN -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . BLAS . - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . BLAS . - EXTERNAL DGEMV, DGER, DAXPY -C . LAPACK . - EXTERNAL DLASET -C .. Intrinsic Functions .. - INTRINSIC DBLE, MIN, MOD -C .. Data Statements .. -C . default values for availabilities . - DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., - 1 .TRUE., .FALSE., .FALSE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) - 10 CONTINUE -C - IF (NR(1) .EQ. 4) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'CTLEX: Example 4.1' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDX .LT. N) INFO = -17 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - VEC(7) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, ZERO, ZERO, B, LDB) - CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) - DO 30 J = 1, N - TEMP = DPAR(1) ** (J-1) - A(J,J) = -TEMP - DWORK(J) = ONE - DO 20 I = 1, N - X(I,J) = DBLE( I*J ) / (TEMP + DPAR(1)**(I-1)) - 20 CONTINUE - 30 CONTINUE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C H1 * X - CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) -C X * H1 - CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) -C S A INV(S), INV(S) X INV(S), B INV(S) - DO 50 J = 1, N - B(1,J) = DBLE( J-N-1 ) / (DPAR(2)**(J-1)) - DO 40 I = 1, N - X(I,J) = X(I,J) / (DPAR(2)**(I+J-2)) - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 40 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 50 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C H2 * X - CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) -C X * H2 - CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'CTLEX: Example 4.2' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = -.5D0 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .GE. ZERO) .OR. (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) - DO 60 I = 1, N-1 - DWORK(I) = ONE - A(I,I+1) = ONE - 60 CONTINUE - DWORK(N) = ONE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C S A INV(S), B INV(S) - DO 80 J = 1, N - B(1,J) = B(1,J) / (DPAR(2)**(J-1)) - DO 70 I = 1, N - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 70 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 80 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'CTLEX: Example 4.3' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .1D2 - END IF - IF (DPAR(1) .LT. ZERO) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 0 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDX .LT. N) INFO = -17 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(7) = .TRUE. - TEMP = TWO ** (-DPAR(1)) - CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('L', N, N, TEMP, ONE, E, LDE) - CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('U', N, N, ONE, ZERO, A, LDA) - CALL DLASET('A', N, N, ONE, ONE, X, LDX) - DO 90 I = 1, N - A(I,I) = DBLE( I - 1 ) + TEMP - 90 CONTINUE - Y(1,1) = TWO * TEMP + TWO * DBLE( N-1 ) * TEMP**2 - TTP1 = TWO * DBLE( N+1 ) * TEMP + TWO - TEMP**2 - TTM1 = TWO * DBLE( N-1 ) * TEMP + TWO - TEMP**2 - DO 100 I = 2, N - Y(I,1) = Y(1,1) + DBLE( I-1 ) * TTM1 - 100 CONTINUE - DO 120 J = 2, N - DO 110 I = 1, N - Y(I,J) = Y(I,1) + DBLE( J-1 ) * (TTP1 - FOUR * I * TEMP) - 110 CONTINUE - 120 CONTINUE -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'CTLEX: Example 4.4' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - END IF - IF (DPAR(1) .LT. ONE) INFO = -3 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) * 3 - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(6) = .TRUE. - CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - DO 150 I = 1, IPAR(1) - TEMP = -DPAR(1)**I - DO 140 J = 1, I - 1 - DO 130 K = 0, 2 - A(N - I*3+3, J*3-K) = TEMP - A(N - I*3+2, J*3-K) = TWO * TEMP - 130 CONTINUE - 140 CONTINUE - A(N - I*3+3, I*3-2) = TEMP - A(N - I*3+2, I*3-2) = TWO * TEMP - A(N - I*3+2, I*3-1) = TWO * TEMP - A(N - I*3+2, I*3 ) = TEMP - A(N - I*3+1, I*3 ) = TEMP - 150 CONTINUE - DO 170 J = 1, N - IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) - B(1, J) = DBLE( J ) - DO 160 I = 1, N - E(I,N-J+1) = DBLE( MIN( I, J ) ) - Y(I,J) = -DBLE( I*J ) - 160 CONTINUE - 170 CONTINUE -C - ELSE - INFO = -2 - END IF - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BB03AD *** - END diff --git a/slycot/src/BB04AD.f b/slycot/src/BB04AD.f deleted file mode 100644 index a017a880..00000000 --- a/slycot/src/BB04AD.f +++ /dev/null @@ -1,476 +0,0 @@ - SUBROUTINE BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, - 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, - 2 LDWORK, INFO) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples of (generalized) discrete-time -C Lyapunov equations -C -C T T -C A X A - E X E = Y . -C -C In some examples, the right hand side has the form -C -C T -C Y = - B B -C -C and the solution can be represented as a product of Cholesky -C factors -C -C T -C X = U U . -C -C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note -C that E can be the identity matrix. For some examples, B, X, or U -C are not provided. -C -C This routine is an implementation of the benchmark library -C DTLEX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C DEF = 'D' or 'd': Default values are used. -C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension 2 -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension 2 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on real parameters, then the array DPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', -C respectively. -C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and -C 's', respectively. -C For Examples 4.3 and 4.4, DPAR(1) defines the parameter -C 't'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on real parameters, then the array DPAR is -C overwritten by the default values given in [1]. -C -C IPAR (input/output) INTEGER array of DIMENSION at least 1 -C On entry, if DEF = 'N' or 'n' and the desired example -C depends on integer parameters, then the array IPAR must -C contain the values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. -C For Example 4.4, IPAR(1) defines 'q'. -C On exit, if DEF = 'D' or 'd' and the desired example -C depends on integer parameters, then the array IPAR is -C overwritten by the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension 8 -C Flag vector which displays the availability of the output -C data: -C VEC(1) and VEC(2) refer to N and M, respectively, and are -C always .TRUE. -C VEC(3) is .TRUE. iff E is NOT the identity matrix. -C VEC(4) and VEC(5) refer to A and Y, respectively, and are -C always .TRUE. -C VEC(6) is .TRUE. iff B is provided. -C VEC(7) is .TRUE. iff the solution matrix X is provided. -C VEC(8) is .TRUE. iff the Cholesky factor U is provided. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of rows in the matrix B. If B is not provided -C for the desired example, M = 0 is returned. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(3) = .FALSE. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the -C matrix Y. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= M. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the -C matrix X. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= N. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C matrix U. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is -C required. -C For the other examples, no workspace is needed, i.e., -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value. -C -C REFERENCES -C -C [1] D. Kressner, V. Mehrmann, and T. Penzl. -C DTLEX - a Collection of Benchmark Examples for Discrete- -C Time Lyapunov Equations. -C SLICOT Working Note 1999-7, 1999. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C discrete-time Lyapunov equations -C -C ******************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR - PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, - 1 THREE = .3D1, FOUR = .4D1) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), - 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) -C .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION TEMP, TTEMP, TWOBYN -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . BLAS . - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . BLAS . - EXTERNAL DGEMV, DGER, DAXPY -C . LAPACK . - EXTERNAL DLASET -C .. Intrinsic Functions .. - INTRINSIC DBLE, MIN, MOD, SQRT -C .. Data Statements .. -C . default values for availabilities . - DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., - 1 .TRUE., .FALSE., .FALSE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) - 10 CONTINUE -C - IF (NR(1) .EQ. 4) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'DTLEX: Example 4.1' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDX .LT. N) INFO = -17 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - VEC(7) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) - CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) - DO 20 I = 1, N - TEMP = DPAR(1) ** (I-1) - A(I,I) = (TEMP-ONE) / (TEMP+ONE) - DWORK(I) = ONE - 20 CONTINUE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C S A INV(S), B INV(S) - DO 40 J = 1, N - B(1,J) = B(1,J) / (DPAR(2)**(J-1)) - DO 30 I = 1, N - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 30 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 40 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C X = -Y - DO 50 J = 1, N - CALL DAXPY(N, -ONE, Y(1,J), 1, X(1,J), 1) - 50 CONTINUE -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'DTLEX: Example 4.2' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = -.5D0 - DPAR(2) = .15D1 - END IF - IF ((DPAR(1) .LE. -ONE) .OR. (DPAR(1) .GE. ONE) .OR. - 1 (DPAR(2) .LE. ONE)) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (LDWORK .LT. N*2) INFO = -22 - IF (INFO .NE. 0) RETURN -C - VEC(6) = .TRUE. - TWOBYN = TWO / DBLE( N ) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) - CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) - CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) - DO 60 I = 1, N-1 - DWORK(I) = ONE - A(I,I+1) = ONE - 60 CONTINUE - DWORK(N) = ONE -C H1 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H1 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C S A INV(S), B INV(S) - DO 80 J = 1, N - B(1,J) = B(1,J) / (DPAR(2)**(J-1)) - DO 70 I = 1, N - A(I,J) = A(I,J) * (DPAR(2)**(I-J)) - 70 CONTINUE - DWORK(J) = ONE - TWO * MOD(J,2) - 80 CONTINUE -C H2 * A - CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) -C A * H2 - CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) - CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) -C B * H2 - CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, - 1 B, LDB) -C Y = -B' * B - CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'DTLEX: Example 4.3' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .1D2 - END IF - IF (DPAR(1) .LT. ZERO) INFO = -3 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 0 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDX .LT. N) INFO = -17 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(7) = .TRUE. - TEMP = TWO ** (-DPAR(1)) - CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('L', N, N, TEMP, ONE, E, LDE) - CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('U', N, N, ONE, ZERO, A, LDA) - CALL DLASET('A', N, N, ONE, ONE, X, LDX) - DO 90 I = 1, N - A(I,I) = DBLE( I ) + TEMP - 90 CONTINUE - DO 110 J = 1, N - DO 100 I = 1, N - Y(I,J) = TEMP * TEMP * DBLE( 1 - (N-I) * (N-J) ) + - 1 TEMP * DBLE( 3 * (I+J) - 2 * (N+1) ) + - 2 FOUR*DBLE( I*J ) - TWO * DBLE( I+J ) - 100 CONTINUE - 110 CONTINUE -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'DTLEX: Example 4.4' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 10 - DPAR(1) = .15D1 - END IF - IF (DPAR(1) .LT. ONE) INFO = -3 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) * 3 - M = 1 - IF (LDE .LT. N) INFO = -9 - IF (LDA .LT. N) INFO = -11 - IF (LDY .LT. N) INFO = -13 - IF (LDB .LT. M) INFO = -15 - IF (INFO .NE. 0) RETURN -C - VEC(3) = .TRUE. - VEC(6) = .TRUE. - CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - DO 140 I = 1, IPAR(1) - TTEMP = ONE - ONE / (DPAR(1)**I) - TEMP = - TTEMP / SQRT( TWO ) - DO 130 J = 1, I - 1 - DO 120 K = 0, 2 - A(N - I*3+3, J*3-K) = TTEMP - A(N - I*3+2, J*3-K) = TWO * TEMP - 120 CONTINUE - 130 CONTINUE - A(N - I*3+3, I*3-2) = TTEMP - A(N - I*3+2, I*3-2) = TWO * TEMP - A(N - I*3+2, I*3-1) = TWO * TEMP - A(N - I*3+2, I*3 ) = TEMP - A(N - I*3+1, I*3 ) = TEMP - 140 CONTINUE - DO 160 J = 1, N - IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) - B(1, J) = DBLE( J ) - DO 150 I = 1, N - E(I,N-J+1) = DBLE( MIN(I,J) ) - Y(I,J) = -DBLE( I*J ) - 150 CONTINUE - 160 CONTINUE -C - ELSE - INFO = -2 - END IF - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BB04AD *** - END diff --git a/slycot/src/BD01AD.f b/slycot/src/BD01AD.f deleted file mode 100644 index 9cc34c06..00000000 --- a/slycot/src/BD01AD.f +++ /dev/null @@ -1,1017 +0,0 @@ - SUBROUTINE BD01AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, - 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, - 2 LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples for time-invariant, -C continuous-time dynamical systems -C -C . -C E x(t) = A x(t) + B u(t) -C -C y(t) = C x(t) + D u(t) -C -C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and -C D is P-by-M. In many examples, E is the identity matrix and D is -C the zero matrix. -C -C This routine is an implementation of the benchmark library -C CTDSX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C = 'D': Default values defined in [1] are used; -C = 'N': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (7) -C On entry, if DEF = 'N' and the desired example depends on -C real parameters, then the array DPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 2.1 and 2.2, DPAR(1) defines the parameter -C 'epsilon'. -C For Example 2.4, DPAR(1), ..., DPAR(7) define 'b', 'mu', -C 'r', 'r_c', 'k_l', 'sigma', 'a', respectively. -C For Example 2.7, DPAR(1) and DPAR(2) define 'mu' and 'nu', -C respectively. -C For Example 4.1, DPAR(1), ..., DPAR(7) define 'a', 'b', -C 'c', 'beta_1', 'beta_2', 'gamma_1', 'gamma_2', -C respectively. -C For Example 4.2, DPAR(1), ..., DPAR(3) define 'mu', -C 'delta', 'kappa', respectively. -C On exit, if DEF = 'D' and the desired example depends on -C real parameters, then the array DPAR is overwritten by the -C default values given in [1]. -C -C IPAR (input/output) INTEGER array, dimension (1) -C On entry, if DEF = 'N' and the desired example depends on -C integer parameters, then the array IPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Examples 2.3, 2.5, and 2.6, IPAR(1) defines the -C parameter 's'. -C For Example 3.1, IPAR(1) defines 'q'. -C For Examples 3.2 and 3.3, IPAR(1) defines 'n'. -C For Example 3.4, IPAR(1) defines 'l'. -C For Example 4.1, IPAR(1) defines 'n'. -C For Example 4.2, IPAR(1) defines 'l'. -C On exit, if DEF = 'D' and the desired example depends on -C integer parameters, then the array IPAR is overwritten by -C the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension (8) -C Flag vector which displays the availabilty of the output -C data: -C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, -C and are always .TRUE.. -C VEC(4) is .TRUE. iff E is NOT the identity matrix. -C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, -C and are always .TRUE.. -C VEC(8) is .TRUE. iff D is NOT the zero matrix. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of columns in the matrices B and D. -C -C P (output) INTEGER -C The number of rows in the matrices C and D. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(4) = .FALSE.. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= P. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C matrix D. -C NOTE that this array is overwritten (by the zero -C matrix), if VEC(8) = .FALSE.. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= P. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C For Example 3.4, LDWORK >= 4*IPAR(1) is required. -C For the other examples, no workspace is needed, i.e., -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value; -C = 1: data file can not be opened or has wrong format. -C -C -C REFERENCES -C -C [1] Kressner, D., Mehrmann, V. and Penzl, T. -C CTDSX - a Collection of Benchmark Examples for State-Space -C Realizations of Continuous-Time Dynamical Systems. -C SLICOT Working Note 1998-9. 1998. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C continuous-time dynamical systems -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, - 2 PI = .3141592653589793D1 ) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), - 1 DWORK(*), E(LDE,*) -C .. Local Scalars .. - CHARACTER*12 DATAF - INTEGER I, J, L, STATUS - DOUBLE PRECISION APPIND, B1, B2, C1, C2, TEMP, TTEMP -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . BLAS . - EXTERNAL DSCAL -C . LAPACK . - EXTERNAL DLASET -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD -C .. Data Statements .. -C . default values for availabities . - DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., - 1 .TRUE., .TRUE., .TRUE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) -10 CONTINUE -C - IF (NR(1) .EQ. 1) THEN -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Laub 1979, Ex.1' - N = 2 - M = 1 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - B(1,1) = ZERO - B(2,1) = ONE - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Laub 1979, Ex.2: uncontrollable-unobservable data' - N = 2 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = .3D1 - A(2,2) = -.35D1 - B(1,1) = ONE - B(2,1) = -ONE - C(1,1) = THREE - C(1,2) = TWO - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Beale/Shafai 1989: model of L-1011 aircraft' - N = 4 - M = 2 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Bhattacharyya et al. 1983: binary distillation column' - N = 8 - M = 2 - P = 8 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 5) THEN - NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' - N = 9 - M = 3 - P = 9 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 6) THEN - NOTE = 'Davison/Gesing 1978: J-100 jet engine' - N = 30 - M = 3 - P = 5 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 7) THEN - NOTE = 'Davison 1967: binary distillation column' - N = 11 - M = 3 - P = 3 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(2,1) = ONE - C(1,10) = ONE - C(3,11) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) - - ELSE IF (NR(2) .EQ. 8) THEN - NOTE = 'Chien/Ergin/Ling/Lee 1958: drum boiler' - N = 9 - M = 3 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,6) = ONE - C(2,9) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 9) THEN - NOTE = 'Ly, Gangsaas 1981: B-767 airplane' - N = 55 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 10) THEN - NOTE = 'control surface servo for an underwater vehicle' - N = 8 - M = 2 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,7) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) - ELSE - INFO = -2 - END IF -C - IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 10)) THEN -C .. loading data files - WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD011', NR(2), '.dat' - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 110 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -110 CONTINUE - DO 120 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -120 CONTINUE - IF ((NR(2) .EQ. 6) .OR. (NR(2) .EQ. 9)) THEN - DO 130 I = 1, P - READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -130 CONTINUE - END IF - END IF - CLOSE(1) - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Chow/Kokotovic 1976: magnetic tape control system' - IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 - IF (DPAR(1) .EQ. ZERO) INFO = -3 - N = 4 - M = 1 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = .400D0 - A(2,3) = .345D0 - A(3,2) = -.524D0/DPAR(1) - A(3,3) = -.465D0/DPAR(1) - A(3,4) = .262D0/DPAR(1) - A(4,4) = -ONE/DPAR(1) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(4,1) = ONE/DPAR(1) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(2,3) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Arnold/Laub 1984' - IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 - N = 4 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) - A(1,1) = -DPAR(1) - A(2,1) = -ONE - A(1,2) = ONE - A(2,2) = -DPAR(1) - A(4,3) = -ONE - A(3,4) = ONE - CALL DLASET('A', N, M, ONE, ONE, B, LDB) - CALL DLASET('A', P, N, ONE, ONE, C, LDC) - D(1,1) = ZERO -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Vertical acceleration of a rigid guided missile' - IF (LSAME(DEF,'D')) IPAR(1) = 1 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 10)) INFO = -4 - N = 3 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(2,1) = ONE - A(3,3) = -.19D3 - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(3,1) = .19D3 - D(1,1) = ZERO - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01203.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 210 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 2, N) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (C(1,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -210 CONTINUE - END IF - CLOSE(1) -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Senning 1980: hydraulic positioning system' - IF (LSAME(DEF,'D')) THEN - DPAR(1) = .14D5 - DPAR(2) = .1287D0 - DPAR(3) = .15D0 - DPAR(4) = .1D-1 - DPAR(5) = .2D-2 - DPAR(6) = .24D0 - DPAR(7) = .1075D2 - END IF - IF (((DPAR(1) .LE. .9D4) .OR. (DPAR(1) .GE. .16D5)) .OR. - 1 ((DPAR(2) .LE. .5D-1) .OR. (DPAR(2) .GE. .3D0)) .OR. - 2 ((DPAR(3) .LE. .5D-1) .OR. (DPAR(3) .GE. .5D1)) .OR. - 3 ((DPAR(4) .LE. ZERO) .OR. (DPAR(4) .GE. .5D-1)) .OR. - 4 ((DPAR(5) .LE. .103D-3) .OR. (DPAR(5) .GE. .35D-2)) .OR. - 5 ((DPAR(6) .LE. .1D-2) .OR. (DPAR(6) .GE. .15D2)) .OR. - 6 ((DPAR(7) .LE. .105D2) .OR. (DPAR(7) .GE. .111D2))) THEN - INFO = -3 - END IF - N = 3 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - A(2,2) = -(DPAR(3) + FOUR*DPAR(4)/PI) / DPAR(2) - A(2,3) = DPAR(7) / DPAR(2) - A(3,2) = -FOUR * DPAR(7) * DPAR(1) / .874D3 - A(3,3) = -FOUR * DPAR(1) * (DPAR(6) + DPAR(5)) / .874D3 - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(3,1) = -FOUR * DPAR(1) / .874D3 - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - D(1,1) = 0 -C - ELSE IF (NR(2) .EQ. 5) THEN - NOTE = 'Kwakernaak/Westdyk 1985: cascade of inverted pendula' - IF (LSAME(DEF,'D')) IPAR(1) = 1 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 7)) INFO = -4 - IF (IPAR(1) .LE. 6) THEN - M = IPAR(1) - ELSE - M = 10 - END IF - N = 2 * M - P = M - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - WRITE (DATAF(1:12), '(A,I1,A)') 'BD01205', IPAR(1), '.dat' - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:12)) - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 220 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -220 CONTINUE - DO 230 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -230 CONTINUE - DO 240 I = 1, P - READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -240 CONTINUE - END IF - CLOSE(1) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 6) THEN - NOTE = 'Kallstrom/Astrom 1981: regulation of a ship heading' - IF (LSAME(DEF,'D')) IPAR(1) = 1 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 5)) INFO = -4 - N = 3 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(3,2) = ONE - B(3,1) = ZERO - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,3) = ONE - D(1,1) = ZERO - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01206.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 250 I = 1, IPAR(1) - READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, 2) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 1, 2) - IF (STATUS .NE. 0) INFO = 1 - READ (1, FMT = *, IOSTAT = STATUS) (B(J,1), J = 1, 2) - IF (STATUS .NE. 0) INFO = 1 -250 CONTINUE - END IF - CLOSE(1) -C - ELSE IF (NR(2) .EQ. 7) THEN - NOTE = 'Ackermann 1989: track-guided bus' - IF (LSAME(DEF,'D')) THEN - DPAR(1) = .15D2 - DPAR(2) = .1D2 - END IF - IF ((DPAR(1) .LT. .995D1) .OR. (DPAR(1) .GT. .16D2)) INFO = -3 - IF ((DPAR(1) .LT. .1D1) .OR. (DPAR(1) .GT. .2D2)) INFO = -3 - N = 5 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,1) = -.668D3 / (DPAR(1)*DPAR(2)) - A(1,2) = -ONE + .1804D3 / (DPAR(1)*DPAR(2)**2) - A(2,1) = .1804D3 / (.1086D2*DPAR(1)) - A(2,2) = -.44175452D4 / (.1086D2*DPAR(1)*DPAR(2)) - A(1,5) = 198 / (DPAR(1)*DPAR(2)) - A(2,5) = .72666D3 / (.1086D2*DPAR(1)) - A(3,1) = DPAR(2) - A(3,4) = DPAR(2) - A(4,2) = ONE - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(5,1) = ONE - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,3) = ONE - C(1,4) = .612D1 - D(1,1) = 0 -C - ELSE - INFO = -2 - END IF -C - ELSE IF (NR(1) .EQ. 3) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Laub 1979, Ex.4: string of high speed vehicles' - IF (LSAME(DEF,'D')) IPAR(1) = 20 - IF (IPAR(1) .LT. 2) INFO = -4 - N = 2*IPAR(1) - 1 - M = IPAR(1) - P = IPAR(1) - 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - DO 310 I = 1, N - IF (MOD(I,2) .EQ. 1) THEN - A(I,I) = -ONE - B(I,(I+1)/2) = ONE - ELSE - A(I,I-1) = ONE - A(I,I+1) = -ONE - C(I/2,I) = ONE - END IF -310 CONTINUE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Hodel et al. 1996: heat flow in a thin rod' - IF (LSAME(DEF,'D')) IPAR(1) = 100 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) - M = 1 - P = N - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - TEMP = DBLE(N + 1) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, -TWO * TEMP, A, LDA) - A(1,1) = -TEMP - DO 320 I = 1, N - 1 - A(I,I+1) = TEMP - A(I+1,I) = TEMP -320 CONTINUE - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(N,1) = TEMP - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Laub 1979, Ex.6' - IF (LSAME(DEF,'D')) IPAR(1) = 21 - IF (IPAR(1) .LT. 1) INFO = -4 - N = IPAR(1) - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(N,1) = ONE - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Lang/Penzl 1994: rotating axle' - IF (LSAME(DEF,'D')) IPAR(1) = 211 - IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 211)) INFO = -4 - N = 2*IPAR(1) - 1 - M = IPAR(1) - P = IPAR(1) - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (LDWORK .LT. M*4) INFO = -21 - IF (INFO .NE. 0) RETURN -C - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01304.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 330 I = 1, M*4 - READ (1, FMT = *, IOSTAT = STATUS) DWORK(I) - IF (STATUS .NE. 0) INFO = 1 -330 CONTINUE - END IF - CLOSE(1) - IF (INFO .NE. 0) RETURN - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - E(1,1) = DWORK(1) - DO 340 I = 2, M - E(I,I-1) = DWORK((I-2) * 4 + 1) - E(I,I) = -DWORK((I-1) * 4 + 1) -340 CONTINUE - E(M,M) = -E(M,M) - DO 350 I = M-1, 1, -1 - DO 345 J = I, M - IF (I .EQ. 1) THEN - E(J,I) = E(J,I) - E(J,I+1) - ELSE - E(J,I) = E(J,I+1) - E(J,I) - END IF -345 CONTINUE -350 CONTINUE - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - DO 360 I = 2, M - A(I-1,I) = DWORK((I-2) * 4 + 3) - A(I,I) = -TWO * DWORK((I-2) * 4 + 3) - DWORK((I-1) * 4 + 2) - A(I,1) = DWORK((I-1) * 4 + 2) - DWORK((I-2) * 4 + 2) - A(I-1,M+I-1) = DWORK((I-1) * 4) - A(I,M+I-1) = -TWO * DWORK((I-1) * 4) - IF (I .LT. M) THEN - A(I+1,I) = DWORK((I-2) * 4 + 3) - DO 355 J = I+1, M - A(J,I) = A(J,I) + DWORK((J-2) * 4 + 2) - 1 - DWORK((J-1) * 4 + 2) -355 CONTINUE - A(I+1,M+I-1) = DWORK((I-1) * 4) - END IF -360 CONTINUE - A(1,1) = -DWORK(2) - A(1,2) = -DWORK(3) - A(1,M+1) = -A(1,M+1) - CALL DLASET('A', M-1, M-1, ZERO, ONE, A(M+1,2), LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - DO 370 I = 2, M - B(I,I) = -ONE - B(I,I-1) = ONE - C(I,I) = DWORK((I-2) * 4 + 3) - C(I,M+I-1) = DWORK((I-1) * 4) -370 CONTINUE - B(1,1) = ONE - C(1,1) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF -C - ELSE IF (NR(1) .EQ. 4) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Rosen/Wang 1995: control of 1-dim. heat flow' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 100 - DPAR(1) = .1D-1 - DPAR(2) = ONE - DPAR(3) = ONE - DPAR(4) = .2D0 - DPAR(5) = .3D0 - DPAR(6) = .2D0 - DPAR(7) = .3D0 - END IF - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - VEC(4) = .TRUE. - APPIND = DBLE(N + 1) - TTEMP = -DPAR(1) * APPIND - TEMP = 1 / (.6D1 * APPIND) - CALL DLASET('A', N, N, ZERO, FOUR*TEMP, E, LDE) - CALL DLASET('A', N, N, ZERO, TWO*TTEMP, A, LDA) - DO 410 I = 1, N - 1 - A(I+1,I) = -TTEMP - A(I,I+1) = -TTEMP - E(I+1,I) = TEMP - E(I,I+1) = TEMP -410 CONTINUE - DO 420 I = 1, N - B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) - B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) - C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) - C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) - IF (B1 .GE. B2) THEN - B(I,1) = ZERO - ELSE - B(I,1) = B2 - B1 - TEMP = MIN(B2, DBLE(I)/APPIND) - IF (B1 .LT. TEMP) THEN - B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO - B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) - END IF - TEMP = MAX(B1, DBLE(I)/APPIND) - IF (TEMP .LT. B2) THEN - B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO - B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) - END IF - END IF - IF (C1 .GE. C2) THEN - C(1,I) = ZERO - ELSE - C(1,I) = C2 - C1 - TEMP = MIN(C2, DBLE(I)/APPIND) - IF (C1 .LT. TEMP) THEN - C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO - C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) - END IF - TEMP = MAX(C1, DBLE(I)/APPIND) - IF (TEMP .LT. C2) THEN - C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO - C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) - END IF - END IF -420 CONTINUE - CALL DSCAL(N, DPAR(2), B(1,1), 1) - CALL DSCAL(N, DPAR(3), C(1,1), LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Hench et al. 1995: coupled springs, dashpots, masses' - IF (LSAME(DEF,'D')) THEN - IPAR(1) = 30 - DPAR(1) = FOUR - DPAR(2) = FOUR - DPAR(3) = ONE - END IF - IF (IPAR(1) .LT. 2) INFO = -4 - L = IPAR(1) - N = 2*L - M = 2 - P = 2*L - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - VEC(4) = .TRUE. - CALL DLASET('A', N, N, ZERO, DPAR(1), E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - TEMP = -TWO * DPAR(3) - DO 430 I = 1, L - E(I,I) = ONE - A(I,I+L) = ONE - A(I+L,I+L) = -DPAR(2) - IF (I .LT. L) THEN - A(I+L,I+1) = DPAR(3) - A(I+L+1,I) = DPAR(3) - IF (I .GT. 1) THEN - A(I+L,I) = TEMP - END IF - END IF - 430 CONTINUE - A(L+1,1) = -DPAR(3) - A(N,L) = -DPAR(3) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(L+1,1) = ONE - B(N,2) = -ONE - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BD01AD *** - END diff --git a/slycot/src/BD02AD.f b/slycot/src/BD02AD.f deleted file mode 100644 index ebe6f4a7..00000000 --- a/slycot/src/BD02AD.f +++ /dev/null @@ -1,601 +0,0 @@ - SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, - 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, - 2 LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate benchmark examples for time-invariant, -C discrete-time dynamical systems -C -C E x_k+1 = A x_k + B u_k -C -C y_k = C x_k + D u_k -C -C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and -C D is P-by-M. In many examples, E is the identity matrix and D is -C the zero matrix. -C -C This routine is an implementation of the benchmark library -C DTDSX (Version 1.0) described in [1]. -C -C ARGUMENTS -C -C Mode Parameters -C -C DEF CHARACTER*1 -C Specifies the kind of values used as parameters when -C generating parameter-dependent and scalable examples -C (i.e., examples with NR(1) = 2, 3, or 4): -C = 'D': Default values defined in [1] are used; -C = 'N': Values set in DPAR and IPAR are used. -C This parameter is not referenced if NR(1) = 1. -C Note that the scaling parameter of examples with -C NR(1) = 3 or 4 is considered as a regular parameter in -C this context. -C -C Input/Output Parameters -C -C NR (input) INTEGER array, dimension (2) -C Specifies the index of the desired example according -C to [1]. -C NR(1) defines the group: -C 1 : parameter-free problems of fixed size -C 2 : parameter-dependent problems of fixed size -C 3 : parameter-free problems of scalable size -C 4 : parameter-dependent problems of scalable size -C NR(2) defines the number of the benchmark example -C within a certain group according to [1]. -C -C DPAR (input/output) DOUBLE PRECISION array, dimension (7) -C On entry, if DEF = 'N' and the desired example depends on -C real parameters, then the array DPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 2.1, DPAR(1), ..., DPAR(3) define the -C parameters 'tau', 'delta', 'K', respectively. -C On exit, if DEF = 'D' and the desired example depends on -C real parameters, then the array DPAR is overwritten by the -C default values given in [1]. -C -C IPAR (input/output) INTEGER array, dimension (1) -C On entry, if DEF = 'N' and the desired example depends on -C integer parameters, then the array IPAR must contain the -C values for these parameters. -C For an explanation of the parameters see [1]. -C For Example 3.1, IPAR(1) defines the parameter 'n'. -C On exit, if DEF = 'D' and the desired example depends on -C integer parameters, then the array IPAR is overwritten by -C the default values given in [1]. -C -C VEC (output) LOGICAL array, dimension (8) -C Flag vector which displays the availabilty of the output -C data: -C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, -C and are always .TRUE.. -C VEC(4) is .TRUE. iff E is NOT the identity matrix. -C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, -C and are always .TRUE.. -C VEC(8) is .TRUE. iff D is NOT the zero matrix. -C -C N (output) INTEGER -C The actual state dimension, i.e., the order of the -C matrices E and A. -C -C M (output) INTEGER -C The number of columns in the matrices B and D. -C -C P (output) INTEGER -C The number of rows in the matrices C and D. -C -C E (output) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array contains the -C matrix E. -C NOTE that this array is overwritten (by the identity -C matrix), if VEC(4) = .FALSE.. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= N. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= P. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C matrix D. -C NOTE that this array is overwritten (by the zero -C matrix), if VEC(8) = .FALSE.. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= P. -C -C NOTE (output) CHARACTER*70 -C String containing short information about the chosen -C example. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C NOTE that DWORK is not used in the current version -C of BD02AD. -C -C LDWORK INTEGER -C LDWORK >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; in particular, INFO = -3 or -4 indicates -C that at least one of the parameters in DPAR or -C IPAR, respectively, has an illegal value; -C = 1: data file can not be opened or has wrong format. -C -C REFERENCES -C -C [1] Kressner, D., Mehrmann, V. and Penzl, T. -C DTDSX - a Collection of Benchmark Examples for State-Space -C Realizations of Discrete-Time Dynamical Systems. -C SLICOT Working Note 1998-10. 1998. -C -C NUMERICAL ASPECTS -C -C None -C -C CONTRIBUTOR -C -C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) -C -C For questions concerning the collection or for the submission of -C test examples, please contact Volker Mehrmann -C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). -C -C REVISIONS -C -C June 1999, V. Sima. -C -C KEYWORDS -C -C discrete-time dynamical systems -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - 1 THREE = 3.0D0, FOUR = 4.0D0, - 2 PI = .3141592653589793D1 ) -C .. Scalar Arguments .. - CHARACTER DEF - CHARACTER*70 NOTE - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P -C .. Array Arguments .. - LOGICAL VEC(8) - INTEGER IPAR(*), NR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), - 1 DWORK(*), E(LDE,*) -C .. Local Scalars .. - CHARACTER*12 DATAF - INTEGER I, J, STATUS - DOUBLE PRECISION TEMP -C .. Local Arrays .. - LOGICAL VECDEF(8) -C .. External Functions .. -C . LAPACK . - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. -C . LAPACK . - EXTERNAL DLASET -C .. Data Statements .. -C . default values for availabities . - DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., - 1 .TRUE., .TRUE., .TRUE., .FALSE./ -C -C .. Executable Statements .. -C - INFO = 0 - DO 10 I = 1, 8 - VEC(I) = VECDEF(I) -10 CONTINUE -C - IF (NR(1) .EQ. 1) THEN -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Laub 1979, Ex. 2: uncontrollable-unobservable data' - N = 2 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - A(1,1) = FOUR - A(2,1) = -.45D1 - A(1,2) = THREE - A(2,2) = -.35D1 - CALL DLASET('A', N, M, -ONE, ONE, B, LDB) - C(1,1) = 3.0D0 - C(1,2) = 2.0D0 - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 2) THEN - NOTE = 'Laub 1979, Ex. 3' - N = 2 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,1) = .9512D0 - A(2,2) = .9048D0 - B(1,1) = .4877D1 - B(1,2) = .4877D1 - B(2,1) = -.11895D1 - B(2,2) = .3569D1 - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 3) THEN - NOTE = 'Van Dooren 1981, Ex. II' - N = 2 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - A(1,1) = TWO - A(2,1) = ONE - A(1,2) = -ONE - A(2,2) = ZERO - CALL DLASET('A', N, M, ZERO, ONE, B, LDB) - CALL DLASET('A', P, N, ONE, ZERO, C, LDC) - D(1,1) = ZERO -C - ELSE IF (NR(2) .EQ. 4) THEN - NOTE = 'Ionescu/Weiss 1992' - N = 2 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - A(2,2) = -ONE - CALL DLASET('A', N, M, ZERO, ONE, B, LDB) - B(2,1) = TWO - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 5) THEN - NOTE = 'Jonckheere 1981' - N = 2 - M = 1 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - CALL DLASET('A', N, M, ONE, ZERO, B, LDB) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 6) THEN - NOTE = 'Ackerson/Fu 1970: satellite control problem' - N = 4 - M = 2 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 7) THEN - NOTE = 'Litkouhi 1983: system with slow and fast modes' - N = 4 - M = 2 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 8) THEN - NOTE = 'Lu/Lin 1993, Ex. 4.3' - N = 4 - M = 4 - P = 4 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('U', P, N, ONE, ONE, C, LDC) - C(1,3) = TWO - C(1,4) = FOUR - C(2,4) = TWO - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 9) THEN - NOTE = 'Gajic/Shen 1993, Section 2.7.4: chemical plant' - N = 5 - M = 2 - P = 5 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 10) THEN - NOTE = 'Davison/Wang 1974' - N = 6 - M = 2 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN - VEC(8) = .TRUE. -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - A(1,2) = ONE - A(2,3) = ONE - A(4,5) = ONE - A(5,6) = ONE - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(3,1) = ONE - B(6,2) = ONE - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(1,2) = ONE - C(2,4) = ONE - C(2,5) = -ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) - D(1,1) = ONE - D(2,1) = ONE -C - ELSE IF (NR(2) .EQ. 11) THEN - NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' - N = 9 - M = 3 - P = 2 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(2,5) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE IF (NR(2) .EQ. 12) THEN - NOTE = 'Smith 1969: two-stand cold rolling mill' - N = 10 - M = 3 - P = 5 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN - VEC(8) = .TRUE. -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N, N, ZERO, ONE, A(2,1), LDA) - A(1,10) = .112D0 - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(1,1) = .276D1 - B(1,2) = -.135D1 - B(1,3) = -.46D0 - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,1) = ONE - C(2,10) = .894D0 - C(3,10) = -.1693D2 - C(4,10) = .7D-1 - C(5,10) = .398D0 - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD02112.dat') - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 110 I = 1, P - READ (1, FMT = *, IOSTAT = STATUS) (D(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -110 CONTINUE - END IF - CLOSE(1) -C - ELSE - INFO = -2 - END IF -C - IF (((NR(2) .GE. 6) .AND. (NR(2) .LE. 9)) .OR. - 1 (NR(2) .EQ. 11)) THEN -C .. loading data files - WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD021', NR(2), '.dat' - OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) - IF (STATUS .NE. 0) THEN - INFO = 1 - ELSE - DO 120 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) - IF (STATUS .NE. 0) INFO = 1 -120 CONTINUE - DO 130 I = 1, N - READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) - IF (STATUS .NE. 0) INFO = 1 -130 CONTINUE - END IF - CLOSE(1) - END IF -C - ELSE IF (NR(1) .EQ. 2) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Pappas et al. 1980: process control of paper machine' - IF (LSAME(DEF,'D')) THEN - DPAR(1) = .1D9 - DPAR(2) = ONE - DPAR(3) = ONE - END IF - IF (DPAR(1) .EQ. ZERO) INFO = -3 - N = 4 - M = 1 - P = 1 - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - TEMP = DPAR(2) / DPAR(1) - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N-1, N-1, ZERO, ONE, A(2,1), LDA) - A(1,1) = ONE - TEMP - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(1,1) = DPAR(3) * TEMP - CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) - C(1,4) = ONE - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF -C - ELSE IF (NR(1) .EQ. 3) THEN - IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN - INFO = -1 - RETURN - END IF -C - IF (NR(2) .EQ. 1) THEN - NOTE = 'Pappas et al. 1980, Ex. 3' - IF (LSAME(DEF,'D')) IPAR(1) = 100 - IF (IPAR(1) .LT. 2) INFO = -4 - N = IPAR(1) - M = 1 - P = N - IF (LDE .LT. N) INFO = -10 - IF (LDA .LT. N) INFO = -12 - IF (LDB .LT. N) INFO = -14 - IF (LDC .LT. P) INFO = -16 - IF (LDD .LT. P) INFO = -18 - IF (INFO .NE. 0) RETURN -C - CALL DLASET('A', N, N, ZERO, ONE, E, LDE) - CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) - CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) - CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) - B(N,1) = ONE - CALL DLASET('A', P, N, ZERO, ONE, C, LDC) - CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) -C - ELSE - INFO = -2 - END IF -C - ELSE - INFO = -2 - END IF -C - RETURN -C *** Last Line of BD02AD *** - END diff --git a/slycot/src/DE01OD.f b/slycot/src/DE01OD.f deleted file mode 100644 index b2b0a608..00000000 --- a/slycot/src/DE01OD.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE DE01OD( CONV, N, A, B, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the convolution or deconvolution of two real signals -C A and B. -C -C ARGUMENTS -C -C Mode Parameters -C -C CONV CHARACTER*1 -C Indicates whether convolution or deconvolution is to be -C performed as follows: -C = 'C': Convolution; -C = 'D': Deconvolution. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N must be a power of 2. N >= 2. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the first signal. -C On exit, this array contains the convolution (if -C CONV = 'C') or deconvolution (if CONV = 'D') of the two -C signals. -C -C B (input) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the second signal. -C NOTE that this array is overwritten. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine computes the convolution or deconvolution of two real -C signals A and B using an FFT algorithm (SLICOT Library routine -C DG01MD). -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DE01CD by R. Dekeyser, State -C University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Convolution, deconvolution, digital signal processing, fast -C Fourier transform, real signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF=0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER CONV - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - LOGICAL LCONV - INTEGER J, KJ, ND2P1 - DOUBLE PRECISION AC, AS, AST, BC, BS, CI, CR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01MD, DLADIV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MOD -C .. Executable Statements .. -C - INFO = 0 - LCONV = LSAME( CONV, 'C' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN - INFO = -1 - ELSE - J = 0 - IF( N.GE.2 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( J.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DE01OD', -INFO ) - RETURN - END IF -C -C Fourier transform. -C - CALL DG01MD( 'Direct', N, A, B, INFO ) -C - IF ( LCONV ) THEN - AST = A(1)*B(1) - ELSE - IF ( B(1).EQ.ZERO ) THEN - AST = ZERO - ELSE - AST = A(1)/B(1) - END IF - END IF -C - ND2P1 = N/2 + 1 - J = ND2P1 -C - DO 20 KJ = ND2P1, N -C -C Components of the transform of function A. -C - AC = HALF*( A(J) + A(KJ) ) - AS = HALF*( B(J) - B(KJ) ) -C -C Components of the transform of function B. -C - BC = HALF*( B(KJ) + B(J) ) - BS = HALF*( A(KJ) - A(J) ) -C -C Deconvolution by complex division if CONV = 'D'; -C Convolution by complex multiplication if CONV = 'C'. -C - IF ( LCONV ) THEN - CR = AC*BC - AS*BS - CI = AS*BC + AC*BS - ELSE - IF ( MAX( ABS( BC ), ABS( BS ) ).EQ.ZERO ) THEN - CR = ZERO - CI = ZERO - ELSE - CALL DLADIV( AC, AS, BC, BS, CR, CI ) - END IF - END IF -C - A(J) = CR - B(J) = CI - A(KJ) = CR - B(KJ) = -CI - J = J - 1 - 20 CONTINUE - A(1) = AST - B(1) = ZERO -C -C Inverse Fourier transform. -C - CALL DG01MD( 'Inverse', N, A, B, INFO ) -C - CALL DSCAL( N, ONE/DBLE( N ), A, 1 ) -C - RETURN -C *** Last line of DE01OD *** - END diff --git a/slycot/src/DE01PD.f b/slycot/src/DE01PD.f deleted file mode 100644 index 0358e803..00000000 --- a/slycot/src/DE01PD.f +++ /dev/null @@ -1,236 +0,0 @@ - SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the convolution or deconvolution of two real signals -C A and B using the Hartley transform. -C -C ARGUMENTS -C -C Mode Parameters -C -C CONV CHARACTER*1 -C Indicates whether convolution or deconvolution is to be -C performed as follows: -C = 'C': Convolution; -C = 'D': Deconvolution. -C -C WGHT CHARACTER*1 -C Indicates whether the precomputed weights are available -C or not, as follows: -C = 'A': available; -C = 'N': not available. -C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is -C set to 'A' on exit. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N must be a power of 2. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the first signal. -C On exit, this array contains the convolution (if -C CONV = 'C') or deconvolution (if CONV = 'D') of the two -C signals. -C -C B (input) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the second signal. -C NOTE that this array is overwritten. -C -C W (input/output) DOUBLE PRECISION array, -C dimension (N - LOG2(N)) -C On entry with WGHT = 'A', this array must contain the long -C weight vector computed by a previous call of this routine -C or of the SLICOT Library routine DG01OD.f, with the same -C value of N. If WGHT = 'N', the contents of this array on -C entry is ignored. -C On exit, this array contains the long weight vector. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine computes the convolution or deconvolution of two -C real signals A and B using three scrambled Hartley transforms -C (SLICOT Library routine DG01OD). -C -C REFERENCES -C -C [1] Van Loan, Charles. -C Computational frameworks for the fast Fourier transform. -C SIAM, 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N log(N)) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, April 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C KEYWORDS -C -C Convolution, deconvolution, digital signal processing, -C fast Hartley transform, real signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HALF, ONE, TWO - PARAMETER ( HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER CONV, WGHT - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*), W(*) -C .. Local Scalars .. - LOGICAL LCONV, LWGHT - INTEGER J, L, LEN, M, P1, R1 - DOUBLE PRECISION T1, T2, T3 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01OD, DLADIV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MOD -C .. Executable Statements .. -C - INFO = 0 - LCONV = LSAME( CONV, 'C' ) - LWGHT = LSAME( WGHT, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN - INFO = -2 - ELSE - M = 0 - J = 0 - IF( N.GE.1 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - M = M + 1 - GO TO 10 - END IF -C END WHILE 10 - IF ( J.NE.1 ) INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DE01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.LE.0 ) THEN - RETURN - ELSE IF ( N.EQ.1 ) THEN - IF ( LCONV ) THEN - A(1) = A(1)*B(1) - ELSE - A(1) = A(1)/B(1) - END IF - RETURN - END IF -C -C Scrambled Hartley transforms of A and B. -C - CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO ) - CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO ) -C -C Something similar to a Hadamard product/quotient. -C - LEN = 1 - IF( LCONV ) THEN - A(1) = TWO*A(1)*B(1) - A(2) = TWO*A(2)*B(2) -C - DO 30 L = 1, M - 1 - LEN = 2*LEN - R1 = 2*LEN -C - DO 20 P1 = LEN + 1, LEN + LEN/2 - T1 = B(P1) + B(R1) - T2 = B(P1) - B(R1) - T3 = T2*A(P1) - A(P1) = T1*A(P1) + T2*A(R1) - A(R1) = T1*A(R1) - T3 - R1 = R1 - 1 - 20 CONTINUE -C - 30 CONTINUE -C - ELSE -C - A(1) = HALF*A(1)/B(1) - A(2) = HALF*A(2)/B(2) -C - DO 50 L = 1, M - 1 - LEN = 2*LEN - R1 = 2*LEN -C - DO 40 P1 = LEN + 1, LEN + LEN/2 - CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1, - $ T2 ) - A(P1) = T1 - A(R1) = T2 - R1 = R1 - 1 - 40 CONTINUE -C - 50 CONTINUE -C - END IF -C -C Transposed Hartley transform of A. -C - CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO ) - IF ( LCONV ) THEN - CALL DSCAL( N, HALF/DBLE( N ), A, 1 ) - ELSE - CALL DSCAL( N, TWO/DBLE( N ), A, 1 ) - END IF -C - RETURN -C *** Last line of DE01PD *** - END diff --git a/slycot/src/DF01MD.f b/slycot/src/DF01MD.f deleted file mode 100644 index 1dafa4b9..00000000 --- a/slycot/src/DF01MD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the sine transform or cosine transform of a real -C signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SICO CHARACTER*1 -C Indicates whether the sine transform or cosine transform -C is to be computed as follows: -C = 'S': The sine transform is computed; -C = 'C': The cosine transform is computed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N must be a power of 2 plus 1. -C N >= 5. -C -C DT (input) DOUBLE PRECISION -C The sampling time of the signal. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the signal to be -C processed. -C On exit, this array contains either the sine transform, if -C SICO = 'S', or the cosine transform, if SICO = 'C', of the -C given signal. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N+1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let A(1), A(2),..., A(N) be a real signal of N samples. -C -C If SICO = 'S', the routine computes the sine transform of A as -C follows. First, transform A(i), i = 1,2,...,N, into the complex -C signal B(i), i = 1,2,...,(N+1)/2, where -C -C B(1) = -2*A(2), -C B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2, -C B((N+1)/2) = 2*A(N-1) and j**2 = -1. -C -C Next, perform a discrete inverse Fourier transform on B(i) by -C calling SLICOT Library Routine DG01ND, to give the complex signal -C Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be -C obtained as follows: -C -C C(2i-1) = Re(Z(i)), C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. -C -C Finally, compute the sine transform coefficients S ,S ,...,S -C 1 2 N -C given by -C -C S = 0, -C 1 -C { [C(k) + C(N+1-k)] } -C S = DT*{[C(k) - C(N+1-k)] - -----------------------}, -C k { [2*sin(pi*(k-1)/(N-1))]} -C -C for k = 2,3,...,N-1, and -C -C S = 0. -C N -C -C If SICO = 'C', the routine computes the cosine transform of A as -C follows. First, transform A(i), i = 1,2,...,N, into the complex -C signal B(i), i = 1,2,...,(N+1)/2, where -C -C B(1) = 2*A(1), -C B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]} -C for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N). -C -C Next, perform a discrete inverse Fourier transform on B(i) by -C calling SLICOT Library Routine DG01ND, to give the complex signal -C Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be -C obtained as follows: -C -C D(2i-1) = Re(Z(i)), D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. -C -C Finally, compute the cosine transform coefficients S ,S ,...,S -C 1 2 N -C given by -C -C S = 2*DT*[D(1) + A0], -C 1 -C { [D(k) - D(N+1-k)] } -C S = DT*{[D(k) + D(N+1-k)] - -----------------------}, -C k { [2*sin(pi*(k-1)/(N-1))]} -C -C -C for k = 2,3,...,N-1, and -C -C S = 2*DT*[D(1) - A0], -C N -C (N-1)/2 -C where A0 = 2*SUM A(2i). -C i=1 -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C [2] Oppenheim, A.V. and Schafer, R.W. -C Discrete-Time Signal Processing. -C Prentice-Hall Signal Processing Series, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DF01AD by F. Dumortier, and -C R.M.C. Dekeyser, State University of Gent, Belgium. -C -C REVISIONS -C -C V. Sima, Jan. 2003. -C -C KEYWORDS -C -C Digital signal processing, fast Fourier transform, complex -C signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -C .. Scalar Arguments .. - CHARACTER SICO - INTEGER INFO, N - DOUBLE PRECISION DT -C .. Array Arguments .. - DOUBLE PRECISION A(*), DWORK(*) -C .. Local Scalars .. - LOGICAL LSICO, LSIG - INTEGER I, I2, IND1, IND2, M, MD2 - DOUBLE PRECISION A0, PIBYM, W1, W2, W3 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01ND, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, DBLE, MOD, SIN -C .. Executable Statements .. -C - INFO = 0 - LSICO = LSAME( SICO, 'S' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN - INFO = -1 - ELSE - M = 0 - IF( N.GT.4 ) THEN - M = N - 1 -C WHILE ( MOD( M, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( M, 2 ).EQ.0 ) THEN - M = M/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( M.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DF01MD', -INFO ) - RETURN - END IF -C -C Initialisation. -C - M = N - 1 - MD2 = ( N + 1 )/2 - PIBYM = FOUR*ATAN( ONE )/DBLE( M ) - I2 = 1 - DWORK(MD2+1) = ZERO - DWORK(2*MD2) = ZERO -C - IF ( LSICO ) THEN -C -C Sine transform. -C - LSIG = .TRUE. - DWORK(1) = -TWO*A(2) - DWORK(MD2) = TWO*A(M) -C - DO 20 I = 4, M, 2 - I2 = I2 + 1 - DWORK(I2) = A(I-2) - A(I) - DWORK(MD2+I2) = -A(I-1) - 20 CONTINUE -C - ELSE -C -C Cosine transform. -C - LSIG = .FALSE. - DWORK(1) = TWO*A(1) - DWORK(MD2) = TWO*A(N) - A0 = A(2) -C - DO 30 I = 4, M, 2 - I2 = I2 + 1 - DWORK(I2) = TWO*A(I-1) - DWORK(MD2+I2) = TWO*( A(I-2) - A(I) ) - A0 = A0 + A(I) - 30 CONTINUE -C - A0 = TWO*A0 - END IF -C -C Inverse Fourier transform. -C - CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO ) -C -C Sine or cosine coefficients. -C - IF ( LSICO ) THEN - A(1) = ZERO - A(N) = ZERO - ELSE - A(1) = TWO*DT*( DWORK(1) + A0 ) - A(N) = TWO*DT*( DWORK(1) - A0 ) - END IF -C - IND1 = MD2 + 1 - IND2 = N -C - DO 40 I = 1, M - 1, 2 - W1 = DWORK(IND1) - W2 = DWORK(IND2) - IF ( LSIG ) W2 = -W2 - W3 = TWO*SIN( PIBYM*DBLE( I ) ) - A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) - IND1 = IND1 + 1 - IND2 = IND2 - 1 - 40 CONTINUE -C - IND1 = 2 - IND2 = MD2 - 1 -C - DO 50 I = 2, M - 2, 2 - W1 = DWORK(IND1) - W2 = DWORK(IND2) - IF ( LSIG ) W2 = -W2 - W3 = TWO*SIN( PIBYM*DBLE( I ) ) - A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) - IND1 = IND1 + 1 - IND2 = IND2 - 1 - 50 CONTINUE -C - RETURN -C *** Last line of DF01MD *** - END diff --git a/slycot/src/DG01MD.f b/slycot/src/DG01MD.f deleted file mode 100644 index ac91ab31..00000000 --- a/slycot/src/DG01MD.f +++ /dev/null @@ -1,235 +0,0 @@ - SUBROUTINE DG01MD( INDI, N, XR, XI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the discrete Fourier transform, or inverse transform, -C of a complex signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C INDI CHARACTER*1 -C Indicates whether a Fourier transform or inverse Fourier -C transform is to be performed as follows: -C = 'D': (Direct) Fourier transform; -C = 'I': Inverse Fourier transform. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of complex samples. N must be a power of 2. -C N >= 2. -C -C XR (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the real part of either -C the complex signal z if INDI = 'D', or f(z) if INDI = 'I'. -C On exit, this array contains either the real part of the -C computed Fourier transform f(z) if INDI = 'D', or the -C inverse Fourier transform z of f(z) if INDI = 'I'. -C -C XI (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the imaginary part of -C either z if INDI = 'D', or f(z) if INDI = 'I'. -C On exit, this array contains either the imaginary part of -C f(z) if INDI = 'D', or z if INDI = 'I'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If INDI = 'D', then the routine performs a discrete Fourier -C transform on the complex signal Z(i), i = 1,2,...,N. If the result -C is denoted by FZ(k), k = 1,2,...,N, then the relationship between -C Z and FZ is given by the formula: -C -C N ((k-1)*(i-1)) -C FZ(k) = SUM ( Z(i) * V ), -C i=1 -C 2 -C where V = exp( -2*pi*j/N ) and j = -1. -C -C If INDI = 'I', then the routine performs an inverse discrete -C Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If -C the result is denoted by Z(i), i = 1,2,...,N, then the -C relationship between Z and FZ is given by the formula: -C -C N ((k-1)*(i-1)) -C Z(i) = SUM ( FZ(k) * W ), -C k=1 -C -C where W = exp( 2*pi*j/N ). -C -C Note that a discrete Fourier transform, followed by an inverse -C discrete Fourier transform, will result in a signal which is a -C factor N larger than the original input signal. -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DG01AD by R. Dekeyser, State -C University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Complex signals, digital signal processing, fast Fourier -C transform. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, EIGHT = 8.0D0 ) -C .. Scalar Arguments .. - CHARACTER INDI - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION XI(*), XR(*) -C .. Local Scalars .. - LOGICAL LINDI - INTEGER I, J, K, L, M - DOUBLE PRECISION PI2, TI, TR, WHELP, WI, WR, WSTPI, WSTPR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, DBLE, MOD, SIN -C .. Executable Statements .. -C - INFO = 0 - LINDI = LSAME( INDI, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN - INFO = -1 - ELSE - J = 0 - IF( N.GE.2 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( J.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DG01MD', -INFO ) - RETURN - END IF -C -C Inplace shuffling of data. -C - J = 1 -C - DO 30 I = 1, N - IF ( J.GT.I ) THEN - TR = XR(I) - TI = XI(I) - XR(I) = XR(J) - XI(I) = XI(J) - XR(J) = TR - XI(J) = TI - END IF - K = N/2 -C REPEAT - 20 IF ( J.GT.K ) THEN - J = J - K - K = K/2 - IF ( K.GE.2 ) GO TO 20 - END IF -C UNTIL ( K.LT.2 ) - J = J + K - 30 CONTINUE -C -C Transform by decimation in time. -C - PI2 = EIGHT*ATAN( ONE ) - IF ( LINDI ) PI2 = -PI2 -C - I = 1 -C -C WHILE ( I.LT.N ) DO -C - 40 IF ( I.LT.N ) THEN - L = 2*I - WHELP = PI2/DBLE( L ) - WSTPI = SIN( WHELP ) - WHELP = SIN( HALF*WHELP ) - WSTPR = -TWO*WHELP*WHELP - WR = ONE - WI = ZERO -C - DO 60 J = 1, I -C - DO 50 K = J, N, L - M = K + I - TR = WR*XR(M) - WI*XI(M) - TI = WR*XI(M) + WI*XR(M) - XR(M) = XR(K) - TR - XI(M) = XI(K) - TI - XR(K) = XR(K) + TR - XI(K) = XI(K) + TI - 50 CONTINUE -C - WHELP = WR - WR = WR + WR*WSTPR - WI*WSTPI - WI = WI + WHELP*WSTPI + WI*WSTPR - 60 CONTINUE -C - I = L - GO TO 40 -C END WHILE 40 - END IF -C - RETURN -C *** Last line of DG01MD *** - END diff --git a/slycot/src/DG01ND.f b/slycot/src/DG01ND.f deleted file mode 100644 index 0a97d0ea..00000000 --- a/slycot/src/DG01ND.f +++ /dev/null @@ -1,247 +0,0 @@ - SUBROUTINE DG01ND( INDI, N, XR, XI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the discrete Fourier transform, or inverse Fourier -C transform, of a real signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C INDI CHARACTER*1 -C Indicates whether a Fourier transform or inverse Fourier -C transform is to be performed as follows: -C = 'D': (Direct) Fourier transform; -C = 'I': Inverse Fourier transform. -C -C Input/Output Parameters -C -C N (input) INTEGER -C Half the number of real samples. N must be a power of 2. -C N >= 2. -C -C XR (input/output) DOUBLE PRECISION array, dimension (N+1) -C On entry with INDI = 'D', the first N elements of this -C array must contain the odd part of the input signal; for -C example, XR(I) = A(2*I-1) for I = 1,2,...,N. -C On entry with INDI = 'I', the first N+1 elements of this -C array must contain the the real part of the input discrete -C Fourier transform (computed, for instance, by a previous -C call of the routine). -C On exit with INDI = 'D', the first N+1 elements of this -C array contain the real part of the output signal, that is -C of the computed discrete Fourier transform. -C On exit with INDI = 'I', the first N elements of this -C array contain the odd part of the output signal, that is -C of the computed inverse discrete Fourier transform. -C -C XI (input/output) DOUBLE PRECISION array, dimension (N+1) -C On entry with INDI = 'D', the first N elements of this -C array must contain the even part of the input signal; for -C example, XI(I) = A(2*I) for I = 1,2,...,N. -C On entry with INDI = 'I', the first N+1 elements of this -C array must contain the the imaginary part of the input -C discrete Fourier transform (computed, for instance, by a -C previous call of the routine). -C On exit with INDI = 'D', the first N+1 elements of this -C array contain the imaginary part of the output signal, -C that is of the computed discrete Fourier transform. -C On exit with INDI = 'I', the first N elements of this -C array contain the even part of the output signal, that is -C of the computed inverse discrete Fourier transform. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let A(1),....,A(2*N) be a real signal of 2*N samples. Then the -C first N+1 samples of the discrete Fourier transform of this signal -C are given by the formula: -C -C 2*N ((m-1)*(i-1)) -C FA(m) = SUM ( A(i) * W ), -C i=1 -C 2 -C where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1. -C -C This transform can be computed as follows. First, transform A(i), -C i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)), -C i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next, -C perform a discrete Fourier transform on Z(i) by calling SLICOT -C Library routine DG01MD. This gives a new complex signal FZ(k), -C such that -C -C N ((k-1)*(i-1)) -C FZ(k) = SUM ( Z(i) * V ), -C i=1 -C -C where k = 1,2,...,N, V = exp(-2*pi*j/N). Using the values of -C FZ(k), the components of the discrete Fourier transform FA can be -C computed by simple linear relations, implemented in the DG01NY -C subroutine. -C -C Finally, let -C -C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)), k = 1,2,...,N, -C -C be the contents of the arrays XR and XI on entry to DG01NY with -C INDI = 'D', then on exit XR and XI contain the real and imaginary -C parts of the Fourier transform of the original real signal A. -C That is, -C -C XR(m) = Re(FA(m)), XI(m) = Im(FA(m)), -C -C where m = 1,2,...,N+1. -C -C If INDI = 'I', then the routine evaluates the inverse Fourier -C transform of a complex signal which may itself be the discrete -C Fourier transform of a real signal. -C -C Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier -C transform of a real signal A(i), i=1,2,...,2*N. The relationship -C between FA and A is given by the formula: -C -C 2*N ((m-1)*(i-1)) -C A(i) = SUM ( FA(m) * W ), -C m=1 -C -C where W = exp(pi*j/N). -C -C Let -C -C XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1, -C -C be the contents of the arrays XR and XI on entry to the routine -C DG01NY with INDI = 'I', then on exit the first N samples of the -C complex signal FZ are returned in XR and XI such that -C -C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N. -C -C Next, an inverse Fourier transform is performed on FZ (e.g. by -C calling SLICOT Library routine DG01MD), to give the complex signal -C Z, whose i-th component is given by the formula: -C -C N ((k-1)*(i-1)) -C Z(i) = SUM ( FZ(k) * V ), -C k=1 -C -C where i = 1,2,...,N and V = exp(2*pi*j/N). -C -C Finally, the 2*N samples of the real signal A can then be obtained -C directly from Z. That is, -C -C A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N. -C -C Note that a discrete Fourier transform, followed by an inverse -C transform will result in a signal which is a factor 2*N larger -C than the original input signal. -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N*log(N) ) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DG01BD by R. Dekeyser, and -C F. Dumortier, State University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Complex signals, digital signal processing, fast Fourier -C transform, real signals. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER INDI - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION XI(*), XR(*) -C .. Local Scalars .. - INTEGER J - LOGICAL LINDI -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DG01MD, DG01NY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MOD -C .. Executable Statements .. -C - INFO = 0 - LINDI = LSAME( INDI, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN - INFO = -1 - ELSE - J = 0 - IF( N.GE.2 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - GO TO 10 - END IF -C END WHILE 10 - END IF - IF ( J.NE.1 ) INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DG01ND', -INFO ) - RETURN - END IF -C -C Compute the Fourier transform of Z = (XR,XI). -C - IF ( .NOT.LINDI ) CALL DG01NY( INDI, N, XR, XI ) -C - CALL DG01MD( INDI, N, XR, XI, INFO ) -C - IF ( LINDI ) CALL DG01NY( INDI, N, XR, XI ) -C - RETURN -C *** Last line of DG01ND *** - END diff --git a/slycot/src/DG01NY.f b/slycot/src/DG01NY.f deleted file mode 100644 index 9b7929de..00000000 --- a/slycot/src/DG01NY.f +++ /dev/null @@ -1,94 +0,0 @@ - SUBROUTINE DG01NY( INDI, N, XR, XI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C For efficiency, no tests of the input scalar parameters are -C performed. -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT - PARAMETER ( ZERO=0.0D0, HALF=0.5D0, ONE = 1.0D0, - $ TWO=2.0D0, EIGHT=8.0D0 ) -C .. Scalar Arguments .. - CHARACTER INDI - INTEGER N -C .. Array Arguments .. - DOUBLE PRECISION XI(*), XR(*) -C .. Local Scalars .. - LOGICAL LINDI - INTEGER I, J, N2 - DOUBLE PRECISION AI, AR, BI, BR, HELPI, HELPR, PI2, WHELP, WI, - $ WR, WSTPI, WSTPR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. Intrinsic Functions .. - INTRINSIC ATAN, DBLE, SIN -C .. Executable Statements .. -C - LINDI = LSAME( INDI, 'D' ) -C -C Initialisation. -C - PI2 = EIGHT*ATAN( ONE ) - IF ( LINDI ) PI2 = -PI2 -C - WHELP = PI2/DBLE( 2*N ) - WSTPI = SIN( WHELP ) - WHELP = SIN( HALF*WHELP ) - WSTPR = -TWO*WHELP*WHELP - WI = ZERO -C - IF ( LINDI ) THEN - WR = ONE - XR(N+1) = XR(1) - XI(N+1) = XI(1) - ELSE - WR = -ONE - END IF -C -C Recursion. -C - N2 = N/2 + 1 - DO 10 I = 1, N2 - J = N + 2 - I - AR = XR(I) + XR(J) - AI = XI(I) - XI(J) - BR = XI(I) + XI(J) - BI = XR(J) - XR(I) - IF ( LINDI ) THEN - AR = HALF*AR - AI = HALF*AI - BR = HALF*BR - BI = HALF*BI - END IF - HELPR = WR*BR - WI*BI - HELPI = WR*BI + WI*BR - XR(I) = AR + HELPR - XI(I) = AI + HELPI - XR(J) = AR - HELPR - XI(J) = HELPI - AI - WHELP = WR - WR = WR + WR*WSTPR - WI*WSTPI - WI = WI + WI*WSTPR + WHELP*WSTPI - 10 CONTINUE -C - RETURN -C *** Last line of DG01NY *** - END diff --git a/slycot/src/DG01OD.f b/slycot/src/DG01OD.f deleted file mode 100644 index ded9d479..00000000 --- a/slycot/src/DG01OD.f +++ /dev/null @@ -1,357 +0,0 @@ - SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the (scrambled) discrete Hartley transform of -C a real signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SCR CHARACTER*1 -C Indicates whether the signal is scrambled on input or -C on output as follows: -C = 'N': the signal is not scrambled at all; -C = 'I': the input signal is bit-reversed; -C = 'O': the output transform is bit-reversed. -C -C WGHT CHARACTER*1 -C Indicates whether the precomputed weights are available -C or not, as follows: -C = 'A': available; -C = 'N': not available. -C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is -C set to 'A' on exit. -C -C Input/Output Parameters -C -C N (input) INTEGER -C Number of real samples. N must be a power of 2. -C N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry with SCR = 'N' or SCR = 'O', this array must -C contain the input signal. -C On entry with SCR = 'I', this array must contain the -C bit-reversed input signal. -C On exit with SCR = 'N' or SCR = 'I', this array contains -C the Hartley transform of the input signal. -C On exit with SCR = 'O', this array contains the -C bit-reversed Hartley transform. -C -C W (input/output) DOUBLE PRECISION array, -C dimension (N - LOG2(N)) -C On entry with WGHT = 'A', this array must contain the long -C weight vector computed by a previous call of this routine -C with the same value of N. If WGHT = 'N', the contents of -C this array on entry is ignored. -C On exit, this array contains the long weight vector. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine uses a Hartley butterfly algorithm as described -C in [1]. -C -C REFERENCES -C -C [1] Van Loan, Charles. -C Computational frameworks for the fast Fourier transform. -C SIAM, 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable and requires O(N log(N)) -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, April 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C KEYWORDS -C -C Digital signal processing, fast Hartley transform, real signals. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, FOUR - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0 ) -C .. Scalar Arguments .. - CHARACTER SCR, WGHT - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*), W(*) -C .. Local Scalars .. - INTEGER I, J, L, LEN, M, P1, P2, Q1, Q2, R1, R2, S1, S2, - $ WPOS - LOGICAL LFWD, LSCR, LWGHT - DOUBLE PRECISION CF, SF, T1, T2, TH -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, COS, DBLE, MOD, SIN -C .. Executable Statements .. -C - INFO = 0 - LFWD = LSAME( SCR, 'N' ) .OR. LSAME( SCR, 'I' ) - LSCR = LSAME( SCR, 'I' ) .OR. LSAME( SCR, 'O' ) - LWGHT = LSAME( WGHT, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.( LFWD .OR. LSCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN - INFO = -2 - ELSE - M = 0 - J = 0 - IF( N.GE.1 ) THEN - J = N -C WHILE ( MOD( J, 2 ).EQ.0 ) DO - 10 CONTINUE - IF ( MOD( J, 2 ).EQ.0 ) THEN - J = J/2 - M = M + 1 - GO TO 10 - END IF -C END WHILE 10 - IF ( J.NE.1 ) INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DG01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.LE.1 ) - $ RETURN -C - IF ( .NOT. LWGHT ) THEN -C -C Compute the long weight vector via subvector scaling. -C - R1 = 1 - LEN = 1 - TH = FOUR*ATAN( ONE ) / DBLE( N ) -C - DO 30 L = 1, M - 2 - LEN = 2*LEN - TH = TWO*TH - CF = COS(TH) - SF = SIN(TH) - W(R1) = CF - W(R1+1) = SF - R1 = R1 + 2 -C - DO 20 I = 1, LEN - 2, 2 - W(R1) = CF*W(I) - SF*W(I+1) - W(R1+1) = SF*W(I) + CF*W(I+1) - R1 = R1 + 2 - 20 CONTINUE -C - 30 CONTINUE -C - P1 = 3 - Q1 = R1 - 2 -C - DO 50 L = M - 2, 1, -1 -C - DO 40 I = P1, Q1, 4 - W(R1) = W(I) - W(R1+1) = W(I+1) - R1 = R1 + 2 - 40 CONTINUE -C - P1 = Q1 + 4 - Q1 = R1 - 2 - 50 CONTINUE -C - WGHT = 'A' -C - END IF -C - IF ( LFWD .AND. .NOT.LSCR ) THEN -C -C Inplace shuffling of data. -C - J = 1 -C - DO 70 I = 1, N - IF ( J.GT.I ) THEN - T1 = A(I) - A(I) = A(J) - A(J) = T1 - END IF - L = N/2 -C REPEAT - 60 IF ( J.GT.L ) THEN - J = J - L - L = L/2 - IF ( L.GE.2 ) GO TO 60 - END IF -C UNTIL ( L.LT.2 ) - J = J + L - 70 CONTINUE -C - END IF -C - IF ( LFWD ) THEN -C -C Compute Hartley transform with butterfly operators. -C - DO 110 J = 2, N, 2 - T1 = A(J) - A(J) = A(J-1) - T1 - A(J-1) = A(J-1) + T1 - 110 CONTINUE -C - LEN = 1 - WPOS = N - 2*M + 1 -C - DO 140 L = 1, M - 1 - LEN = 2*LEN - P2 = 1 - Q2 = LEN + 1 - R2 = LEN / 2 + 1 - S2 = R2 + Q2 - 1 -C - DO 130 I = 0, N/( 2*LEN ) - 1 - T1 = A(Q2) - A(Q2) = A(P2) - T1 - A(P2) = A(P2) + T1 - T1 = A(S2) - A(S2) = A(R2) - T1 - A(R2) = A(R2) + T1 -C - P1 = P2 + 1 - Q1 = P1 + LEN - R1 = Q1 - 2 - S1 = R1 + LEN -C - DO 120 J = WPOS, WPOS + LEN - 3, 2 - CF = W(J) - SF = W(J+1) - T1 = CF*A(Q1) + SF*A(S1) - T2 = -CF*A(S1) + SF*A(Q1) - A(Q1) = A(P1) - T1 - A(P1) = A(P1) + T1 - A(S1) = A(R1) - T2 - A(R1) = A(R1) + T2 - P1 = P1 + 1 - Q1 = Q1 + 1 - R1 = R1 - 1 - S1 = S1 - 1 - 120 CONTINUE -C - P2 = P2 + 2*LEN - Q2 = Q2 + 2*LEN - R2 = R2 + 2*LEN - S2 = S2 + 2*LEN - 130 CONTINUE -C - WPOS = WPOS - 2*LEN + 2 - 140 CONTINUE -C - ELSE -C -C Compute Hartley transform with transposed butterfly operators. -C - WPOS = 1 - LEN = N -C - DO 230 L = M - 1, 1, -1 - LEN = LEN / 2 - P2 = 1 - Q2 = LEN + 1 - R2 = LEN / 2 + 1 - S2 = R2 + Q2 - 1 -C - DO 220 I = 0, N/( 2*LEN ) - 1 - T1 = A(Q2) - A(Q2) = A(P2) - T1 - A(P2) = A(P2) + T1 - T1 = A(S2) - A(S2) = A(R2) - T1 - A(R2) = A(R2) + T1 -C - P1 = P2 + 1 - Q1 = P1 + LEN - R1 = Q1 - 2 - S1 = R1 + LEN -C - DO 210 J = WPOS, WPOS + LEN - 3, 2 - CF = W(J) - SF = W(J+1) - T1 = A(P1) - A(Q1) - T2 = A(R1) - A(S1) - A(P1) = A(P1) + A(Q1) - A(R1) = A(R1) + A(S1) - A(Q1) = CF*T1 + SF*T2 - A(S1) = -CF*T2 + SF*T1 - P1 = P1 + 1 - Q1 = Q1 + 1 - R1 = R1 - 1 - S1 = S1 - 1 - 210 CONTINUE -C - P2 = P2 + 2*LEN - Q2 = Q2 + 2*LEN - R2 = R2 + 2*LEN - S2 = S2 + 2*LEN - 220 CONTINUE -C - WPOS = WPOS + LEN - 2 - 230 CONTINUE -C - DO 240 J = 2, N, 2 - T1 = A(J) - A(J) = A(J-1) - T1 - A(J-1) = A(J-1) + T1 - 240 CONTINUE -C - END IF - RETURN -C *** Last line of DG01OD *** - END diff --git a/slycot/src/DK01MD.f b/slycot/src/DK01MD.f deleted file mode 100644 index 3ae29867..00000000 --- a/slycot/src/DK01MD.f +++ /dev/null @@ -1,183 +0,0 @@ - SUBROUTINE DK01MD( TYPE, N, A, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply an anti-aliasing window to a real signal. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C Indicates the type of window to be applied to the signal -C as follows: -C = 'M': Hamming window; -C = 'N': Hann window; -C = 'Q': Quadratic window. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of samples. N >= 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the signal to be -C processed. -C On exit, this array contains the windowing function. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N), -C which yields -C _ -C A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. -C -C If TYPE = 'N', then a Hann window is applied to A(1),...,A(N), -C which yields -C _ -C A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. -C -C If TYPE = 'Q', then a quadratic window is applied to A(1),..., -C A(N), which yields -C _ -C A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i), -C i = 1,2,...,(N-1)/2+1; -C _ -C A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N. -C -C REFERENCES -C -C [1] Rabiner, L.R. and Rader, C.M. -C Digital Signal Processing. -C IEEE Press, 1972. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0( N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine DK01AD by R. Dekeyser, State -C University of Gent, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Digital signal processing, Hamming window, Hann window, real -C signals, windowing. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION PT46, HALF, PT54, ONE, TWO, FOUR - PARAMETER ( PT46=0.46D0, HALF=0.5D0, PT54=0.54D0, - $ ONE = 1.0D0, TWO=2.0D0, FOUR=4.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, N -C .. Array Arguments .. - DOUBLE PRECISION A(*) -C .. Local Scalars .. - LOGICAL MTYPE, MNTYPE, NTYPE - INTEGER I, N1 - DOUBLE PRECISION BUF, FN, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, COS, DBLE -C .. Executable Statements .. -C - INFO = 0 - MTYPE = LSAME( TYPE, 'M' ) - NTYPE = LSAME( TYPE, 'N' ) - MNTYPE = MTYPE.OR.NTYPE -C -C Test the input scalar arguments. -C - IF( .NOT.MNTYPE .AND. .NOT.LSAME( TYPE, 'Q' ) ) - $ THEN - INFO = -1 - ELSE IF( N.LE.0 ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'DK01MD', -INFO ) - RETURN - END IF -C - FN = DBLE( N-1 ) - IF( MNTYPE ) TEMP = FOUR*ATAN( ONE )/FN -C - IF ( MTYPE ) THEN -C -C Hamming window. -C - DO 10 I = 1, N - A(I) = A(I)*( PT54 + PT46*COS( TEMP*DBLE( I-1 ) ) ) - 10 CONTINUE -C - ELSE IF ( NTYPE ) THEN -C -C Hann window. -C - DO 20 I = 1, N - A(I) = A(I)*HALF*( ONE + COS( TEMP*DBLE( I-1 ) ) ) - 20 CONTINUE -C - ELSE -C -C Quadratic window. -C - N1 = ( N-1 )/2 + 1 -C - DO 30 I = 1, N - BUF = DBLE( I-1 )/FN - TEMP = BUF**2 - IF ( I.LE.N1 ) THEN - A(I) = A(I)*( ONE - TWO*TEMP )*( ONE - BUF ) - ELSE - A(I) = A(I)*TWO*( ONE - BUF*TEMP ) - END IF - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of DK01MD *** - END diff --git a/slycot/src/FB01QD.f b/slycot/src/FB01QD.f deleted file mode 100644 index 4bcc391f..00000000 --- a/slycot/src/FB01QD.f +++ /dev/null @@ -1,464 +0,0 @@ - SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, - $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-varying Kalman filter. This update is given -C for the square root covariance filter, using dense matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBK CHARACTER*1 -C Indicates whether the user wishes to compute the Kalman -C filter gain matrix K as follows: -C i -C = 'K': K is computed and stored in array K; -C i -C = 'N': K is not required. -C i -C -C MULTBQ CHARACTER*1 1/2 -C Indicates how matrices B and Q are to be passed to -C i i -C the routine as follows: -C = 'P': Array Q is not used and the array B must contain -C 1/2 -C the product B Q ; -C i i -C = 'N': Arrays B and Q must contain the matrices as -C described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices S and A . N >= 0. -C i-1 i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C 1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C 1/2 -C R . P >= 0. -C i -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) -C On entry, the leading N-by-N lower triangular part of this -C array must contain S , the square root (left Cholesky -C i-1 -C factor) of the state covariance matrix at instant (i-1). -C On exit, the leading N-by-N lower triangular part of this -C array contains S , the square root (left Cholesky factor) -C i -C of the state covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain A , -C i -C the state transition matrix of the discrete system at -C instant i. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C 1/2 i -C the input weight matrix (or the product B Q if -C i i -C MULTBQ = 'P') of the discrete system at instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) -C If MULTBQ = 'N', then the leading M-by-M lower triangular -C 1/2 -C part of this array must contain Q , the square root -C i -C (left Cholesky factor) of the input (process) noise -C covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C If MULTBQ = 'P', Q is not referenced and can be supplied -C as a dummy array (i.e., set parameter LDQ = 1 and declare -C this array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,M) if MULTBQ = 'N'; -C LDQ >= 1 if MULTBQ = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C , the -C i -C output weight matrix of the discrete system at instant i. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) -C On entry, the leading P-by-P lower triangular part of this -C 1/2 -C array must contain R , the square root (left Cholesky -C i -C factor) of the output (measurement) noise covariance -C matrix at instant i. -C On exit, the leading P-by-P lower triangular part of this -C 1/2 -C array contains (RINOV ) , the square root (left Cholesky -C i -C factor) of the covariance matrix of the innovations at -C instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,P). -C -C K (output) DOUBLE PRECISION array, dimension (LDK,P) -C If JOBK = 'K', and INFO = 0, then the leading N-by-P part -C of this array contains K , the Kalman filter gain matrix -C i -C at instant i. -C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the -C leading N-by-P part of this array contains AK , a matrix -C i -C related to the Kalman filter gain matrix at instant i (see -C -1/2 -C METHOD). Specifically, AK = A P C'(RINOV') . -C i i i|i-1 i i -C -C LDK INTEGER -C The leading dimension of array K. LDK >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBK = 'K', then TOL is used to test for near -C 1/2 -C singularity of the matrix (RINOV ) . If the user sets -C i -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = P*P*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), -C where LIWORK = P if JOBK = 'K', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C 1/2 -C (in the 1-norm) of (RINOV ) . -C i -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)), if JOBK = 'N'; -C LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C 1/2 -C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, -C i 1/2 -C i.e., the condition number estimate of (RINOV ) -C i -C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , -C 1/2 i -C and (RINOV ) have been computed. -C i -C -C METHOD -C -C The routine performs one recursion of the square root covariance -C filter algorithm, summarized as follows: -C -C | 1/2 | | 1/2 | -C | R C x S 0 | | (RINOV ) 0 0 | -C | i i i-1 | | i | -C | 1/2 | T = | | -C | 0 A x S B x Q | | AK S 0 | -C | i i-1 i i | | i i | -C -C (Pre-array) (Post-array) -C -C where T is an orthogonal transformation triangularizing the -C pre-array. -C -C The state covariance matrix P is factorized as -C i|i-1 -C P = S S' -C i|i-1 i i -C -C and one combined time and measurement update for the state X -C i|i-1 -C is given by -C -C X = A X + K (Y - C X ), -C i+1|i i i|i-1 i i i i|i-1 -C -C -1/2 -C where K = AK (RINOV ) is the Kalman filter gain matrix and Y -C i i i i -C is the observed output of the system. -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires -C -C 3 2 2 2 -C (7/6)N + N x (5/2 x P + M) + N x (1/2 x M + P ) -C -C operations and is backward stable (see [2]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01ED by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003. -C -C KEYWORDS -C -C Kalman filtering, optimal filtering, orthogonal transformation, -C recursive estimation, square-root covariance filtering, -C square-root filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBK, MULTBQ - INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, - $ M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL LJOBK, LMULTB - INTEGER I12, ITAU, JWORK, N1, PN, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGELQF, DLACPY, DTRMM, MB02OD, MB04LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - PN = P + N - N1 = MAX( 1, N ) - INFO = 0 - LJOBK = LSAME( JOBK, 'K' ) - LMULTB = LSAME( MULTBQ, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDS.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -11 - ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDK.LT.N1 ) THEN - INFO = -19 - ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + 2*P, - $ N*(N + M + 2), 3*P ) ) .OR. - $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + 2*P, - $ N*(N + M + 2) ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( LJOBK ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,2), (2,2), and (2,3) will be -C constructed as shown below. -C -C Storing A x S and C x S in the (1,1) and (2,1) blocks of DWORK, -C respectively. -C Workspace: need (N+P)*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, PN ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), PN ) - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', PN, N, - $ ONE, S, LDS, DWORK, PN ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix C x S. -C Workspace: need (N+P)*N + 2*P. -C - ITAU = PN*N + 1 - JWORK = ITAU + P -C - CALL MB04LD( 'Full', P, N, N, R, LDR, DWORK(N+1), PN, DWORK, PN, - $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) - WRKOPT = PN*N + 2*P -C -C Now, the workspace for C x S is no longer needed. -C Adjust the leading dimension of DWORK, to save space for the -C following computations. -C - CALL DLACPY( 'Full', N, N, DWORK, PN, DWORK, N ) - I12 = N*N + 1 -C -C Storing B x Q in the (1,2) block of DWORK. -C Workspace: need N*(N+M). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I12), N ) - IF ( .NOT.LMULTB ) - $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, - $ ONE, Q, LDQ, DWORK(I12), N ) - WRKOPT = MAX( WRKOPT, N*( N + M ) ) -C -C Step 2: LQ triangularization of the matrix [ A x S B x Q ], where -C A x S was modified at Step 1. -C Workspace: need N*(N+M+2); prefer N*(N+M+1)+N*NB. -C - ITAU = N*( N + M ) + 1 - JWORK = ITAU + N -C - CALL DGELQF( N, N+M, DWORK, N, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output S and K (if needed) and set the optimal workspace -C dimension (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) -C - IF ( LJOBK ) THEN -C -C Compute K. -C Workspace: need 3*P. -C - CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', - $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, - $ IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*P ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01QD *** - END diff --git a/slycot/src/FB01RD.f b/slycot/src/FB01RD.f deleted file mode 100644 index 721cb2ae..00000000 --- a/slycot/src/FB01RD.f +++ /dev/null @@ -1,535 +0,0 @@ - SUBROUTINE FB01RD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, - $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-invariant Kalman filter. This update is -C given for the square root covariance filter, using the condensed -C observer Hessenberg form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBK CHARACTER*1 -C Indicates whether the user wishes to compute the Kalman -C filter gain matrix K as follows: -C i -C = 'K': K is computed and stored in array K; -C i -C = 'N': K is not required. -C i -C -C MULTBQ CHARACTER*1 1/2 -C Indicates how matrices B and Q are to be passed to -C i i -C the routine as follows: -C = 'P': Array Q is not used and the array B must contain -C 1/2 -C the product B Q ; -C i i -C = 'N': Arrays B and Q must contain the matrices as -C described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices S and A. N >= 0. -C i-1 -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C 1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C 1/2 -C R . P >= 0. -C i -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) -C On entry, the leading N-by-N lower triangular part of this -C array must contain S , the square root (left Cholesky -C i-1 -C factor) of the state covariance matrix at instant (i-1). -C On exit, the leading N-by-N lower triangular part of this -C array contains S , the square root (left Cholesky factor) -C i -C of the state covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain A, -C the state transition matrix of the discrete system in -C lower observer Hessenberg form (e.g., as produced by -C SLICOT Library Routine TB01ND). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C 1/2 i -C the input weight matrix (or the product B Q if -C i i -C MULTBQ = 'P') of the discrete system at instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) -C If MULTBQ = 'N', then the leading M-by-M lower triangular -C 1/2 -C part of this array must contain Q , the square root -C i -C (left Cholesky factor) of the input (process) noise -C covariance matrix at instant i. -C The strict upper triangular part of this array is not -C referenced. -C Otherwise, Q is not referenced and can be supplied as a -C dummy array (i.e., set parameter LDQ = 1 and declare this -C array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,M) if MULTBQ = 'N'; -C LDQ >= 1 if MULTBQ = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C, -C the output weight matrix of the discrete system in lower -C observer Hessenberg form (e.g., as produced by SLICOT -C Library routine TB01ND). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) -C On entry, the leading P-by-P lower triangular part of this -C 1/2 -C array must contain R , the square root (left Cholesky -C i -C factor) of the output (measurement) noise covariance -C matrix at instant i. -C On exit, the leading P-by-P lower triangular part of this -C 1/2 -C array contains (RINOV ) , the square root (left Cholesky -C i -C factor) of the covariance matrix of the innovations at -C instant i. -C The strict upper triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,P). -C -C K (output) DOUBLE PRECISION array, dimension (LDK,P) -C If JOBK = 'K', and INFO = 0, then the leading N-by-P part -C of this array contains K , the Kalman filter gain matrix -C i -C at instant i. -C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the -C leading N-by-P part of this array contains AK , a matrix -C i -C related to the Kalman filter gain matrix at instant i (see -C -1/2 -C METHOD). Specifically, AK = A P C'(RINOV') . -C i i|i-1 i -C -C LDK INTEGER -C The leading dimension of array K. LDK >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBK = 'K', then TOL is used to test for near -C 1/2 -C singularity of the matrix (RINOV ) . If the user sets -C i -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = P*P*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C where LIWORK = P if JOBK = 'K', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C 1/2 -C (in the 1-norm) of (RINOV ) . -C i -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2)), -C if JOBK = 'N'; -C LDWORK >= MAX(2,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2),3*P), -C if JOBK = 'K'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C 1/2 -C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, -C i 1/2 -C i.e., the condition number estimate of (RINOV ) -C i -C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , -C 1/2 i -C and (RINOV ) have been computed. -C i -C -C METHOD -C -C The routine performs one recursion of the square root covariance -C filter algorithm, summarized as follows: -C -C | 1/2 | | 1/2 | -C | R 0 C x S | | (RINOV ) 0 0 | -C | i i-1 | | i | -C | 1/2 | T = | | -C | 0 B x Q A x S | | AK S 0 | -C | i i i-1 | | i i | -C -C (Pre-array) (Post-array) -C -C where T is unitary and (A,C) is in lower observer Hessenberg form. -C -C An example of the pre-array is given below (where N = 6, P = 2 -C and M = 3): -C -C |x | | x | -C |x x | | x x | -C |____|______|____________| -C | | x x x| x x x | -C | | x x x| x x x x | -C | | x x x| x x x x x | -C | | x x x| x x x x x x| -C | | x x x| x x x x x x| -C | | x x x| x x x x x x| -C -C The corresponding state covariance matrix P is then -C i|i-1 -C factorized as -C -C P = S S' -C i|i-1 i i -C -C and one combined time and measurement update for the state X -C i|i-1 -C is given by -C -C X = A X + K (Y - C X ) -C i+1|i i|i-1 i i i|i-1 -C -C -1/2 -C where K = AK (RINOV ) is the Kalman filter gain matrix and Y -C i i i i -C is the observed output of the system. -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Van Dooren, P. and Verhaegen, M.H.G. -C Condensed Forms for Efficient Time-Invariant Kalman Filtering. -C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. -C -C [3] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires -C -C 3 2 2 3 -C 1/6 x N + N x (3/2 x P + M) + 2 x N x P + 2/3 x P -C -C operations and is backward stable (see [3]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01FD by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, February 14, 2004. -C -C KEYWORDS -C -C Kalman filtering, observer Hessenberg form, optimal filtering, -C orthogonal transformation, recursive estimation, square-root -C covariance filtering, square-root filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBK, MULTBQ - INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, - $ M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL LJOBK, LMULTB - INTEGER I, II, ITAU, JWORK, N1, PL, PN, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, MB04JD, - $ MB04LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - PN = P + N - N1 = MAX( 1, N ) - INFO = 0 - LJOBK = LSAME( JOBK, 'K' ) - LMULTB = LSAME( MULTBQ, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDS.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -11 - ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDK.LT.N1 ) THEN - INFO = -19 - ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + N, PN*N + 2*P, - $ N*(N + M + 2), 3*P ) ) .OR. - $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + N, PN*N + 2*P, - $ N*(N + M + 2) ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( LJOBK ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,3), (2,2), and (2,3) will be -C constructed as shown below. -C -C Storing C x S and A x S in the (1,1) and (2,1) blocks of DWORK, -C respectively. The lower trapezoidal structure of [ C' A' ]' is -C fully exploited. Specifically, if P <= N, the following partition -C is used: -C -C [ C1 0 ] [ S1 0 ] -C [ A1 A3 ] [ S2 S3 ], -C [ A2 A4 ] -C -C where C1, S1, and A2 are P-by-P matrices, A1 and S2 are -C (N-P)-by-P, A3 and S3 are (N-P)-by-(N-P), A4 is P-by-(N-P), and -C C1, S1, A3, and S3 are lower triangular. The left hand side -C matrix above is stored in the workspace. If P > N, the partition -C is: -C -C [ C1 ] -C [ C2 ] [ S ], -C [ A ] -C -C where C1 and C2 are N-by-N and (P-N)-by-N matrices, respectively, -C and C1 and S are lower triangular. -C -C Workspace: need (P+N)*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DLACPY( 'Lower', P, MIN( N, P ), C, LDC, DWORK, PN ) - CALL DLACPY( 'Full', N, MIN( N, P ), A, LDA, DWORK(P+1), PN ) - IF ( N.GT.P ) - $ CALL DLACPY( 'Lower', N, N-P, A(1,P+1), LDA, DWORK(P*PN+P+1), - $ PN ) -C -C [ C1 0 ] -C Compute [ ] x S or C1 x S as a product of lower triangular -C [ A1 A3 ] -C matrices. -C Workspace: need (P+N+1)*N. -C - II = 1 - PL = N*PN + 1 - WRKOPT = PL + N - 1 -C - DO 10 I = 1, N - CALL DCOPY( N-I+1, S(I,I), 1, DWORK(PL), 1 ) - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', N-I+1, - $ DWORK(II), PN, DWORK(PL), 1 ) - CALL DCOPY( N-I+1, DWORK(PL), 1, DWORK(II), 1 ) - II = II + PN + 1 - 10 CONTINUE -C -C Compute [ A2 A4 ] x S. -C - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', P, N, - $ ONE, S, LDS, DWORK(N+1), PN ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix C x S (hence C1 x S1, if P <= N). -C Workspace: need (N+P)*N + 2*P. -C - ITAU = PL - JWORK = ITAU + P -C - CALL MB04LD( 'Lower', P, N, N, R, LDR, DWORK, PN, DWORK(P+1), PN, - $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) - WRKOPT = MAX( WRKOPT, PN*N + 2*P ) -C -C Now, the workspace for C x S is no longer needed. -C Adjust the leading dimension of DWORK, to save space for the -C following computations, and make room for B x Q. -C - CALL DLACPY( 'Full', N, N, DWORK(P+1), PN, DWORK, N ) -C - DO 20 I = N*( N - 1 ) + 1, 1, -N - CALL DCOPY( N, DWORK(I), 1, DWORK(I+N*M), 1 ) - 20 CONTINUE -C -C Storing B x Q in the (1,1) block of DWORK. -C Workspace: need N*(M+N). -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - IF ( .NOT.LMULTB ) - $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, - $ ONE, Q, LDQ, DWORK, N ) -C -C Step 2: LQ triangularization of the matrix [ B x Q A x S ], where -C A x S was modified at Step 1. -C Workspace: need N*(N+M+2); -C prefer N*(N+M+1)+(P+1)*NB, where NB is the optimal -C block size for DGELQF (called in MB04JD). -C - ITAU = N*( M + N ) + 1 - JWORK = ITAU + N -C - CALL MB04JD( N, M+N, MAX( N-P-1, 0 ), 0, DWORK, N, DWORK, N, - $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output S and K (if needed) and set the optimal workspace -C dimension (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) -C - IF ( LJOBK ) THEN -C -C Compute K. -C Workspace: need 3*P. -C - CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', - $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, - $ IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*P ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01RD *** - END diff --git a/slycot/src/FB01SD.f b/slycot/src/FB01SD.f deleted file mode 100644 index 41783fc2..00000000 --- a/slycot/src/FB01SD.f +++ /dev/null @@ -1,597 +0,0 @@ - SUBROUTINE FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV, LDSINV, - $ AINV, LDAINV, B, LDB, RINV, LDRINV, C, LDC, - $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-varying Kalman filter. This update is given -C for the square root information filter, using dense matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX CHARACTER*1 -C Indicates whether X is to be computed as follows: -C i+1 -C = 'X': X is computed and stored in array X; -C i+1 -C = 'N': X is not required. -C i+1 -C -C MULTAB CHARACTER*1 -1 -C Indicates how matrices A and B are to be passed to -C i i -C the routine as follows: -1 -C = 'P': Array AINV must contain the matrix A and the -C -1 i -C array B must contain the product A B ; -C i i -C = 'N': Arrays AINV and B must contain the matrices -C as described below. -C -C MULTRC CHARACTER*1 -1/2 -C Indicates how matrices R and C are to be passed to -C i+1 i+1 -C the routine as follows: -C = 'P': Array RINV is not used and the array C must -C -1/2 -C contain the product R C ; -C i+1 i+1 -C = 'N': Arrays RINV and C must contain the matrices -C as described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C -1 -1 -C matrices S and A . N >= 0. -C i i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C -1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C -1/2 -C R . P >= 0. -C i+1 -C -C SINV (input/output) DOUBLE PRECISION array, dimension -C (LDSINV,N) -C On entry, the leading N-by-N upper triangular part of this -C -1 -C array must contain S , the inverse of the square root -C i -C (right Cholesky factor) of the state covariance matrix -C P (hence the information square root) at instant i. -C i|i -C On exit, the leading N-by-N upper triangular part of this -C -1 -C array contains S , the inverse of the square root (right -C i+1 -C Cholesky factor) of the state covariance matrix P -C i+1|i+1 -C (hence the information square root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C -C LDSINV INTEGER -C The leading dimension of array SINV. LDSINV >= MAX(1,N). -C -C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) -C -1 -C The leading N-by-N part of this array must contain A , -C i -C the inverse of the state transition matrix of the discrete -C system at instant i. -C -C LDAINV INTEGER -C The leading dimension of array AINV. LDAINV >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C -1 i -C the input weight matrix (or the product A B if -C i i -C MULTAB = 'P') of the discrete system at instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) -C If MULTRC = 'N', then the leading P-by-P upper triangular -C -1/2 -C part of this array must contain R , the inverse of the -C i+1 -C covariance square root (right Cholesky factor) of the -C output (measurement) noise (hence the information square -C root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C Otherwise, RINV is not referenced and can be supplied as a -C dummy array (i.e., set parameter LDRINV = 1 and declare -C this array to be RINV(1,1) in the calling program). -C -C LDRINV INTEGER -C The leading dimension of array RINV. -C LDRINV >= MAX(1,P) if MULTRC = 'N'; -C LDRINV >= 1 if MULTRC = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C , -C -1/2 i+1 -C the output weight matrix (or the product R C if -C i+1 i+1 -C MULTRC = 'P') of the discrete system at instant i+1. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C QINV (input/output) DOUBLE PRECISION array, dimension -C (LDQINV,M) -C On entry, the leading M-by-M upper triangular part of this -C -1/2 -C array must contain Q , the inverse of the covariance -C i -C square root (right Cholesky factor) of the input (process) -C noise (hence the information square root) at instant i. -C On exit, the leading M-by-M upper triangular part of this -C -1/2 -C array contains (QINOV ) , the inverse of the covariance -C i -C square root (right Cholesky factor) of the process noise -C innovation (hence the information square root) at -C instant i. -C The strict lower triangular part of this array is not -C referenced. -C -C LDQINV INTEGER -C The leading dimension of array QINV. LDQINV >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain X , the estimated -C i -C filtered state at instant i. -C On exit, if JOBX = 'X', and INFO = 0, then this array -C contains X , the estimated filtered state at -C i+1 -C instant i+1. -C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then -C -1 -C this array contains S X . -C i+1 i+1 -C -C RINVY (input) DOUBLE PRECISION array, dimension (P) -C -1/2 -C This array must contain R Y , the product of the -C i+1 i+1 -C -1/2 -C upper triangular matrix R and the measured output -C i+1 -C vector Y at instant i+1. -C i+1 -C -C Z (input) DOUBLE PRECISION array, dimension (M) -C This array must contain Z , the mean value of the state -C i -C process noise at instant i. -C -C E (output) DOUBLE PRECISION array, dimension (P) -C This array contains E , the estimated error at instant -C i+1 -C i+1. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBX = 'X', then TOL is used to test for near -C -1 -C singularity of the matrix S . If the user sets -C i+1 -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = N*N*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C where LIWORK = N if JOBX = 'X', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C -1 -C (in the 1-norm) of S . -C i+1 -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N), -C if JOBX = 'N'; -C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N,3*N), -C if JOBX = 'X'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -1 -C = 1: if JOBX = 'X' and the matrix S is singular, -C i+1 -1 -C i.e., the condition number estimate of S (in the -C i+1 -C -1 -1/2 -C 1-norm) exceeds 1/TOL. The matrices S , Q -C i+1 i -C and E have been computed. -C -C METHOD -C -C The routine performs one recursion of the square root information -C filter algorithm, summarized as follows: -C -C | -1/2 -1/2 | | -1/2 | -C | Q 0 Q Z | | (QINOV ) * * | -C | i i i | | i | -C | | | | -C | -1 -1 -1 -1 -1 | | -1 -1 | -C T | S A B S A S X | = | 0 S S X | -C | i i i i i i i | | i+1 i+1 i+1| -C | | | | -C | -1/2 -1/2 | | | -C | 0 R C R Y | | 0 0 E | -C | i+1 i+1 i+1 i+1| | i+1 | -C -C (Pre-array) (Post-array) -C -C where T is an orthogonal transformation triangularizing the -C -1/2 -C pre-array, (QINOV ) is the inverse of the covariance square -C i -C root (right Cholesky factor) of the process noise innovation -C (hence the information square root) at instant i, and E is the -C i+1 -C estimated error at instant i+1. -C -C The inverse of the corresponding state covariance matrix P -C i+1|i+1 -C (hence the information matrix I) is then factorized as -C -C -1 -1 -1 -C I = P = (S )' S -C i+1|i+1 i+1|i+1 i+1 i+1 -C -C and one combined time and measurement update for the state is -C given by X . -C i+1 -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 3 2 2 2 -C (7/6)N + N x (7/2 x M + P) + N x (1/2 x P + M ) -C -C operations and is backward stable (see [2]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01GD by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, February 14, 2004. -C -C KEYWORDS -C -C Kalman filtering, optimal filtering, orthogonal transformation, -C recursive estimation, square-root filtering, square-root -C information filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBX, MULTAB, MULTRC - INTEGER INFO, LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV, - $ LDWORK, M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION AINV(LDAINV,*), B(LDB,*), C(LDC,*), DWORK(*), - $ E(*), QINV(LDQINV,*), RINV(LDRINV,*), RINVY(*), - $ SINV(LDSINV,*), X(*), Z(*) -C .. Local Scalars .. - LOGICAL LJOBX, LMULTA, LMULTR - INTEGER I, I12, I13, I21, I23, IJ, ITAU, JWORK, LDW, M1, - $ N1, NP, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DORMQR, - $ DTRMM, DTRMV, MB02OD, MB04KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - NP = N + P - N1 = MAX( 1, N ) - M1 = MAX( 1, M ) - INFO = 0 - LJOBX = LSAME( JOBX, 'X' ) - LMULTA = LSAME( MULTAB, 'P' ) - LMULTR = LSAME( MULTRC, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTA .AND. .NOT.LSAME( MULTAB, 'N' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDSINV.LT.N1 ) THEN - INFO = -8 - ELSE IF( LDAINV.LT.N1 ) THEN - INFO = -10 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -12 - ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDQINV.LT.M1 ) THEN - INFO = -18 - ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(N + 2*M) + 3*M, - $ NP*(N + 1) + 2*N, 3*N ) ) - $ .OR. - $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(N + 2*M) + 3*M, - $ NP*(N + 1) + 2*N ) ) ) THEN - INFO = -26 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, P ).EQ.0 ) THEN - IF ( LJOBX ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,3), (2,1)-(2,3), (3,2), and -C (3,3) will be constructed when needed as shown below. -C -C Storing SINV x AINV and SINV x AINV x B in the (1,1) and (1,2) -C blocks of DWORK, respectively. -C The variables called Ixy define the starting positions where the -C (x,y) blocks of the pre-array are initially stored in DWORK. -C Workspace: need N*(N+M). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - LDW = N1 - I21 = N*N + 1 -C - CALL DLACPY( 'Full', N, N, AINV, LDAINV, DWORK, LDW ) - IF ( LMULTA ) THEN - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I21), LDW ) - ELSE - CALL DGEMM( 'No transpose', 'No transpose', N, M, N, ONE, - $ DWORK, LDW, B, LDB, ZERO, DWORK(I21), LDW ) - END IF - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, N+M, - $ ONE, SINV, LDSINV, DWORK, LDW ) -C -C Storing the process noise mean value in (1,3) block of DWORK. -C Workspace: need N*(N+M) + M. -C - I13 = N*( N + M ) + 1 -C - CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, - $ DWORK(I13), 1 ) -C -C Computing SINV x X in X. -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, - $ X, 1 ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix SINV x AINV x B. -C Workspace: need N*(N+2*M) + 3*M. -C - I12 = I13 + M - ITAU = I12 + M*N - JWORK = ITAU + M -C - CALL MB04KD( 'Full', M, N, N, QINV, LDQINV, DWORK(I21), LDW, - $ DWORK, LDW, DWORK(I12), M1, DWORK(ITAU), - $ DWORK(JWORK) ) - WRKOPT = MAX( 1, N*( N + 2*M ) + 3*M ) -C - IF ( N.EQ.0 ) THEN - CALL DCOPY( P, RINVY, 1, E, 1 ) - IF ( LJOBX ) - $ DWORK(2) = ONE - DWORK(1) = WRKOPT - RETURN - END IF -C -C Apply the transformations to the last column of the pre-array. -C (Only the updated (2,3) block is now needed.) -C - IJ = I21 -C - DO 10 I = 1, M - CALL DAXPY( N, -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + - $ DDOT( N, DWORK(IJ), 1, X, 1 ) ), - $ DWORK(IJ), 1, X, 1 ) - IJ = IJ + N - 10 CONTINUE -C -C Now, the workspace for SINV x AINV x B, as well as for the updated -C (1,2) block of the pre-array, are no longer needed. -C Move the computed (2,3) block of the pre-array in the (1,2) block -C position of DWORK, to save space for the following computations. -C Then, adjust the implicitly defined leading dimension of DWORK, -C to make space for storing the (3,2) and (3,3) blocks of the -C pre-array. -C Workspace: need (N+P)*(N+1). -C - CALL DCOPY( N, X, 1, DWORK(I21), 1 ) - LDW = MAX( 1, NP ) -C - DO 30 I = N + 1, 1, -1 - DO 20 IJ = N, 1, -1 - DWORK(NP*(I-1)+IJ) = DWORK(N*(I-1)+IJ) - 20 CONTINUE - 30 CONTINUE -C -C Copy of RINV x C in the (2,1) block of DWORK. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), LDW ) - IF ( .NOT.LMULTR ) - $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, - $ ONE, RINV, LDRINV, DWORK(N+1), LDW ) -C -C Copy the inclusion measurement in the (2,2) block of DWORK. -C - I21 = NP*N + 1 - I23 = I21 + N - CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) - WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) -C -C Step 2: QR factorization of the first block column of the matrix -C -C [ SINV x AINV SINV x X ] -C [ RINV x C RINV x Y ], -C -C where the first block row was modified at Step 1. -C Workspace: need (N+P)*(N+1) + 2*N; -C prefer (N+P)*(N+1) + N + N*NB. -C - ITAU = I21 + NP - JWORK = ITAU + N -C - CALL DGEQRF( NP, N, DWORK, LDW, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Apply the Householder transformations to the last column. -C Workspace: need (N+P)*(N+1) + 1; prefer (N+P)*(N+1) + NB. -C - CALL DORMQR( 'Left', 'Transpose', NP, 1, N, DWORK, LDW, - $ DWORK(ITAU), DWORK(I21), LDW, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output SINV, X, and E and set the optimal workspace dimension -C (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) - CALL DCOPY( N, DWORK(I21), 1, X, 1 ) - CALL DCOPY( P, DWORK(I23), 1, E, 1 ) -C - IF ( LJOBX ) THEN -C -C Compute X. -C Workspace: need 3*N. -C - CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', - $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, - $ TOL, IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*N ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01SD *** - END diff --git a/slycot/src/FB01TD.f b/slycot/src/FB01TD.f deleted file mode 100644 index f248de0d..00000000 --- a/slycot/src/FB01TD.f +++ /dev/null @@ -1,641 +0,0 @@ - SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV, - $ LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC, - $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a combined measurement and time update of one -C iteration of the time-invariant Kalman filter. This update is -C given for the square root information filter, using the condensed -C controller Hessenberg form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX CHARACTER*1 -C Indicates whether X is to be computed as follows: -C i+1 -C = 'X': X is computed and stored in array X; -C i+1 -C = 'N': X is not required. -C i+1 -C -C MULTRC CHARACTER*1 -1/2 -C Indicates how matrices R and C are to be passed to -C i+1 i+1 -C the routine as follows: -C = 'P': Array RINV is not used and the array C must -C -1/2 -C contain the product R C ; -C i+1 i+1 -C = 'N': Arrays RINV and C must contain the matrices -C as described below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C -1 -1 -C matrices S and A . N >= 0. -C i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C -1/2 -C Q . M >= 0. -C i -C -C P (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C -1/2 -C R . P >= 0. -C i+1 -C -C SINV (input/output) DOUBLE PRECISION array, dimension -C (LDSINV,N) -C On entry, the leading N-by-N upper triangular part of this -C -1 -C array must contain S , the inverse of the square root -C i -C (right Cholesky factor) of the state covariance matrix -C P (hence the information square root) at instant i. -C i|i -C On exit, the leading N-by-N upper triangular part of this -C -1 -C array contains S , the inverse of the square root (right -C i+1 -C Cholesky factor) of the state covariance matrix P -C i+1|i+1 -C (hence the information square root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C -C LDSINV INTEGER -C The leading dimension of array SINV. LDSINV >= MAX(1,N). -C -C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) -C -1 -C The leading N-by-N part of this array must contain A , -C the inverse of the state transition matrix of the discrete -C system in controller Hessenberg form (e.g., as produced by -C SLICOT Library Routine TB01MD). -C -C LDAINV INTEGER -C The leading dimension of array AINV. LDAINV >= MAX(1,N). -C -C AINVB (input) DOUBLE PRECISION array, dimension (LDAINB,M) -C -1 -C The leading N-by-M part of this array must contain A B, -C -1 -C the product of A and the input weight matrix B of the -C discrete system, in upper controller Hessenberg form -C (e.g., as produced by SLICOT Library Routine TB01MD). -C -C LDAINB INTEGER -C The leading dimension of array AINVB. LDAINB >= MAX(1,N). -C -C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) -C If MULTRC = 'N', then the leading P-by-P upper triangular -C -1/2 -C part of this array must contain R , the inverse of the -C i+1 -C covariance square root (right Cholesky factor) of the -C output (measurement) noise (hence the information square -C root) at instant i+1. -C The strict lower triangular part of this array is not -C referenced. -C Otherwise, RINV is not referenced and can be supplied as a -C dummy array (i.e., set parameter LDRINV = 1 and declare -C this array to be RINV(1,1) in the calling program). -C -C LDRINV INTEGER -C The leading dimension of array RINV. -C LDRINV >= MAX(1,P) if MULTRC = 'N'; -C LDRINV >= 1 if MULTRC = 'P'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain C , -C -1/2 i+1 -C the output weight matrix (or the product R C if -C i+1 i+1 -C MULTRC = 'P') of the discrete system at instant i+1. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C QINV (input/output) DOUBLE PRECISION array, dimension -C (LDQINV,M) -C On entry, the leading M-by-M upper triangular part of this -C -1/2 -C array must contain Q , the inverse of the covariance -C i -C square root (right Cholesky factor) of the input (process) -C noise (hence the information square root) at instant i. -C On exit, the leading M-by-M upper triangular part of this -C -1/2 -C array contains (QINOV ) , the inverse of the covariance -C i -C square root (right Cholesky factor) of the process noise -C innovation (hence the information square root) at -C instant i. -C The strict lower triangular part of this array is not -C referenced. -C -C LDQINV INTEGER -C The leading dimension of array QINV. LDQINV >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain X , the estimated -C i -C filtered state at instant i. -C On exit, if JOBX = 'X', and INFO = 0, then this array -C contains X , the estimated filtered state at -C i+1 -C instant i+1. -C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then -C -1 -C this array contains S X . -C i+1 i+1 -C -C RINVY (input) DOUBLE PRECISION array, dimension (P) -C -1/2 -C This array must contain R Y , the product of the -C i+1 i+1 -C -1/2 -C upper triangular matrix R and the measured output -C i+1 -C vector Y at instant i+1. -C i+1 -C -C Z (input) DOUBLE PRECISION array, dimension (M) -C This array must contain Z , the mean value of the state -C i -C process noise at instant i. -C -C E (output) DOUBLE PRECISION array, dimension (P) -C This array contains E , the estimated error at instant -C i+1 -C i+1. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If JOBX = 'X', then TOL is used to test for near -C -1 -C singularity of the matrix S . If the user sets -C i+1 -C TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then an implicitly computed, default -C tolerance, defined by TOLDEF = N*N*EPS, is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C Otherwise, TOL is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C where LIWORK = N if JOBX = 'X', -C and LIWORK = 1 otherwise. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns -C an estimate of the reciprocal of the condition number -C -1 -C (in the 1-norm) of S . -C i+1 -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)), -C if JOBX = 'N'; -C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1), -C 3*N), if JOBX = 'X'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -1 -C = 1: if JOBX = 'X' and the matrix S is singular, -C i+1 -1 -C i.e., the condition number estimate of S (in the -C i+1 -C -1 -1/2 -C 1-norm) exceeds 1/TOL. The matrices S , Q -C i+1 i -C and E have been computed. -C -C METHOD -C -C The routine performs one recursion of the square root information -C filter algorithm, summarized as follows: -C -C | -1/2 -1/2 | | -1/2 | -C | Q 0 Q Z | | (QINOV ) * * | -C | i i i | | i | -C | | | | -C | -1/2 -1/2 | | -1 -1 | -C T | 0 R C R Y | = | 0 S S X | -C | i+1 i+1 i+1 i+1| | i+1 i+1 i+1| -C | | | | -C | -1 -1 -1 -1 -1 | | | -C | S A B S A S X | | 0 0 E | -C | i i i i | | i+1 | -C -C (Pre-array) (Post-array) -C -C where T is an orthogonal transformation triangularizing the -C -1/2 -C pre-array, (QINOV ) is the inverse of the covariance square -C i -C root (right Cholesky factor) of the process noise innovation -C -1 -1 -C (hence the information square root) at instant i and (A ,A B) is -C in upper controller Hessenberg form. -C -C An example of the pre-array is given below (where N = 6, M = 2, -C and P = 3): -C -C |x x | | x| -C | x | | x| -C _______________________ -C | | x x x x x x | x| -C | | x x x x x x | x| -C | | x x x x x x | x| -C _______________________ -C |x x | x x x x x x | x| -C | x | x x x x x x | x| -C | | x x x x x x | x| -C | | x x x x x | x| -C | | x x x x | x| -C | | x x x | x| -C -C The inverse of the corresponding state covariance matrix P -C i+1|i+1 -C (hence the information matrix I) is then factorized as -C -C -1 -1 -1 -C I = P = (S )' S -C i+1|i+1 i+1|i+1 i+1 i+1 -C -C and one combined time and measurement update for the state is -C given by X . -C i+1 -C -C The triangularization is done entirely via Householder -C transformations exploiting the zero pattern of the pre-array. -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering. -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Van Dooren, P. and Verhaegen, M.H.G. -C Condensed Forms for Efficient Time-Invariant Kalman Filtering. -C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. -C -C [3] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. -C -C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. -C Algorithm 675: FORTRAN Subroutines for Computing the Square -C Root Covariance Filter and Square Root Information Filter in -C Dense or Hessenberg Forms. -C ACM Trans. Math. Software, 15, pp. 243-256, 1989. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 3 2 2 3 -C (1/6)N + N x (3/2 x M + P) + 2 x N x M + 2/3 x M -C -C operations and is backward stable (see [3]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01HD by M. Vanbegin, -C P. Van Dooren, and M.H.G. Verhaegen. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, February 14, 2004. -C -C KEYWORDS -C -C Controller Hessenberg form, Kalman filtering, optimal filtering, -C orthogonal transformation, recursive estimation, square-root -C filtering, square-root information filtering. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBX, MULTRC - INTEGER INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV, - $ LDSINV, LDWORK, M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*), - $ DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*), - $ RINVY(*), SINV(LDSINV,*), X(*), Z(*) -C .. Local Scalars .. - LOGICAL LJOBX, LMULTR - INTEGER I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK, - $ LDW, M1, MP1, N1, NM, NP, WRKOPT - DOUBLE PRECISION RCOND -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, - $ MB04ID, MB04KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - NP = N + P - NM = N + M - N1 = MAX( 1, N ) - M1 = MAX( 1, M ) - MP1 = M + 1 - INFO = 0 - LJOBX = LSAME( JOBX, 'X' ) - LMULTR = LSAME( MULTRC, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDSINV.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDAINV.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDAINB.LT.N1 ) THEN - INFO = -11 - ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDQINV.LT.M1 ) THEN - INFO = -17 - ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M, - $ NP*(N + 1) + N + - $ MAX( N - 1, MP1 ), 3*N ) ) - $ .OR. - $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M, - $ NP*(N + 1) + N + - $ MAX( N - 1, MP1 ) ) ) ) THEN - INFO = -25 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, P ).EQ.0 ) THEN - IF ( LJOBX ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - ELSE - DWORK(1) = ONE - END IF - RETURN - END IF -C -C Construction of the needed part of the pre-array in DWORK. -C To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and -C (2,3) will be constructed when needed as shown below. -C -C Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2) -C blocks of DWORK, respectively. The upper trapezoidal structure of -C [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the -C following partition is used: -C -C [ S1 S2 ] [ B1 A1 A3 ] -C [ 0 S3 ] [ 0 A2 A4 ], -C -C where B1, A3, and S1 are M-by-M matrices, A1 and S2 are -C M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and -C B1, S1, A2, and S3 are upper triangular. The right hand side -C matrix above is stored in the workspace. If M > N, the partition -C is [ SINV ] [ B1 B2 A ], where B1 is N-by-N, B2 is N-by-(M-N), -C and B1 and SINV are upper triangular. -C The variables called Ixy define the starting positions where the -C (x,y) blocks of the pre-array are initially stored in DWORK. -C Workspace: need N*(M+N). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - LDW = N1 - I32 = N*M + 1 -C - CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW ) - CALL DLACPY( 'Full', MIN( M, N ), N, AINV, LDAINV, DWORK(I32), - $ LDW ) - IF ( N.GT.M ) - $ CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV, - $ DWORK(I32+M), LDW ) -C -C [ B1 A1 ] -C Compute SINV x [ 0 A2 ] or SINV x B1 as a product of upper -C triangular matrices. -C Workspace: need N*(M+N+1). -C - II = 1 - I13 = N*NM + 1 - WRKOPT = MAX( 1, N*NM + N ) -C - DO 10 I = 1, N - CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV, - $ LDSINV, DWORK(I13), 1 ) - CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 ) - II = II + N - 10 CONTINUE -C -C [ A3 ] -C Compute SINV x [ A4 ] or SINV x [ B2 A ]. -C - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M, - $ ONE, SINV, LDSINV, DWORK(II), LDW ) -C -C Storing the process noise mean value in (1,3) block of DWORK. -C Workspace: need N*(M+N) + M. -C - CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, - $ DWORK(I13), 1 ) -C -C Computing SINV x X in X. -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, - $ X, 1 ) -C -C Triangularization (2 steps). -C -C Step 1: annihilate the matrix SINV x AINVB. -C Workspace: need N*(N+2*M) + 3*M. -C - I12 = I13 + M - ITAU = I12 + M*N - JWORK = ITAU + M -C - CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW, - $ DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU), - $ DWORK(JWORK) ) - WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M ) -C - IF ( N.EQ.0 ) THEN - CALL DCOPY( P, RINVY, 1, E, 1 ) - IF ( LJOBX ) - $ DWORK(2) = ONE - DWORK(1) = WRKOPT - RETURN - END IF -C -C Apply the transformations to the last column of the pre-array. -C (Only the updated (3,3) block is now needed.) -C - IJ = 1 -C - DO 20 I = 1, M - CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + - $ DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ), - $ DWORK(IJ), 1, X, 1 ) - IJ = IJ + N - 20 CONTINUE -C -C Now, the workspace for SINV x AINVB, as well as for the updated -C (1,2) block of the pre-array, are no longer needed. -C Move the computed (3,2) and (3,3) blocks of the pre-array in the -C (1,1) and (1,2) block positions of DWORK, to save space for the -C following computations. -C Then, adjust the implicitly defined leading dimension of DWORK, -C to make space for storing the (2,2) and (2,3) blocks of the -C pre-array. -C Workspace: need (P+N)*(N+1). -C - CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW ) - IF ( N.GT.M ) - $ CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1), - $ LDW ) - LDW = MAX( 1, NP ) -C - DO 40 I = N, 1, -1 - DO 30 IJ = MIN( N, I+M ), 1, -1 - DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ) - 30 CONTINUE - 40 CONTINUE -C -C Copy of RINV x C in the (1,1) block of DWORK. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW ) - IF ( .NOT.LMULTR ) - $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, - $ ONE, RINV, LDRINV, DWORK, LDW ) -C -C Copy the inclusion measurement in the (1,2) block and the updated -C X in the (2,2) block of DWORK. -C - I23 = NP*N + 1 - I33 = I23 + P - CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) - CALL DCOPY( N, X, 1, DWORK(I33), 1 ) - WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) -C -C Step 2: QR factorization of the first block column of the matrix -C -C [ RINV x C RINV x Y ], -C [ SINV x AINV SINV x X ] -C -C where the second block row was modified at Step 1. -C Workspace: need (P+N)*(N+1) + N + MAX(N-1,M+1); -C prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the -C optimal block size for DGEQRF called in MB04ID. -C - ITAU = I23 + NP - JWORK = ITAU + N -C - CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23), - $ LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Output SINV, X, and E and set the optimal workspace dimension -C (and the reciprocal of the condition number estimate). -C - CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) - CALL DCOPY( N, DWORK(I23), 1, X, 1 ) - IF( P.GT.0 ) - $ CALL DCOPY( P, DWORK(I23+N), 1, E, 1 ) -C - IF ( LJOBX ) THEN -C -C Compute X. -C Workspace: need 3*N. -C - CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', - $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, - $ TOL, IWORK, DWORK, INFO ) - IF ( INFO.EQ.0 ) THEN - WRKOPT = MAX( WRKOPT, 3*N ) - DWORK(2) = RCOND - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of FB01TD*** - END diff --git a/slycot/src/FB01VD.f b/slycot/src/FB01VD.f deleted file mode 100644 index eabf2174..00000000 --- a/slycot/src/FB01VD.f +++ /dev/null @@ -1,391 +0,0 @@ - SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q, - $ LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one recursion of the conventional Kalman filter -C equations. This is one update of the Riccati difference equation -C and the Kalman filter gain. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices P and A . N >= 0. -C i|i-1 i -C -C M (input) INTEGER -C The actual input dimension, i.e., the order of the matrix -C Q . M >= 0. -C i -C -C L (input) INTEGER -C The actual output dimension, i.e., the order of the matrix -C R . L >= 0. -C i -C -C P (input/output) DOUBLE PRECISION array, dimension (LDP,N) -C On entry, the leading N-by-N part of this array must -C contain P , the state covariance matrix at instant -C i|i-1 -C (i-1). The upper triangular part only is needed. -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains P , the state covariance matrix at -C i+1|i -C instant i. The strictly lower triangular part is not set. -C Otherwise, the leading N-by-N part of this array contains -C P , its input value. -C i|i-1 -C -C LDP INTEGER -C The leading dimension of array P. LDP >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain A , -C i -C the state transition matrix of the discrete system at -C instant i. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain B , -C i -C the input weight matrix of the discrete system at -C instant i. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array must contain C , -C i -C the output weight matrix of the discrete system at -C instant i. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,L). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,M) -C The leading M-by-M part of this array must contain Q , -C i -C the input (process) noise covariance matrix at instant i. -C The diagonal elements of this array are modified by the -C routine, but are restored on exit. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,M). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) -C On entry, the leading L-by-L part of this array must -C contain R , the output (measurement) noise covariance -C i -C matrix at instant i. -C On exit, if INFO = 0, or INFO = L+1, the leading L-by-L -C 1/2 -C upper triangular part of this array contains (RINOV ) , -C i -C the square root (left Cholesky factor) of the covariance -C matrix of the innovations at instant i. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,L). -C -C K (output) DOUBLE PRECISION array, dimension (LDK,L) -C If INFO = 0, the leading N-by-L part of this array -C contains K , the Kalman filter gain matrix at instant i. -C i -C If INFO > 0, the leading N-by-L part of this array -C contains the matrix product P C'. -C i|i-1 i -C -C LDK INTEGER -C The leading dimension of array K. LDK >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the matrix RINOV . If the user sets TOL > 0, then the -C i -C given value of TOL is used as a lower bound for the -C reciprocal condition number of that matrix; a matrix whose -C estimated condition number is less than 1/TOL is -C considered to be nonsingular. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = L*L*EPS, is used instead, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an -C estimate of the reciprocal of the condition number (in the -C 1-norm) of the matrix RINOV . -C i -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,L*N+3*L,N*N,N*M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value; -C = k: if INFO = k, 1 <= k <= L, the leading minor of order -C k of the matrix RINOV is not positive-definite, and -C i -C its Cholesky factorization could not be completed; -C = L+1: the matrix RINOV is singular, i.e., the condition -C i -C number estimate of RINOV (in the 1-norm) exceeds -C i -C 1/TOL. -C -C METHOD -C -C The conventional Kalman filter gain used at the i-th recursion -C step is of the form -C -C -1 -C K = P C' RINOV , -C i i|i-1 i i -C -C where RINOV = C P C' + R , and the state covariance matrix -C i i i|i-1 i i -C -C P is updated by the discrete-time difference Riccati equation -C i|i-1 -C -C P = A (P - K C P ) A' + B Q B'. -C i+1|i i i|i-1 i i i|i-1 i i i i -C -C Using these two updates, the combined time and measurement update -C of the state X is given by -C i|i-1 -C -C X = A X + A K (Y - C X ), -C i+1|i i i|i-1 i i i i i|i-1 -C -C where Y is the new observation at step i. -C i -C -C REFERENCES -C -C [1] Anderson, B.D.O. and Moore, J.B. -C Optimal Filtering, -C Prentice Hall, Englewood Cliffs, New Jersey, 1979. -C -C [2] Verhaegen, M.H.G. and Van Dooren, P. -C Numerical Aspects of Different Kalman Filter Implementations. -C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 3 2 -C 3/2 x N + N x (3 x L + M/2) -C -C operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Supersedes Release 2.0 routine FB01JD by M.H.G. Verhaegen, -C M. Vanbegin, and P. Van Dooren. -C -C REVISIONS -C -C February 20, 1998, November 20, 2003, April 20, 2004. -C -C KEYWORDS -C -C Kalman filtering, optimal filtering, recursive estimation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LDC, LDK, LDP, LDQ, LDR, - $ LDWORK, M, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ K(LDK,*), P(LDP,*), Q(LDQ,*), R(LDR,*) -C .. Local Scalars .. - INTEGER J, JWORK, LDW, N1 - DOUBLE PRECISION RCOND, RNORM, TOLDEF -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLACPY, DLASET, DPOCON, - $ DPOTRF, DSCAL, DTRMM, DTRSM, MB01RD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - N1 = MAX( 1, N ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( L.LT.0 ) THEN - INFO = -3 - ELSE IF( LDP.LT.N1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -7 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDQ.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDR.LT.MAX( 1, L ) ) THEN - INFO = -15 - ELSE IF( LDK.LT.N1 ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.MAX( 1, L*N + 3*L, N*N, N*M ) ) THEN - INFO = -21 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FB01VD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, L ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Efficiently compute RINOV = CPC' + R in R and put CP in DWORK and -C PC' in K. (The content of DWORK on exit from MB01RD is used.) -C Workspace: need L*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code.) -C - CALL MB01RD( 'Upper', 'No transpose', L, N, ONE, ONE, R, LDR, C, - $ LDC, P, LDP, DWORK, LDWORK, INFO ) - LDW = MAX( 1, L ) -C - DO 10 J = 1, L - CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) - 10 CONTINUE -C - CALL DLACPY( 'Full', L, N, C, LDC, DWORK, LDW ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', L, N, ONE, - $ P, LDP, DWORK, LDW ) - CALL DSCAL( N, TWO, P, LDP+1 ) -C - DO 20 J = 1, L - CALL DAXPY( N, ONE, K(1,J), 1, DWORK(J), LDW ) - CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) - 20 CONTINUE -C -C Calculate the Cholesky decomposition U'U of the innovation -C covariance matrix RINOV, and its reciprocal condition number. -C Workspace: need L*N + 3*L. -C - JWORK = L*N + 1 - RNORM = DLANSY( '1-norm', 'Upper', L, R, LDR, DWORK(JWORK) ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( L*L )*DLAMCH( 'Epsilon' ) - CALL DPOTRF( 'Upper', L, R, LDR, INFO ) - IF ( INFO.NE.0 ) - $ RETURN -C - CALL DPOCON( 'Upper', L, R, LDR, RNORM, RCOND, DWORK(JWORK), - $ IWORK, INFO ) -C - IF ( RCOND.LT.TOLDEF ) THEN -C -C Error return: RINOV is numerically singular. -C - INFO = L+1 - DWORK(1) = RCOND - RETURN - END IF -C - IF ( L.GT.1 ) - $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(2,1),LDR ) -C -1 -C Calculate the Kalman filter gain matrix K = PC'RINOV . -C Workspace: need L*N. -C - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, - $ ONE, R, LDR, K, LDK ) - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', N, L, - $ ONE, R, LDR, K, LDK ) -C -C First part of the Riccati equation update: compute A(P-KCP)A'. -C The upper triangular part of the symmetric matrix P-KCP is formed. -C Workspace: need max(L*N,N*N). -C - JWORK = 1 -C - DO 30 J = 1, N - CALL DGEMV( 'No transpose', J, L, -ONE, K, LDK, DWORK(JWORK), - $ 1, ONE, P(1,J), 1 ) - JWORK = JWORK + L - 30 CONTINUE -C - CALL MB01RD( 'Upper', 'No transpose', N, N, ZERO, ONE, P, LDP, A, - $ LDA, P, LDP, DWORK, LDWORK, INFO ) -C -C Second part of the Riccati equation update: add BQB'. -C Workspace: need N*M. -C - CALL MB01RD( 'Upper', 'No transpose', N, M, ONE, ONE, P, LDP, B, - $ LDB, Q, LDQ, DWORK, LDWORK, INFO ) - CALL DSCAL( M, TWO, Q, LDQ+1 ) -C -C Set the reciprocal of the condition number estimate. -C - DWORK(1) = RCOND -C - RETURN -C *** Last line of FB01VD *** - END diff --git a/slycot/src/FD01AD.f b/slycot/src/FD01AD.f deleted file mode 100644 index 79fef1b6..00000000 --- a/slycot/src/FD01AD.f +++ /dev/null @@ -1,367 +0,0 @@ - SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, - $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the least-squares filtering problem recursively in time. -C Each subroutine call implements one time update of the solution. -C The algorithm uses a fast QR-decomposition based approach. -C -C ARGUMENTS -C -C Mode Parameters -C -C JP CHARACTER*1 -C Indicates whether the user wishes to apply both prediction -C and filtering parts, as follows: -C = 'B': Both prediction and filtering parts are to be -C applied; -C = 'P': Only the prediction section is to be applied. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The length of the impulse response of the equivalent -C transversal filter model. L >= 1. -C -C LAMBDA (input) DOUBLE PRECISION -C Square root of the forgetting factor. -C For tracking capabilities and exponentially stable error -C propagation, LAMBDA < 1.0 (strict inequality) should -C be used. 0.0 < LAMBDA <= 1.0. -C -C XIN (input) DOUBLE PRECISION -C The input sample at instant n. -C (The situation just before and just after the call of -C the routine are denoted by instant (n-1) and instant n, -C respectively.) -C -C YIN (input) DOUBLE PRECISION -C If JP = 'B', then YIN must contain the reference sample -C at instant n. -C Otherwise, YIN is not referenced. -C -C EFOR (input/output) DOUBLE PRECISION -C On entry, this parameter must contain the square root of -C exponentially weighted forward prediction error energy -C at instant (n-1). EFOR >= 0.0. -C On exit, this parameter contains the square root of the -C exponentially weighted forward prediction error energy -C at instant n. -C -C XF (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, this array must contain the transformed forward -C prediction variables at instant (n-1). -C On exit, this array contains the transformed forward -C prediction variables at instant n. -C -C EPSBCK (input/output) DOUBLE PRECISION array, dimension (L+1) -C On entry, the leading L elements of this array must -C contain the normalized a posteriori backward prediction -C error residuals of orders zero through L-1, respectively, -C at instant (n-1), and EPSBCK(L+1) must contain the -C square-root of the so-called "conversion factor" at -C instant (n-1). -C On exit, this array contains the normalized a posteriori -C backward prediction error residuals, plus the square root -C of the conversion factor at instant n. -C -C CTETA (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, this array must contain the cosines of the -C rotation angles used in time updates, at instant (n-1). -C On exit, this array contains the cosines of the rotation -C angles at instant n. -C -C STETA (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, this array must contain the sines of the -C rotation angles used in time updates, at instant (n-1). -C On exit, this array contains the sines of the rotation -C angles at instant n. -C -C YQ (input/output) DOUBLE PRECISION array, dimension (L) -C On entry, if JP = 'B', then this array must contain the -C orthogonally transformed reference vector at instant -C (n-1). These elements are also the tap multipliers of an -C equivalent normalized lattice least-squares filter. -C Otherwise, YQ is not referenced and can be supplied as -C a dummy array (i.e., declare this array to be YQ(1) in -C the calling program). -C On exit, if JP = 'B', then this array contains the -C orthogonally transformed reference vector at instant n. -C -C EPOS (output) DOUBLE PRECISION -C The a posteriori forward prediction error residual. -C -C EOUT (output) DOUBLE PRECISION -C If JP = 'B', then EOUT contains the a posteriori output -C error residual from the least-squares filter at instant n. -C -C SALPH (output) DOUBLE PRECISION array, dimension (L) -C The element SALPH(i), i=1,...,L, contains the opposite of -C the i-(th) reflection coefficient for the least-squares -C normalized lattice predictor (whose value is -SALPH(i)). -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: an element to be annihilated by a rotation is less -C than the machine precision (see LAPACK Library -C routine DLAMCH). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The output error EOUT at instant n, denoted by EOUT(n), is the -C reference sample minus a linear combination of L successive input -C samples: -C -C L-1 -C EOUT(n) = YIN(n) - SUM h_i * XIN(n-i), -C i=0 -C -C where YIN(n) and XIN(n) are the scalar samples at instant n. -C A least-squares filter uses those h_0,...,h_{L-1} which minimize -C an exponentially weighted sum of successive output errors squared: -C -C n -C SUM [LAMBDA**(2(n-k)) * EOUT(k)**2]. -C k=1 -C -C Each subroutine call performs a time update of the least-squares -C filter using a fast least-squares algorithm derived from a -C QR decomposition, as described in references [1] and [2] (the -C notation from [2] is followed in the naming of the arrays). -C The algorithm does not compute the parameters h_0,...,h_{L-1} from -C the above formula, but instead furnishes the parameters of an -C equivalent normalized least-squares lattice filter, which are -C available from the arrays SALPH (reflection coefficients) and YQ -C (tap multipliers), as well as the exponentially weighted input -C signal energy -C -C n L -C SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2. -C k=1 i=1 -C -C For more details on reflection coefficients and tap multipliers, -C references [2] and [4] are recommended. -C -C REFERENCES -C -C [1] Proudler, I. K., McWhirter, J. G., and Shepherd, T. J. -C Fast QRD based algorithms for least-squares linear -C prediction. -C Proceedings IMA Conf. Mathematics in Signal Processing -C Warwick, UK, December 1988. -C -C [2] Regalia, P. A., and Bellanger, M. G. -C On the duality between QR methods and lattice methods in -C least-squares adaptive filtering. -C IEEE Trans. Signal Processing, SP-39, pp. 879-891, -C April 1991. -C -C [3] Regalia, P. A. -C Numerical stability properties of a QR-based fast -C least-squares algorithm. -C IEEE Trans. Signal Processing, SP-41, June 1993. -C -C [4] Lev-Ari, H., Kailath, T., and Cioffi, J. -C Least-squares adaptive lattice and transversal filters: -C A unified geometric theory. -C IEEE Trans. Information Theory, IT-30, pp. 222-236, -C March 1984. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(L) operations for each subroutine call. -C It is backward consistent for all input sequences XIN, and -C backward stable for persistently exciting input sequences, -C assuming LAMBDA < 1.0 (see [3]). -C If the condition of the signal is very poor (IWARN = 1), then the -C results are not guaranteed to be reliable. -C -C FURTHER COMMENTS -C -C 1. For tracking capabilities and exponentially stable error -C propagation, LAMBDA < 1.0 should be used. LAMBDA is typically -C chosen slightly less than 1.0 so that "past" data are -C exponentially forgotten. -C 2. Prior to the first subroutine call, the variables must be -C initialized. The following initial values are recommended: -C -C XF(i) = 0.0, i=1,...,L -C EPSBCK(i) = 0.0 i=1,...,L -C EPSBCK(L+1) = 1.0 -C CTETA(i) = 1.0 i=1,...,L -C STETA(i) = 0.0 i=1,...,L -C YQ(i) = 0.0 i=1,...,L -C -C EFOR = 0.0 (exact start) -C EFOR = "small positive constant" (soft start). -C -C Soft starts are numerically more reliable, but result in a -C biased least-squares solution during the first few iterations. -C This bias decays exponentially fast provided LAMBDA < 1.0. -C If sigma is the standard deviation of the input sequence -C XIN, then initializing EFOR = sigma*1.0E-02 usually works -C well. -C -C CONTRIBUTOR -C -C P. A. Regalia (October 1994). -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Kalman filtering, least-squares estimator, optimal filtering, -C orthogonal transformation, recursive estimation, QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JP - INTEGER INFO, IWARN, L - DOUBLE PRECISION EFOR, EOUT, EPOS, LAMBDA, XIN, YIN -C .. Array Arguments .. - DOUBLE PRECISION CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*), - $ YQ(*) -C .. Local Scalars .. - LOGICAL BOTH - INTEGER I - DOUBLE PRECISION CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DLARTG, XERBLA -C .. Intrinsic Functions - INTRINSIC ABS, SQRT -C .. Executable statements .. -C -C Test the input scalar arguments. -C - BOTH = LSAME( JP, 'B' ) - IWARN = 0 - INFO = 0 -C - IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN - INFO = -1 - ELSE IF( L.LT.1 ) THEN - INFO = -2 - ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE ) ) THEN - INFO = -3 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'FD01AD', -INFO ) - RETURN - END IF -C -C Computation of the machine precision EPS. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Forward prediction rotations. -C - FNODE = XIN -C - DO 10 I = 1, L - XFI = XF(I) * LAMBDA - XF(I) = STETA(I) * FNODE + CTETA(I) * XFI - FNODE = CTETA(I) * FNODE - STETA(I) * XFI - 10 CONTINUE -C - EPOS = FNODE * EPSBCK(L+1) -C -C Update the square root of the prediction energy. -C - EFOR = EFOR * LAMBDA - TEMP = DLAPY2( FNODE, EFOR ) - IF ( TEMP.LT.EPS ) THEN - FNODE = ZERO - IWARN = 1 - ELSE - FNODE = FNODE * EPSBCK(L+1)/TEMP - END IF - EFOR = TEMP -C -C Calculate the reflection coefficients and the backward prediction -C errors. -C - DO 20 I = L, 1, -1 - IF ( ABS( XF(I) ).LT.EPS ) - $ IWARN = 1 - CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM ) - EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE - FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I) - TEMP = NORM - 20 CONTINUE -C - EPSBCK(1) = FNODE -C -C Update to new rotation angles. -C - NORM = DNRM2( L, EPSBCK, 1 ) - TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) ) - EPSBCK(L+1) = TEMP -C - DO 30 I = L, 1, -1 - IF ( ABS( EPSBCK(I) ).LT.EPS ) - $ IWARN = 1 - CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM ) - TEMP = NORM - 30 CONTINUE -C -C Joint process section. -C - IF ( BOTH) THEN - FNODE = YIN -C - DO 40 I = 1, L - YQI = YQ(I) * LAMBDA - YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI - FNODE = CTETA(I) * FNODE - STETA(I) * YQI - 40 CONTINUE -C - EOUT = FNODE * EPSBCK(L+1) - END IF -C - RETURN -C *** Last line of FD01AD *** - END diff --git a/slycot/src/IB01AD.f b/slycot/src/IB01AD.f deleted file mode 100644 index 301cdd52..00000000 --- a/slycot/src/IB01AD.f +++ /dev/null @@ -1,686 +0,0 @@ - SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, - $ L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND, - $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To preprocess the input-output data for estimating the matrices -C of a linear time-invariant dynamical system and to find an -C estimate of the system order. The input-output data can, -C optionally, be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C ALG CHARACTER*1 -C Specifies the algorithm for computing the triangular -C factor R, as follows: -C = 'C': Cholesky algorithm applied to the correlation -C matrix of the input-output data; -C = 'F': Fast QR algorithm; -C = 'Q': QR algorithm applied to the concatenated block -C Hankel matrices. -C -C JOBD CHARACTER*1 -C Specifies whether or not the matrices B and D should later -C be computed using the MOESP approach, as follows: -C = 'M': the matrices B and D should later be computed -C using the MOESP approach; -C = 'N': the matrices B and D should not be computed using -C the MOESP approach. -C This parameter is not relevant for METH = 'N'. -C -C BATCH CHARACTER*1 -C Specifies whether or not sequential data processing is to -C be used, and, for sequential processing, whether or not -C the current data block is the first block, an intermediate -C block, or the last block, as follows: -C = 'F': the first block in sequential data processing; -C = 'I': an intermediate block in sequential data -C processing; -C = 'L': the last block in sequential data processing; -C = 'O': one block only (non-sequential data processing). -C NOTE that when 100 cycles of sequential data processing -C are completed for BATCH = 'I', a warning is -C issued, to prevent for an infinite loop. -C -C CONCT CHARACTER*1 -C Specifies whether or not the successive data blocks in -C sequential data processing belong to a single experiment, -C as follows: -C = 'C': the current data block is a continuation of the -C previous data block and/or it will be continued -C by the next data block; -C = 'N': there is no connection between the current data -C block and the previous and/or the next ones. -C This parameter is not used if BATCH = 'O'. -C -C CTRL CHARACTER*1 -C Specifies whether or not the user's confirmation of the -C system order estimate is desired, as follows: -C = 'C': user's confirmation; -C = 'N': no confirmation. -C If CTRL = 'C', a reverse communication routine, IB01OY, -C is indirectly called (by SLICOT Library routine IB01OD), -C and, after inspecting the singular values and system order -C estimate, n, the user may accept n or set a new value. -C IB01OY is not called if CTRL = 'N'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices to be processed. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C When M = 0, no system inputs are processed. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). (When sequential data processing is used, -C NSMP is the number of samples of the current data -C block.) -C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential -C processing; -C NSMP >= 2*NOBR, for sequential processing. -C The total number of samples when calling the routine with -C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. -C The NSMP argument may vary from a cycle to another in -C sequential data processing, but NOBR, M, and L should -C be kept constant. For efficiency, it is advisable to use -C NSMP as large as possible. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NSMP-by-M part of this array must contain the -C t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= NSMP, if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= NSMP. -C -C N (output) INTEGER -C The estimated order of the system. -C If CTRL = 'C', the estimated order has been reset to a -C value specified by the user. -C -C R (output or input/output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the current upper triangular part of the -C correlation matrix in sequential data processing. -C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not -C referenced. -C On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I', -C the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular -C part of this array contains the current upper triangular -C factor R from the QR factorization of the concatenated -C block Hankel matrices. Denote R_ij, i,j = 1:4, the -C ij submatrix of R, partitioned by M*NOBR, M*NOBR, -C L*NOBR, and L*NOBR rows and columns. -C On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of -C this array contains the matrix S, the processed upper -C triangular factor R from the QR factorization of the -C concatenated block Hankel matrices, as required by other -C subroutines. Specifically, let S_ij, i,j = 1:4, be the -C ij submatrix of S, partitioned by M*NOBR, L*NOBR, -C M*NOBR, and L*NOBR rows and columns. The submatrix -C S_22 contains the matrix of left singular vectors needed -C subsequently. Useful information is stored in S_11 and -C in the block-column S_14 : S_44. For METH = 'M' and -C JOBD = 'M', the upper triangular part of S_31 contains -C the upper triangular factor in the QR factorization of the -C matrix R_1c = [ R_12' R_22' R_11' ]', and S_12 -C contains the corresponding leading part of the transformed -C matrix R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', -C the subarray S_41 : S_43 contains the transpose of the -C matrix contained in S_14 : S_34. -C The details of the contents of R need not be known if this -C routine is followed by SLICOT Library routine IB01BD. -C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or -C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper -C triangular part of this array must contain the upper -C triangular matrix R computed at the previous call of this -C routine in sequential data processing. The array R need -C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), -C for METH = 'M' and JOBD = 'M'; -C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or -C for METH = 'N'. -C -C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) -C The singular values used to estimate the system order. -C -C Tolerances -C -C RCOND DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets RCOND > 0, the given value -C of RCOND is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/RCOND is considered to -C be of full rank. If the user sets RCOND <= 0, then an -C implicitly computed, default tolerance, defined by -C RCONDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not used for METH = 'M'. -C -C TOL DOUBLE PRECISION -C Absolute tolerance used for determining an estimate of -C the system order. If TOL >= 0, the estimate is -C indicated by the index of the last singular value greater -C than or equal to TOL. (Singular values less than TOL -C are considered as zero.) When TOL = 0, an internally -C computed default value, TOL = NOBR*EPS*SV(1), is used, -C where SV(1) is the maximal singular value, and EPS is -C the relative machine precision (see LAPACK Library routine -C DLAMCH). When TOL < 0, the estimate is indicated by the -C index of the singular value that has the largest -C logarithmic gap to its successor. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= (M+L)*NOBR, if METH = 'N'; -C LIWORK >= M+L, if METH = 'M' and ALG = 'F'; -C LIWORK >= 0, if METH = 'M' and ALG = 'C' or 'Q'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, for METH = 'N', and BATCH = 'L' or -C 'O', DWORK(2) and DWORK(3) contain the reciprocal -C condition numbers of the triangular factors of the -C matrices U_f and r_1 [6]. -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C Let -C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; -C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; -C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; -C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. -C The first (M+L)*k elements of DWORK should be preserved -C during successive calls of the routine with BATCH = 'F' -C or 'I', till the final call with BATCH = 'L'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or -C 'I' and CONCT = 'C'; -C LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and -C CONCT = 'N'; -C LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M', -C ALG = 'C', BATCH = 'L' and CONCT = 'C'; -C LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR), -C if METH = 'M', JOBD = 'M', ALG = 'C', -C BATCH = 'O', or -C (BATCH = 'L' and CONCT = 'N'); -C LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C', -C BATCH = 'O', or -C (BATCH = 'L' and CONCT = 'N'); -C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and -C BATCH = 'L' or 'O'; -C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', -C BATCH <> 'O' and CONCT = 'C'; -C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', -C BATCH = 'F', 'I' and CONCT = 'N'; -C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', -C BATCH = 'L' and CONCT = 'N', or -C BATCH = 'O'; -C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and -C LDR >= NS = NSMP - 2*NOBR + 1; -C LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M', -C ALG = 'Q', BATCH = 'O', and LDR >= NS; -C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q', -C BATCH = 'O', and LDR >= NS; -C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O', -C and LDR < NS), or (BATCH = 'I' or -C 'L' and CONCT = 'N'); -C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' -C or 'L' and CONCT = 'C'. -C The workspace used for ALG = 'Q' is -C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, -C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended -C value LDRWRK = NS, assuming a large enough cache size. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the number of 100 cycles in sequential data -C processing has been exhausted without signaling -C that the last block of data was get; the cycle -C counter was reinitialized; -C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), -C but it failed, and the QR algorithm was then used -C (non-sequential data processing); -C = 3: all singular values were exactly zero, hence N = 0 -C (both input and output were identically zero); -C = 4: the least squares problems with coefficient matrix -C U_f, used for computing the weighted oblique -C projection (for METH = 'N'), have a rank-deficient -C coefficient matrix; -C = 5: the least squares problem with coefficient matrix -C r_1 [6], used for computing the weighted oblique -C projection (for METH = 'N'), has a rank-deficient -C coefficient matrix. -C NOTE: the values 4 and 5 of IWARN have no significance -C for the identification problem. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: a fast algorithm was requested (ALG = 'C', or 'F') -C in sequential data processing, but it failed; the -C routine can be repeatedly called again using the -C standard QR algorithm; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C The procedure consists in three main steps, the first step being -C performed by one of the three algorithms included. -C -C 1.a) For non-sequential data processing using QR algorithm, a -C t x 2(m+l)s matrix H is constructed, where -C -C H = [ Uf' Up' Y' ], for METH = 'M', -C s+1,2s,t 1,s,t 1,2s,t -C -C H = [ U' Y' ], for METH = 'N', -C 1,2s,t 1,2s,t -C -C and Up , Uf , U , and Y are block Hankel -C 1,s,t s+1,2s,t 1,2s,t 1,2s,t -C matrices defined in terms of the input and output data [3]. -C A QR factorization is used to compress the data. -C The fast QR algorithm uses a QR factorization which exploits -C the block-Hankel structure. Actually, the Cholesky factor of H'*H -C is computed. -C -C 1.b) For sequential data processing using QR algorithm, the QR -C decomposition is done sequentially, by updating the upper -C triangular factor R. This is also performed internally if the -C workspace is not large enough to accommodate an entire batch. -C -C 1.c) For non-sequential or sequential data processing using -C Cholesky algorithm, the correlation matrix of input-output data is -C computed (sequentially, if requested), taking advantage of the -C block Hankel structure [7]. Then, the Cholesky factor of the -C correlation matrix is found, if possible. -C -C 2) A singular value decomposition (SVD) of a certain matrix is -C then computed, which reveals the order n of the system as the -C number of "non-zero" singular values. For the MOESP approach, this -C matrix is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), -C where R is the upper triangular factor R constructed by SLICOT -C Library routine IB01MD. For the N4SID approach, a weighted -C oblique projection is computed from the upper triangular factor R -C and its SVD is then found. -C -C 3) The singular values are compared to the given, or default TOL, -C and the estimated order n is returned, possibly after user's -C confirmation. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Peternell, K., Scherrer, W. and Deistler, M. -C Statistical Analysis of Novel Subspace Identification Methods. -C Signal Processing, 52, pp. 161-177, 1996. -C -C [6] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C [7] Sima, V. -C Cholesky or QR Factorization for Data Compression in -C Subspace-based Identification ? -C Proceedings of the Second NICONET Workshop on ``Numerical -C Control Software: SLICOT, a Useful Tool in Industry'', -C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable (when QR algorithm is -C used), reliable and efficient. The fast Cholesky or QR algorithms -C are more efficient, but the accuracy could diminish by forming the -C correlation matrix. -C The most time-consuming computational step is step 1: -C 2 -C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. -C 2 3 -C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating -C point operations. -C 2 3 2 -C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating -C point operations. -C 3 -C Step 2 of the algorithm requires 0(((m+l)s) ) floating point -C operations. -C -C FURTHER COMMENTS -C -C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the -C calculations could be rather inefficient if only minimal workspace -C (see argument LDWORK) is provided. It is advisable to provide as -C much workspace as possible. Almost optimal efficiency can be -C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the -C cache size is large enough to accommodate R, U, Y, and DWORK. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. -C -C REVISIONS -C -C August 2000, March 2005. -C -C KEYWORDS -C -C Cholesky decomposition, Hankel matrix, identification methods, -C multivariable systems, QR decomposition, singular value -C decomposition. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - DOUBLE PRECISION RCOND, TOL - INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N, - $ NOBR, NSMP - CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*), U(LDU, *), - $ Y(LDY, *) -C .. Local Scalars .. - INTEGER IWARNL, LMNOBR, LNOBR, MAXWRK, MINWRK, MNOBR, - $ NOBR21, NR, NS, NSMPSM - LOGICAL CHALG, CONNEC, CONTRL, FIRST, FQRALG, INTERM, - $ JOBDM, LAST, MOESP, N4SID, ONEBCH, QRALG -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL IB01MD, IB01ND, IB01OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Save Statement .. -C MAXWRK is used to store the optimal workspace. -C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. - SAVE MAXWRK, NSMPSM -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - FQRALG = LSAME( ALG, 'F' ) - QRALG = LSAME( ALG, 'Q' ) - CHALG = LSAME( ALG, 'C' ) - JOBDM = LSAME( JOBD, 'M' ) - ONEBCH = LSAME( BATCH, 'O' ) - FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH - INTERM = LSAME( BATCH, 'I' ) - LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH - CONTRL = LSAME( CTRL, 'C' ) -C - IF( .NOT.ONEBCH ) THEN - CONNEC = LSAME( CONCT, 'C' ) - ELSE - CONNEC = .FALSE. - END IF -C - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - NR = LMNOBR + LMNOBR - NOBR21 = 2*NOBR - 1 - IWARN = 0 - INFO = 0 - IF( FIRST ) THEN - MAXWRK = 1 - NSMPSM = 0 - END IF - NSMPSM = NSMPSM + NSMP -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN - INFO = -2 - ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN - INFO = -4 - ELSE IF( .NOT. ONEBCH ) THEN - IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) - $ INFO = -5 - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( NOBR.LE.0 ) THEN - INFO = -7 - ELSE IF( M.LT.0 ) THEN - INFO = -8 - ELSE IF( L.LE.0 ) THEN - INFO = -9 - ELSE IF( NSMP.LT.2*NOBR .OR. - $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -12 - ELSE IF( LDY.LT.NSMP ) THEN - INFO = -14 - ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. - $ LDR.LT.3*MNOBR ) ) THEN - INFO = -17 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe -C the minimal amount of workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - NS = NSMP - NOBR21 - IF ( CHALG ) THEN - IF ( .NOT.LAST ) THEN - IF ( CONNEC ) THEN - MINWRK = 2*( NR - M - L ) - ELSE - MINWRK = 1 - END IF - ELSE IF ( MOESP ) THEN - IF ( CONNEC .AND. .NOT.ONEBCH ) THEN - MINWRK = MAX( 2*( NR - M - L ), 5*LNOBR ) - ELSE - MINWRK = 5*LNOBR - IF ( JOBDM ) - $ MINWRK = MAX( 2*MNOBR - NOBR, LMNOBR, MINWRK ) - END IF - ELSE - MINWRK = 5*LMNOBR + 1 - END IF - ELSE IF ( FQRALG ) THEN - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = NR*( M + L + 3 ) - ELSE IF ( FIRST .OR. INTERM ) THEN - MINWRK = NR*( M + L + 1 ) - ELSE - MINWRK = 2*NR*( M + L + 1 ) + NR - END IF - ELSE - MINWRK = 2*NR - IF ( ONEBCH .AND. LDR.GE.NS ) THEN - IF ( MOESP ) THEN - MINWRK = MAX( MINWRK, 5*LNOBR ) - ELSE - MINWRK = 5*LMNOBR + 1 - END IF - END IF - IF ( FIRST ) THEN - IF ( LDR.LT.NS ) THEN - MINWRK = MINWRK + NR - END IF - ELSE - IF ( CONNEC ) THEN - MINWRK = MINWRK*( NOBR + 1 ) - ELSE - MINWRK = MINWRK + NR - END IF - END IF - END IF -C - MAXWRK = MINWRK -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -23 - DWORK( 1 ) = MINWRK - END IF - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01AD', -INFO ) - RETURN - END IF -C -C Compress the input-output data. -C Workspace: need c*(M+L)*NOBR, where c is a constant depending -C on the algorithm and the options used -C (see SLICOT Library routine IB01MD); -C prefer larger. -C - CALL IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, Y, - $ LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, INFO ) -C - IF ( INFO.EQ.1 ) THEN -C -C Error return: A fast algorithm was requested (ALG = 'C', 'F') -C in sequential data processing, but it failed. -C - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) -C - IF ( .NOT.LAST ) THEN -C -C Return to get new data. -C - RETURN - END IF -C -C Find the singular value decomposition (SVD) giving the system -C order, and perform related preliminary calculations needed for -C computing the system matrices. -C Workspace: need max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), -C if METH = 'M'; -C 5*(M+L)*NOBR+1, if METH = 'N'; -C prefer larger. -C - CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK, - $ DWORK, LDWORK, IWARNL, INFO ) - IWARN = MAX( IWARN, IWARNL ) -C - IF ( INFO.EQ.2 ) THEN -C -C Error return: the singular value decomposition (SVD) algorithm -C did not converge. -C - RETURN - END IF -C -C Estimate the system order. -C - CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO ) - IWARN = MAX( IWARN, IWARNL ) -C -C Return optimal workspace in DWORK(1). -C - DWORK( 1 ) = MAX( MAXWRK, INT( DWORK( 1 ) ) ) - RETURN -C -C *** Last line of IB01AD *** - END diff --git a/slycot/src/IB01BD.f b/slycot/src/IB01BD.f deleted file mode 100644 index 011e02d3..00000000 --- a/slycot/src/IB01BD.f +++ /dev/null @@ -1,791 +0,0 @@ - SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R, - $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, - $ RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK, - $ LDWORK, BWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the system matrices A, C, B, and D, the noise -C covariance matrices Q, Ry, and S, and the Kalman gain matrix K -C of a linear time-invariant state space model, using the -C processed triangular factor R of the concatenated block Hankel -C matrices, provided by SLICOT Library routine IB01AD. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm; -C = 'C': combined method: MOESP algorithm for finding the -C matrices A and C, and N4SID algorithm for -C finding the matrices B and D. -C -C JOB CHARACTER*1 -C Specifies which matrices should be computed, as follows: -C = 'A': compute all system matrices, A, B, C, and D; -C = 'C': compute the matrices A and C only; -C = 'B': compute the matrix B only; -C = 'D': compute the matrices B and D only. -C -C JOBCK CHARACTER*1 -C Specifies whether or not the covariance matrices and the -C Kalman gain matrix are to be computed, as follows: -C = 'C': the covariance matrices only should be computed; -C = 'K': the covariance matrices and the Kalman gain -C matrix should be computed; -C = 'N': the covariance matrices and the Kalman gain matrix -C should not be computed. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMPL (input) INTEGER -C If JOBCK = 'C' or 'K', the total number of samples used -C for calculating the covariance matrices. -C NSMPL >= 2*(M+L)*NOBR. -C This parameter is not meaningful if JOBCK = 'N'. -C -C R (input/workspace) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part -C of this array must contain the relevant data for the MOESP -C or N4SID algorithms, as constructed by SLICOT Library -C routine IB01AD. Let R_ij, i,j = 1:4, be the -C ij submatrix of R (denoted S in IB01AD), partitioned -C by M*NOBR, L*NOBR, M*NOBR, and L*NOBR rows and -C columns. The submatrix R_22 contains the matrix of left -C singular vectors used. Also needed, for METH = 'N' or -C JOBCK <> 'N', are the submatrices R_11, R_14 : R_44, -C and, for METH = 'M' or 'C' and JOB <> 'C', the -C submatrices R_31 and R_12, containing the processed -C matrices R_1c and R_2c, respectively, as returned by -C SLICOT Library routine IB01AD. -C Moreover, if METH = 'N' and JOB = 'A' or 'C', the -C block-row R_41 : R_43 must contain the transpose of the -C block-column R_14 : R_34 as returned by SLICOT Library -C routine IB01AD. -C The remaining part of R is used as workspace. -C On exit, part of this array is overwritten. Specifically, -C if METH = 'M', R_22 and R_31 are overwritten if -C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, -C and possibly R_11 are overwritten if JOBCK <> 'N'; -C if METH = 'N', all needed submatrices are overwritten. -C The details of the contents of R need not be known if -C this routine is called once just after calling the SLICOT -C Library routine IB01AD. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C A (input or output) DOUBLE PRECISION array, dimension -C (LDA,N) -C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', -C the leading N-by-N part of this array must contain the -C system state matrix. -C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' -C or 'C'), this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, the -C leading N-by-N part of this array contains the system -C state matrix. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' or 'C' -C and JOB = 'B' or 'D'; -C LDA >= 1, otherwise. -C -C C (input or output) DOUBLE PRECISION array, dimension -C (LDC,N) -C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', -C the leading L-by-N part of this array must contain the -C system output matrix. -C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' -C or 'C'), this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, or -C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading -C L-by-N part of this array contains the system output -C matrix. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' or 'C' -C and JOB = 'B' or 'D'; -C LDC >= 1, otherwise. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the -C leading N-by-M part of this array contains the system -C input matrix. If M = 0 or JOB = 'C', this array is -C not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; -C LDB >= 1, if M = 0 or JOB = 'C'. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix. If M = 0 or JOB = 'C' or 'B', this array is -C not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'A' or 'D'; -C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C If JOBCK = 'C' or 'K', the leading N-by-N part of this -C array contains the positive semidefinite state covariance -C matrix. If JOBCK = 'K', this matrix has been used as -C state weighting matrix for computing the Kalman gain. -C This parameter is not referenced if JOBCK = 'N'. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= N, if JOBCK = 'C' or 'K'; -C LDQ >= 1, if JOBCK = 'N'. -C -C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) -C If JOBCK = 'C' or 'K', the leading L-by-L part of this -C array contains the positive (semi)definite output -C covariance matrix. If JOBCK = 'K', this matrix has been -C used as output weighting matrix for computing the Kalman -C gain. -C This parameter is not referenced if JOBCK = 'N'. -C -C LDRY INTEGER -C The leading dimension of the array RY. -C LDRY >= L, if JOBCK = 'C' or 'K'; -C LDRY >= 1, if JOBCK = 'N'. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,L) -C If JOBCK = 'C' or 'K', the leading N-by-L part of this -C array contains the state-output cross-covariance matrix. -C If JOBCK = 'K', this matrix has been used as state- -C output weighting matrix for computing the Kalman gain. -C This parameter is not referenced if JOBCK = 'N'. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= N, if JOBCK = 'C' or 'K'; -C LDS >= 1, if JOBCK = 'N'. -C -C K (output) DOUBLE PRECISION array, dimension ( LDK,L ) -C If JOBCK = 'K', the leading N-by-L part of this array -C contains the estimated Kalman gain matrix. -C If JOBCK = 'C' or 'N', this array is not referenced. -C -C LDK INTEGER -C The leading dimension of the array K. -C LDK >= N, if JOBCK = 'K'; -C LDK >= 1, if JOBCK = 'C' or 'N'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= max(LIW1,LIW2), where -C LIW1 = N, if METH <> 'N' and M = 0 -C or JOB = 'C' and JOBCK = 'N'; -C LIW1 = M*NOBR+N, if METH <> 'N', JOB = 'C', -C and JOBCK <> 'N'; -C LIW1 = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', -C and JOBCK = 'N'; -C LIW1 = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', -C and JOBCK = 'C' or 'K'; -C LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C' -C and JOB <> 'C'; -C LIW2 = 0, if JOBCK <> 'K'; -C LIW2 = N*N, if JOBCK = 'K'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and -C DWORK(5) contain the reciprocal condition numbers of the -C triangular factors of the following matrices (defined in -C SLICOT Library routine IB01PD and in the lower level -C routines): -C GaL (GaL = Un(1:(s-1)*L,1:n)), -C R_1c (if METH = 'M' or 'C'), -C M (if JOBCK = 'C' or 'K' or METH = 'N'), and -C Q or T (see SLICOT Library routine IB01PY or IB01PX), -C respectively. -C If METH = 'N', DWORK(3) is set to one without any -C calculations. Similarly, if METH = 'M' and JOBCK = 'N', -C DWORK(4) is set to one. If M = 0 or JOB = 'C', -C DWORK(3) and DWORK(5) are set to one. -C If JOBCK = 'K' and INFO = 0, DWORK(6) to DWORK(13) -C contain information about the accuracy of the results when -C computing the Kalman gain matrix, as follows: -C DWORK(6) - reciprocal condition number of the matrix -C U11 of the Nth order system of algebraic -C equations from which the solution matrix X -C of the Riccati equation is obtained; -C DWORK(7) - reciprocal pivot growth factor for the LU -C factorization of the matrix U11; -C DWORK(8) - reciprocal condition number of the matrix -C As = A - S*inv(Ry)*C, which is inverted by -C the standard Riccati solver; -C DWORK(9) - reciprocal pivot growth factor for the LU -C factorization of the matrix As; -C DWORK(10) - reciprocal condition number of the matrix -C Ry; -C DWORK(11) - reciprocal condition number of the matrix -C Ry + C*X*C'; -C DWORK(12) - reciprocal condition number for the Riccati -C equation solution; -C DWORK(13) - forward error bound for the Riccati -C equation solution. -C On exit, if INFO = -30, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M', -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), -C if JOB = 'C' or JOB = 'A' and M = 0; -C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, -C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ -C max( L+M*NOBR, L*NOBR + -C max( 3*L*NOBR+1, M ) ) ), -C if M > 0 and JOB = 'A', 'B', or 'D'; -C LDW2 >= 0, if JOBCK = 'N'; -C LDW2 >= L*NOBR*N+ -C max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), -C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), -C if JOBCK = 'C' or 'K', -C where Aw = N+N*N, if M = 0 or JOB = 'C'; -C Aw = 0, otherwise; -C if METH = 'N', -C LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ); -C LDW2 >= 0, if M = 0 or JOB = 'C'; -C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), -C if M > 0 and JOB = 'A', 'B', or 'D'; -C and, if METH = 'C', LDW1 as -C max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'), -C and LDW2 for METH = 'N' are used; -C LDW3 >= 0, if JOBCK <> 'K'; -C LDW3 >= max( 4*N*N+2*N*L+L*L+max( 3*L,N*L ), -C 14*N*N+12*N+5 ), if JOBCK = 'K'. -C For good performance, LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (LBWORK) -C LBWORK = 2*N, if JOBCK = 'K'; -C LBWORK = 0, if JOBCK <> 'K'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: a least squares problem to be solved has a -C rank-deficient coefficient matrix; -C = 5: the computed covariance matrices are too small. -C The problem seems to be a deterministic one; the -C gain matrix is set to zero. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge; -C = 3: a singular upper triangular matrix was found; -C = 3+i: if JOBCK = 'K' and the associated Riccati -C equation could not be solved, where i = 1,...,6; -C (see the description of the parameter INFO for the -C SLICOT Library routine SB02RD for the meaning of -C the i values); -C = 10: the QR algorithm did not converge. -C -C METHOD -C -C In the MOESP approach, the matrices A and C are first -C computed from an estimated extended observability matrix [1], -C and then, the matrices B and D are obtained by solving an -C extended linear system in a least squares sense. -C In the N4SID approach, besides the estimated extended -C observability matrix, the solutions of two least squares problems -C are used to build another least squares problem, whose solution -C is needed to compute the system matrices A, C, B, and D. The -C solutions of the two least squares problems are also optionally -C used by both approaches to find the covariance matrices. -C The Kalman gain matrix is obtained by solving a discrete-time -C algebraic Riccati equation. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C [4] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method consists in numerically stable steps. -C -C FURTHER COMMENTS -C -C The covariance matrices are computed using the N4SID approach. -C Therefore, for efficiency reasons, it is advisable to set -C METH = 'N', if the Kalman gain matrix or covariance matrices -C are needed (JOBCK = 'K', or 'C'). When JOBCK = 'N', it could -C be more efficient to use the combined method, METH = 'C'. -C Often, this combination will also provide better accuracy than -C MOESP algorithm. -C In some applications, it is useful to compute the system matrices -C using two calls to this routine, the first one with JOB = 'C', -C and the second one with JOB = 'B' or 'D'. This is slightly less -C efficient than using a single call with JOB = 'A', because some -C calculations are repeated. If METH = 'N', all the calculations -C at the first call are performed again at the second call; -C moreover, it is required to save the needed submatrices of R -C before the first call and restore them before the second call. -C If the covariance matrices and/or the Kalman gain are desired, -C JOBCK should be set to 'C' or 'K' at the second call. -C If B and D are both needed, they should be computed at once. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. -C -C REVISIONS -C -C March 2000, August 2000, Sept. 2001, March 2005. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDK, LDQ, - $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL - CHARACTER JOB, JOBCK, METH -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), K(LDK, *), Q(LDQ, *), R(LDR, *), - $ RY(LDRY, *), S(LDS, *) - INTEGER IWORK( * ) - LOGICAL BWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION FERR, RCOND, RCONDR, RNORM, SEP - INTEGER I, IA, IAW, IC, ID, IERR, IFACT, IG, IK, IO, - $ IQ, IR, IS, IT, IV, IWARNL, IWI, IWR, IX, - $ JWORK, LDUNN, LL, LMMNOL, LMNOBR, LNOBR, - $ MAXWRK, MINWRK, MNOBR, MNOBRN, N2, NL, NN, NPL, - $ NR - CHARACTER JOBBD, JOBCOV, JOBCV - LOGICAL COMBIN, MOESP, N4SID, WITHAL, WITHB, WITHC, - $ WITHCO, WITHD, WITHK -C .. Local Arrays .. - DOUBLE PRECISION RCND(8) - INTEGER OUFACT(2) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, IB01PD, MA02AD, SB02MT, SB02ND, - $ SB02RD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - COMBIN = LSAME( METH, 'C' ) - WITHAL = LSAME( JOB, 'A' ) - WITHC = LSAME( JOB, 'C' ) .OR. WITHAL - WITHD = LSAME( JOB, 'D' ) .OR. WITHAL - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - WITHK = LSAME( JOBCK, 'K' ) - WITHCO = LSAME( JOBCK, 'C' ) .OR. WITHK - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - MNOBRN = MNOBR + N - LDUNN = ( LNOBR - L )*N - LMMNOL = LNOBR + 2*MNOBR + L - NR = LMNOBR + LMNOBR - NPL = N + L - N2 = N + N - NN = N*N - NL = N*L - LL = L*L - MINWRK = 1 - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID .OR. COMBIN ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN - INFO = -2 - ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCK, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -4 - ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LE.0 ) THEN - INFO = -7 - ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN - INFO = -8 - ELSE IF( LDR.LT.NR ) THEN - INFO = -10 - ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) - $ .AND. LDA.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) - $ .AND. LDC.LT.L ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) - $ THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -18 - ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN - INFO = -20 - ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN - INFO = -24 - ELSE IF( LDK.LT.1 .OR. ( WITHK .AND. LDK.LT.N ) ) THEN - INFO = -26 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C - IAW = 0 - MINWRK = LDUNN + 4*N - IF( .NOT.N4SID ) THEN - ID = 0 - IF( WITHC ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) - END IF - ELSE - ID = N - END IF -C - IF( ( M.GT.0 .AND. WITHB ) .OR. .NOT.MOESP ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) - IF ( MOESP ) - $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + - $ MAX( L + MNOBR, LNOBR + - $ MAX( 3*LNOBR + 1, M ) ) ) - ELSE - IF( .NOT.N4SID ) - $ IAW = N + NN - END IF -C - IF( .NOT.MOESP .OR. WITHCO ) THEN - MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), - $ ID + 4*MNOBRN + 1, ID + MNOBRN + NPL ) - IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB ) - $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + - $ MAX( NPL**2, 4*M*NPL + 1 ) ) - MINWRK = LNOBR*N + MINWRK - END IF -C - IF( WITHK ) THEN - MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ), - $ 14*NN + 12*N + 5 ) - END IF -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -30 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01BD', -INFO ) - RETURN - END IF -C - IF ( .NOT.WITHK ) THEN - JOBCV = JOBCK - ELSE - JOBCV = 'C' - END IF -C - IO = 1 - IF ( .NOT.MOESP .OR. WITHCO ) THEN - JWORK = IO + LNOBR*N - ELSE - JWORK = IO - END IF - MAXWRK = MINWRK -C -C Call the computational routine for estimating system matrices. -C - IF ( .NOT.COMBIN ) THEN - CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR, - $ A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY, - $ S, LDS, DWORK(IO), LNOBR, TOL, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO ) -C - ELSE -C - IF ( WITHC ) THEN - IF ( WITHAL ) THEN - JOBCOV = 'N' - ELSE - JOBCOV = JOBCV - END IF - CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L, - $ NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD, - $ Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR, - $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, - $ IWARNL, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - IWARN = MAX( IWARN, IWARNL ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF ( WITHB ) THEN - IF ( .NOT.WITHAL ) THEN - JOBBD = JOB - ELSE - JOBBD = 'D' - END IF - CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R, - $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, - $ RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO ) - IWARN = MAX( IWARN, IWARNL ) - END IF - END IF -C - IF ( INFO.NE.0 ) - $ RETURN - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - DO 10 I = 1, 4 - RCND(I) = DWORK(JWORK+I) - 10 CONTINUE -C - IF ( WITHK ) THEN - IF ( IWARN.EQ.5 ) THEN -C -C The problem seems to be a deterministic one. Set the Kalman -C gain to zero, set accuracy parameters and return. -C - CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK ) -C - DO 20 I = 6, 12 - DWORK(I) = ONE - 20 CONTINUE -C - DWORK(13) = ZERO - ELSE -C -C Compute the Kalman gain matrix. -C -C Convert the optimal problem with coupling weighting terms -C to a standard problem. -C Workspace: need 4*N*N+2*N*L+L*L+max( 3*L,N*L ); -C prefer larger. -C - IX = 1 - IQ = IX + NN - IA = IQ + NN - IG = IA + NN - IC = IG + NN - IR = IC + NL - IS = IR + LL - JWORK = IS + NL -C - CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) - CALL DLACPY( 'Upper', N, N, Q, LDQ, DWORK(IQ), N ) - CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) - CALL DLACPY( 'Full', N, L, S, LDS, DWORK(IS), N ) -C - CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored', - $ 'Upper', N, L, DWORK(IA), N, DWORK(IC), N, - $ DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N, - $ IWORK, IFACT, DWORK(IG), N, IWORK(L+1), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 3 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - RCONDR = DWORK(JWORK+1) -C -C Solve the Riccati equation. -C Workspace: need 14*N*N+12*N+5; -C prefer larger. -C - IT = IC - IV = IT + NN - IWR = IV + NN - IWI = IWR + N2 - IS = IWI + N2 - JWORK = IS + N2*N2 -C - CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose', - $ 'Upper', 'General scaling', 'Unstable first', - $ 'Not factored', 'Reduced', N, DWORK(IA), N, - $ DWORK(IT), N, DWORK(IV), N, DWORK(IG), N, - $ DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR, - $ DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR ) -C - IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN - INFO = IERR + 3 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - DO 30 I = 1, 4 - RCND(I+4) = DWORK(JWORK+I) - 30 CONTINUE -C -C Compute the gain matrix. -C Workspace: need 2*N*N+2*N*L+L*L+3*L; -C prefer larger. -C - IA = IX + NN - IC = IA + NN - IR = IC + NL - IK = IR + LL - JWORK = IK + NL -C - CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) - CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) -C - CALL SB02ND( 'Discrete', 'NotFactored', 'Upper', - $ 'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC), - $ N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N, - $ RNORM, DWORK(IK), L, OUFACT, IWORK(L+1), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C - IF ( IERR.NE.0 ) THEN - IF ( IERR.LE.L+1 ) THEN - INFO = 3 - ELSE IF ( IERR.EQ.L+2 ) THEN - INFO = 10 - END IF - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK ) -C -C Set the accuracy parameters. -C - DWORK(11) = DWORK(JWORK+1) -C - DO 40 I = 6, 9 - DWORK(I) = RCND(I-1) - 40 CONTINUE -C - DWORK(10) = RCONDR - DWORK(12) = RCOND - DWORK(13) = FERR - END IF - END IF -C -C Return optimal workspace in DWORK(1) and the remaining -C reciprocal condition numbers in the next locations. -C - DWORK(1) = MAXWRK -C - DO 50 I = 2, 5 - DWORK(I) = RCND(I-1) - 50 CONTINUE -C - RETURN -C -C *** Last line of IB01BD *** - END diff --git a/slycot/src/IB01CD.f b/slycot/src/IB01CD.f deleted file mode 100644 index 001c6dcc..00000000 --- a/slycot/src/IB01CD.f +++ /dev/null @@ -1,823 +0,0 @@ - SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B, - $ LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V, - $ LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the initial state and, optionally, the system matrices -C B and D of a linear time-invariant (LTI) discrete-time system, -C given the system matrices (A,B,C,D), or (when B and D are -C estimated) only the matrix pair (A,C), and the input and output -C trajectories of the system. The model structure is : -C -C x(k+1) = Ax(k) + Bu(k), k >= 0, -C y(k) = Cx(k) + Du(k), -C -C where x(k) is the n-dimensional state vector (at time k), -C u(k) is the m-dimensional input vector, -C y(k) is the l-dimensional output vector, -C and A, B, C, and D are real matrices of appropriate dimensions. -C The input-output data can internally be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX0 CHARACTER*1 -C Specifies whether or not the initial state should be -C computed, as follows: -C = 'X': compute the initial state x(0); -C = 'N': do not compute the initial state (possibly, -C because x(0) is known to be zero). -C -C COMUSE CHARACTER*1 -C Specifies whether the system matrices B and D should be -C computed or used, as follows: -C = 'C': compute the system matrices B and D, as specified -C by JOB; -C = 'U': use the system matrices B and D, as specified by -C JOB; -C = 'N': do not compute/use the matrices B and D. -C If JOBX0 = 'N' and COMUSE <> 'N', then x(0) is set -C to zero. -C If JOBX0 = 'N' and COMUSE = 'N', then x(0) is -C neither computed nor set to zero. -C -C JOB CHARACTER*1 -C If COMUSE = 'C' or 'U', specifies which of the system -C matrices B and D should be computed or used, as follows: -C = 'B': compute/use the matrix B only (D is known to be -C zero); -C = 'D': compute/use the matrices B and D. -C The value of JOB is irrelevant if COMUSE = 'N' or if -C JOBX0 = 'N' and COMUSE = 'U'. -C The combinations of options, the data used, and the -C returned results, are given in the table below, where -C '*' denotes an irrelevant value. -C -C JOBX0 COMUSE JOB Data used Returned results -C ---------------------------------------------------------- -C X C B A,C,u,y x,B -C X C D A,C,u,y x,B,D -C N C B A,C,u,y x=0,B -C N C D A,C,u,y x=0,B,D -C ---------------------------------------------------------- -C X U B A,B,C,u,y x -C X U D A,B,C,D,u,y x -C N U * - x=0 -C ---------------------------------------------------------- -C X N * A,C,y x -C N N * - - -C ---------------------------------------------------------- -C -C For JOBX0 = 'N' and COMUSE = 'N', the routine just -C sets DWORK(1) to 2 and DWORK(2) to 1, and returns -C (see the parameter DWORK). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). -C NSMP >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; -C NSMP >= N, if JOBX0 = 'X' and COMUSE <> 'C'; -C NSMP >= N*M + a + e, if COMUSE = 'C', -C where a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'; -C e = 0, if JOBX0 = 'X' and JOB = 'B'; -C e = 1, if JOBX0 = 'N' and JOB = 'B'; -C e = M, if JOB = 'D'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If JOBX0 = 'X' or COMUSE = 'C', the leading N-by-N -C part of this array must contain the system state matrix A. -C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this -C array is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C'; -C LDA >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. -C -C B (input or output) DOUBLE PRECISION array, dimension -C (LDB,M) -C If JOBX0 = 'X' and COMUSE = 'U', B is an input -C parameter and, on entry, the leading N-by-M part of this -C array must contain the system input matrix B. -C If COMUSE = 'C', B is an output parameter and, on exit, -C if INFO = 0, the leading N-by-M part of this array -C contains the estimated system input matrix B. -C If min(N,M) = 0, or JOBX0 = 'N' and COMUSE = 'U', -C or COMUSE = 'N', this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N), if M > 0, COMUSE = 'U', JOBX0 = 'X', -C or M > 0, COMUSE = 'C'; -C LDB >= 1, if min(N,M) = 0, or COMUSE = 'N', -C or JOBX0 = 'N' and COMUSE = 'U'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If JOBX0 = 'X' or COMUSE = 'C', the leading L-by-N -C part of this array must contain the system output -C matrix C. -C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this -C array is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= L, if N > 0, and JOBX0 = 'X' or COMUSE = 'C'; -C LDC >= 1, if N = 0, or JOBX0 = 'N' and COMUSE <> 'C'. -C -C D (input or output) DOUBLE PRECISION array, dimension -C (LDD,M) -C If JOBX0 = 'X', COMUSE = 'U', and JOB = 'D', D is an -C input parameter and, on entry, the leading L-by-M part of -C this array must contain the system input-output matrix D. -C If COMUSE = 'C' and JOB = 'D', D is an output -C parameter and, on exit, if INFO = 0, the leading -C L-by-M part of this array contains the estimated system -C input-output matrix D. -C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or -C COMUSE = 'N', or JOB = 'B', this array is not -C referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0, JOBX0 = 'X', COMUSE = 'U', and -C JOB = 'D', or -C if M > 0, COMUSE = 'C', and JOB = 'D'; -C LDD >= 1, if M = 0, or JOBX0 = 'N' and COMUSE = 'U', -C or COMUSE = 'N', or JOB = 'B'. -C -C U (input or input/output) DOUBLE PRECISION array, dimension -C (LDU,M) -C On entry, if COMUSE = 'C', or JOBX0 = 'X' and -C COMUSE = 'U', the leading NSMP-by-M part of this array -C must contain the t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C On exit, if COMUSE = 'C' and JOB = 'D', the leading -C NSMP-by-M part of this array contains details of the -C QR factorization of the t-by-m matrix U, possibly -C computed sequentially (see METHOD). -C If COMUSE = 'C' and JOB = 'B', or COMUSE = 'U', this -C array is unchanged on exit. -C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or -C COMUSE = 'N', this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,NSMP), if M > 0 and COMUSE = 'C' or -C JOBX0 = 'X' and COMUSE = 'U; -C LDU >= 1, if M = 0, or COMUSE = 'N', or -C JOBX0 = 'N' and COMUSE = 'U'. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C On entry, if JOBX0 = 'X' or COMUSE = 'C', the leading -C NSMP-by-L part of this array must contain the t-by-l -C output-data sequence matrix Y, Y = [y_1 y_2 ... y_l]. -C Column j of Y contains the NSMP values of the j-th -C output component for consecutive time increments. -C If JOBX0 = 'N' and COMUSE <> 'C', this array is not -C referenced. -C -C LDY INTEGER -C The leading dimension of the array Y. -C LDY >= MAX(1,NSMP), if JOBX0 = 'X' or COMUSE = 'C; -C LDY >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0 and JOBX0 = 'X', this array contains the -C estimated initial state of the system, x(0). -C If JOBX0 = 'N' and COMUSE = 'C', this array is used as -C workspace and finally it is set to zero. -C If JOBX0 = 'N' and COMUSE = 'U', then x(0) is set to -C zero without any calculations. -C If JOBX0 = 'N' and COMUSE = 'N', this array is not -C referenced. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,N) -C On exit, if INFO = 0 or 2, JOBX0 = 'X' or -C COMUSE = 'C', the leading N-by-N part of this array -C contains the orthogonal matrix V of a real Schur -C factorization of the matrix A. -C If JOBX0 = 'N' and COMUSE <> 'C', this array is not -C referenced. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C; -C LDV >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; a matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then EPS is used -C instead, where EPS is the relative machine precision -C (see LAPACK Library routine DLAMCH). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; -C LIWORK >= N, if JOBX0 = 'X' and COMUSE <> 'C'; -C LIWORK >= N*M + a, if COMUSE = 'C' and JOB = 'B', -C LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D', -C with a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; DWORK(2) contains the reciprocal condition -C number of the triangular factor of the QR factorization of -C the matrix W2, if COMUSE = 'C', or of the matrix -C Gamma, if COMUSE = 'U' (see METHOD); if JOBX0 = 'N' -C and COMUSE <> 'C', DWORK(2) is set to one; -C if COMUSE = 'C', M > 0, and JOB = 'D', DWORK(3) -C contains the reciprocal condition number of the triangular -C factor of the QR factorization of U; denoting -C g = 2, if JOBX0 = 'X' and COMUSE <> 'C' or -C COMUSE = 'C' and M = 0 or JOB = 'B', -C g = 3, if COMUSE = 'C' and M > 0 and JOB = 'D', -C then DWORK(i), i = g+1:g+N*N, -C DWORK(j), j = g+1+N*N:g+N*N+L*N, and -C DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M, -C contain the transformed system matrices At, Ct, and Bt, -C respectively, corresponding to the real Schur form of the -C given system state matrix A, i.e., -C At = V'*A*V, Bt = V'*B, Ct = C*V. -C The matrices At, Ct, Bt are not computed if JOBX0 = 'N' -C and COMUSE <> 'C'. -C On exit, if INFO = -26, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2, if JOBX0 = 'N' and COMUSE <> 'C', or -C if max( N, M ) = 0. -C Otherwise, -C LDWORK >= LDW1 + N*( N + M + L ) + -C max( 5*N, LDW1, min( LDW2, LDW3 ) ), -C where, if COMUSE = 'C', then -C LDW1 = 2, if M = 0 or JOB = 'B', -C LDW1 = 3, if M > 0 and JOB = 'D', -C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), -C LDW2 = LDWa, if M = 0 or JOB = 'B', -C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C LDWb = (b + r)*(r + 1) + -C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), -C LDW3 = LDWb, if M = 0 or JOB = 'B', -C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C r = N*M + a, -C a = 0, if JOBX0 = 'N', -C a = N, if JOBX0 = 'X'; -C b = 0, if JOB = 'B', -C b = L*M, if JOB = 'D'; -C c = 0, if JOBX0 = 'N', -C c = L*N, if JOBX0 = 'X'; -C d = 0, if JOBX0 = 'N', -C d = 2*N*N + N, if JOBX0 = 'X'; -C f = 2*r, if JOB = 'B' or M = 0, -C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; -C q = b + r*L; -C and, if JOBX0 = 'X' and COMUSE <> 'C', then -C LDW1 = 2, -C LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), -C LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N, -C 4*N ), -C q = N*L. -C For good performance, LDWORK should be larger. -C If LDWORK >= LDW2, or if COMUSE = 'C' and -C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + -C max( d, f ), -C then standard QR factorizations of the matrices U and/or -C W2, if COMUSE = 'C', or of the matrix Gamma, if -C JOBX0 = 'X' and COMUSE <> 'C' (see METHOD), are used. -C Otherwise, the QR factorizations are computed sequentially -C by performing NCYCLE cycles, each cycle (except possibly -C the last one) processing s < t samples, where s is -C chosen by equating LDWORK to the first term of LDWb, -C if COMUSE = 'C', or of LDW3, if COMUSE <> 'C', for -C q replaced by s*L. (s is larger than or equal to the -C minimum value of NSMP.) The computational effort may -C increase and the accuracy may slightly decrease with the -C decrease of s. Recommended value is LDWORK = LDW2, -C assuming a large enough cache size, to also accommodate -C A, (B,) C, (D,) U, and Y. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix; -C = 6: the matrix A is unstable; the estimated x(0) -C and/or B and D could be inaccurate. -C NOTE: the value 4 of IWARN has no significance for the -C identification problem. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the QR algorithm failed to compute all the -C eigenvalues of the matrix A (see LAPACK Library -C routine DGEES); the locations DWORK(i), for -C i = g+1:g+N*N, contain the partially converged -C Schur form; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C Matrix A is initially reduced to a real Schur form, A = V*At*V', -C and the given system matrices are transformed accordingly. For the -C reduced system, an extension and refinement of the method in [1,2] -C is used. Specifically, for JOBX0 = 'X', COMUSE = 'C', and -C JOB = 'D', denoting -C -C X = [ vec(D')' vec(B)' x0' ]', -C -C where vec(M) is the vector obtained by stacking the columns of -C the matrix M, then X is the least squares solution of the -C system S*X = vec(Y), with the matrix S = [ diag(U) W ], -C defined by -C -C ( U | | ... | | | ... | | ) -C ( U | 11 | ... | n1 | 12 | ... | nm | ) -C S = ( : | y | ... | y | y | ... | y | P*Gamma ), -C ( : | | ... | | | ... | | ) -C ( U | | ... | | | ... | | ) -C ij -C diag(U) having L block rows and columns. In this formula, y -C are the outputs of the system for zero initial state computed -C using the following model, for j = 1:m, and for i = 1:n, -C ij ij ij -C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, -C -C ij ij -C y (k) = Cx (k), -C -C where e_i is the i-th n-dimensional unit vector, Gamma is -C given by -C -C ( C ) -C ( C*A ) -C Gamma = ( C*A^2 ), -C ( : ) -C ( C*A^(t-1) ) -C -C and P is a permutation matrix that groups together the rows of -C Gamma depending on the same row of C, namely -C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. -C The first block column, diag(U), is not explicitly constructed, -C but its structure is exploited. The last block column is evaluated -C using powers of A with exponents 2^k. No interchanges are applied. -C A special QR decomposition of the matrix S is computed. Let -C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where -C r is M-by-M. Then, diag(q') is applied to W and vec(Y). -C The block-rows of S and vec(Y) are implicitly permuted so that -C matrix S becomes -C -C ( diag(r) W1 ) -C ( 0 W2 ), -C -C where W1 has L*M rows. Then, the QR decomposition of W2 is -C computed (sequentially, if M > 0) and used to obtain B and x0. -C The intermediate results and the QR decomposition of U are -C needed to find D. If a triangular factor is too ill conditioned, -C then singular value decomposition (SVD) is employed. SVD is not -C generally needed if the input sequence is sufficiently -C persistently exciting and NSMP is large enough. -C If the matrix W cannot be stored in the workspace (i.e., -C LDWORK < LDW2), the QR decompositions of W2 and U are -C computed sequentially. -C For JOBX0 = 'N' and COMUSE = 'C', or JOB = 'B', a simpler -C problem is solved efficiently. -C -C For JOBX0 = 'X' and COMUSE <> 'C', a simpler method is used. -C Specifically, the output y0(k) of the system for zero initial -C state is computed for k = 0, 1, ..., t-1 using the given model. -C Then the following least squares problem is solved for x(0) -C -C ( y(0) - y0(0) ) -C ( y(1) - y0(1) ) -C Gamma * x(0) = ( : ). -C ( : ) -C ( y(t-1) - y0(t-1) ) -C -C The coefficient matrix Gamma is evaluated using powers of A with -C exponents 2^k. The QR decomposition of this matrix is computed. -C If its triangular factor R is too ill conditioned, then singular -C value decomposition of R is used. -C If the coefficient matrix cannot be stored in the workspace (i.e., -C LDWORK < LDW2), the QR decomposition is computed sequentially. -C -C -C REFERENCES -C -C [1] Verhaegen M., and Varga, A. -C Some Experience with the MOESP Class of Subspace Model -C Identification Methods in Identifying the BO105 Helicopter. -C Report TR R165-94, DLR Oberpfaffenhofen, 1994. -C -C [2] Sima, V., and Varga, A. -C RASP-IDENT : Subspace Model Identification Programs. -C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., -C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C FURTHER COMMENTS -C -C The algorithm for computing the system matrices B and D is -C less efficient than the MOESP or N4SID algorithms implemented in -C SLICOT Library routines IB01BD/IB01PD, because a large least -C squares problem has to be solved, but the accuracy is better, as -C the computed matrices B and D are fitted to the input and -C output trajectories. However, if matrix A is unstable, the -C computed matrices B and D could be inaccurate. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, LDV, - $ LDWORK, LDY, M, N, NSMP - CHARACTER COMUSE, JOB, JOBX0 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), U(LDU, *), V(LDV, *), X0(*), - $ Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, RCONDU - INTEGER I, IA, IB, IC, IERR, IQ, ISIZE, ITAU, IWARNL, - $ IWI, IWR, JWORK, LDW, LDW2, LDW3, LM, LN, - $ MAXWRK, MINSMP, MINWLS, MINWRK, MTMP, N2M, - $ NCOL, NCP1, NM, NN, NSMPL - LOGICAL COMPBD, USEBD, MAXDIA, MAXDIM, WITHB, WITHD, - $ WITHX0 - CHARACTER JOBD -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD, - $ TB01WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C -C Check the input parameters. -C - WITHX0 = LSAME( JOBX0, 'X' ) - COMPBD = LSAME( COMUSE, 'C' ) - USEBD = LSAME( COMUSE, 'U' ) - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD - MAXDIA = WITHX0 .OR. COMPBD -C - IWARN = 0 - INFO = 0 - LDW = MAX( 1, N ) - LM = L*M - LN = L*N - NN = N*N - NM = N*M - N2M = N*NM - IF( COMPBD ) THEN - NCOL = NM - IF( WITHX0 ) - $ NCOL = NCOL + N - MINSMP = NCOL - IF( WITHD ) THEN - MINSMP = MINSMP + M - IQ = MINSMP - ELSE IF ( .NOT.WITHX0 ) THEN - IQ = MINSMP - MINSMP = MINSMP + 1 - ELSE - IQ = MINSMP - END IF - ELSE - NCOL = N - IF( WITHX0 ) THEN - MINSMP = N - ELSE - MINSMP = 0 - END IF - IQ = MINSMP - END IF -C - IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.WITHB ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( L.LE.0 ) THEN - INFO = -6 - ELSE IF( NSMP.LT.MINSMP ) THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) ) - $ THEN - INFO = -11 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) ) - $ THEN - INFO = -13 - ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND. - $ LDD.LT.L ) ) THEN - INFO = -15 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) ) - $ THEN - INFO = -17 - ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN - INFO = -19 - ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN - INFO = -22 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -23 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN - MINWRK = 2 - ELSE - NSMPL = NSMP*L - IQ = IQ*L - NCP1 = NCOL + 1 - ISIZE = NSMPL*NCP1 - IF ( COMPBD ) THEN - IF ( N.GT.0 .AND. WITHX0 ) THEN - IC = 2*NN + N - ELSE - IC = 0 - END IF - ELSE - IC = 2*NN - END IF - MINWLS = NCOL*NCP1 - IF ( COMPBD ) THEN - IF ( WITHD ) - $ MINWLS = MINWLS + LM*NCP1 - IF ( M.GT.0 .AND. WITHD ) THEN - IA = M + MAX( 2*NCOL, M ) - ELSE - IA = 2*NCOL - END IF - ITAU = N2M + MAX( IC, IA ) - IF ( WITHX0 ) - $ ITAU = ITAU + LN - LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) - LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) - IF ( M.GT.0 .AND. WITHD ) THEN - LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) - LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) - IA = 3 - ELSE - IA = 2 - END IF - ELSE - ITAU = IC + LN - LDW2 = ISIZE + 2*N + MAX( IC, 4*N ) - LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) - IA = 2 - END IF - MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) ) -C - IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN - MAXWRK = MAX( 5*N, IA ) - IF ( COMPBD ) THEN - IF ( M.GT.0 .AND. WITHD ) THEN - MAXWRK = MAX( MAXWRK, ISIZE + N + M + - $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, - $ M, -1, -1 ), - $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', - $ ' ', NSMP-M, NCOL, -1, -1 ) ) ) - MAXWRK = MAX( MAXWRK, ISIZE + N + M + - $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', - $ NSMP, NCP1, M, -1 ), - $ NCOL + ILAENV( 1, 'DORMQR', 'LT', - $ NSMP-M, 1, NCOL, -1 ) ) ) - ELSE - MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL + - $ MAX( NCOL*ILAENV( 1, 'DGEQRF', - $ ' ', NSMPL, NCOL, -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT', - $ NSMPL, 1, NCOL, -1 ) ) ) - END IF - ELSE - MAXWRK = MAX( MAXWRK, ISIZE + 2*N + - $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', - $ NSMPL, N, -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT', - $ NSMPL, 1, N, -1 ) ) ) - END IF - MAXWRK = IA + NN + NM + LN + MAXWRK - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF - END IF -C - IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN - INFO = -26 - DWORK(1) = MINWRK - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN - DWORK(2) = ONE - IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN - DWORK(1) = THREE - DWORK(3) = ONE - ELSE - DWORK(1) = TWO - END IF - IF ( N.GT.0 .AND. USEBD ) THEN - DUM(1) = ZERO - CALL DCOPY( N, DUM, 0, X0, 1 ) - END IF - RETURN - END IF -C -C Compute the Schur factorization of A and transform the other -C given system matrices accordingly. -C Workspace: need g + N*N + L*N + N*M + 5*N, where -C g = 2, if M = 0, COMUSE = 'C', or JOB = 'B', -C g = 3, if M > 0, COMUSE = 'C', and JOB = 'D', -C g = 2, if JOBX0 = 'X' and COMUSE <> 'C'; -C prefer larger. -C - IA = IA + 1 - IC = IA + NN - IB = IC + LN - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW ) - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L ) -C - IF ( USEBD ) THEN - MTMP = M - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW ) - ELSE - MTMP = 0 - END IF - IWR = IB + NM - IWI = IWR + N - JWORK = IWI + N -C - CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW, - $ DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 1 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) -C - DO 10 I = IWR, IWI - 1 - IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE ) - $ IWARN = 6 - 10 CONTINUE -C - JWORK = IWR -C -C Estimate x(0) and/or the system matrices B and D. -C Workspace: need g + N*N + L*N + N*M + -C max( g, min( LDW2, LDW3 ) ) (see LDWORK); -C prefer larger. -C - IF ( COMPBD ) THEN - CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW, - $ DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW, - $ D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, - $ IWARNL, INFO ) -C - IF( INFO.EQ.0 ) THEN - IF ( M.GT.0 .AND. WITHD ) - $ RCONDU = DWORK(JWORK+2) -C -C Compute the system input matrix B corresponding to the -C original system. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE, - $ V, LDV, DWORK(IB), LDW, ZERO, B, LDB ) - END IF - ELSE - IF ( WITHD ) THEN - JOBD = 'N' - ELSE - JOBD = 'Z' - END IF -C - CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB), - $ LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0, - $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL, - $ INFO ) - END IF - IWARN = MAX( IWARN, IWARNL ) -C - IF( INFO.EQ.0 ) THEN - RCOND = DWORK(JWORK+1) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF( WITHX0 ) THEN -C -C Transform the initial state estimate to obtain the initial -C state corresponding to the original system. -C Workspace: need g + N*N + L*N + N*M + N. -C - CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO, - $ DWORK(JWORK), 1 ) - CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 ) - END IF -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND - IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) - $ DWORK(3) = RCONDU - END IF - RETURN -C -C *** End of IB01CD *** - END diff --git a/slycot/src/IB01MD.f b/slycot/src/IB01MD.f deleted file mode 100644 index d76b4af3..00000000 --- a/slycot/src/IB01MD.f +++ /dev/null @@ -1,1433 +0,0 @@ - SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, - $ LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct an upper triangular factor R of the concatenated -C block Hankel matrices using input-output data. The input-output -C data can, optionally, be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C ALG CHARACTER*1 -C Specifies the algorithm for computing the triangular -C factor R, as follows: -C = 'C': Cholesky algorithm applied to the correlation -C matrix of the input-output data; -C = 'F': Fast QR algorithm; -C = 'Q': QR algorithm applied to the concatenated block -C Hankel matrices. -C -C BATCH CHARACTER*1 -C Specifies whether or not sequential data processing is to -C be used, and, for sequential processing, whether or not -C the current data block is the first block, an intermediate -C block, or the last block, as follows: -C = 'F': the first block in sequential data processing; -C = 'I': an intermediate block in sequential data -C processing; -C = 'L': the last block in sequential data processing; -C = 'O': one block only (non-sequential data processing). -C NOTE that when 100 cycles of sequential data processing -C are completed for BATCH = 'I', a warning is -C issued, to prevent for an infinite loop. -C -C CONCT CHARACTER*1 -C Specifies whether or not the successive data blocks in -C sequential data processing belong to a single experiment, -C as follows: -C = 'C': the current data block is a continuation of the -C previous data block and/or it will be continued -C by the next data block; -C = 'N': there is no connection between the current data -C block and the previous and/or the next ones. -C This parameter is not used if BATCH = 'O'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices to be processed. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C When M = 0, no system inputs are processed. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). (When sequential data processing is used, -C NSMP is the number of samples of the current data -C block.) -C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential -C processing; -C NSMP >= 2*NOBR, for sequential processing. -C The total number of samples when calling the routine with -C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. -C The NSMP argument may vary from a cycle to another in -C sequential data processing, but NOBR, M, and L should -C be kept constant. For efficiency, it is advisable to use -C NSMP as large as possible. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NSMP-by-M part of this array must contain the -C t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= NSMP, if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= NSMP. -C -C R (output or input/output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F', -C and BATCH = 'L' or 'O'), the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of -C this array contains the (current) upper triangular factor -C R from the QR factorization of the concatenated block -C Hankel matrices. The diagonal elements of R are positive -C when the Cholesky algorithm was successfully used. -C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the current upper triangular part of the -C correlation matrix in sequential data processing. -C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not -C referenced. -C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or -C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper -C triangular part of this array must contain the upper -C triangular matrix R computed at the previous call of this -C routine in sequential data processing. The array R need -C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= M+L, if ALG = 'F'; -C LIWORK >= 0, if ALG = 'C' or 'Q'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C Let -C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; -C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; -C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; -C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. -C The first (M+L)*k elements of DWORK should be preserved -C during successive calls of the routine with BATCH = 'F' -C or 'I', till the final call with BATCH = 'L'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and -C CONCT = 'C'; -C LDWORK >= 1, if ALG = 'C', BATCH = 'O' or -C CONCT = 'N'; -C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', -C BATCH <> 'O' and CONCT = 'C'; -C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', -C BATCH = 'F', 'I' and CONCT = 'N'; -C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', -C BATCH = 'L' and CONCT = 'N', or -C BATCH = 'O'; -C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', -C and LDR >= NS = NSMP - 2*NOBR + 1; -C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', -C and LDR < NS, or BATCH = 'I' or -C 'L' and CONCT = 'N'; -C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' -C or 'L' and CONCT = 'C'. -C The workspace used for ALG = 'Q' is -C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, -C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended -C value LDRWRK = NS, assuming a large enough cache size. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the number of 100 cycles in sequential data -C processing has been exhausted without signaling -C that the last block of data was get; the cycle -C counter was reinitialized; -C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), -C but it failed, and the QR algorithm was then used -C (non-sequential data processing). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: a fast algorithm was requested (ALG = 'C', or 'F') -C in sequential data processing, but it failed. The -C routine can be repeatedly called again using the -C standard QR algorithm. -C -C METHOD -C -C 1) For non-sequential data processing using QR algorithm, a -C t x 2(m+l)s matrix H is constructed, where -C -C H = [ Uf' Up' Y' ], for METH = 'M', -C s+1,2s,t 1,s,t 1,2s,t -C -C H = [ U' Y' ], for METH = 'N', -C 1,2s,t 1,2s,t -C -C and Up , Uf , U , and Y are block Hankel -C 1,s,t s+1,2s,t 1,2s,t 1,2s,t -C matrices defined in terms of the input and output data [3]. -C A QR factorization is used to compress the data. -C The fast QR algorithm uses a QR factorization which exploits -C the block-Hankel structure. Actually, the Cholesky factor of H'*H -C is computed. -C -C 2) For sequential data processing using QR algorithm, the QR -C decomposition is done sequentially, by updating the upper -C triangular factor R. This is also performed internally if the -C workspace is not large enough to accommodate an entire batch. -C -C 3) For non-sequential or sequential data processing using -C Cholesky algorithm, the correlation matrix of input-output data is -C computed (sequentially, if requested), taking advantage of the -C block Hankel structure [7]. Then, the Cholesky factor of the -C correlation matrix is found, if possible. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Peternell, K., Scherrer, W. and Deistler, M. -C Statistical Analysis of Novel Subspace Identification Methods. -C Signal Processing, 52, pp. 161-177, 1996. -C -C [6] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C [7] Sima, V. -C Cholesky or QR Factorization for Data Compression in -C Subspace-based Identification ? -C Proceedings of the Second NICONET Workshop on ``Numerical -C Control Software: SLICOT, a Useful Tool in Industry'', -C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable (when QR algorithm is -C used), reliable and efficient. The fast Cholesky or QR algorithms -C are more efficient, but the accuracy could diminish by forming the -C correlation matrix. -C 2 -C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. -C 2 3 -C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating -C point operations. -C 2 3 2 -C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating -C point operations. -C -C FURTHER COMMENTS -C -C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the -C calculations could be rather inefficient if only minimal workspace -C (see argument LDWORK) is provided. It is advisable to provide as -C much workspace as possible. Almost optimal efficiency can be -C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the -C cache size is large enough to accommodate R, U, Y, and DWORK. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C Feb. 2000, Aug. 2000, Feb. 2004. -C -C KEYWORDS -C -C Cholesky decomposition, Hankel matrix, identification methods, -C multivariable systems, QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER MAXCYC - PARAMETER ( MAXCYC = 100 ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, - $ NSMP - CHARACTER ALG, BATCH, CONCT, METH -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) -C .. Local Scalars .. - DOUBLE PRECISION UPD, TEMP - INTEGER I, ICOL, ICYCLE, ID, IERR, II, INICYC, INIT, - $ INITI, INU, INY, IREV, ISHFT2, ISHFTU, ISHFTY, - $ ITAU, J, JD, JWORK, LDRWMX, LDRWRK, LLDRW, - $ LMNOBR, LNOBR, MAXWRK, MINWRK, MLDRW, MMNOBR, - $ MNOBR, NCYCLE, NICYCL, NOBR2, NOBR21, NOBRM1, - $ NR, NS, NSF, NSL, NSLAST, NSMPSM - LOGICAL CHALG, CONNEC, FIRST, FQRALG, INTERM, LAST, - $ LINR, MOESP, N4SID, ONEBCH, QRALG -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DGER, DLACPY, - $ DLASET, DPOTRF, DSWAP, DSYRK, IB01MY, MB04OD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Save Statement .. -C ICYCLE is used to count the cycles for BATCH = 'I'. It is -C reinitialized at each MAXCYC cycles. -C MAXWRK is used to store the optimal workspace. -C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. - SAVE ICYCLE, MAXWRK, NSMPSM -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - FQRALG = LSAME( ALG, 'F' ) - QRALG = LSAME( ALG, 'Q' ) - CHALG = LSAME( ALG, 'C' ) - ONEBCH = LSAME( BATCH, 'O' ) - FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH - INTERM = LSAME( BATCH, 'I' ) - LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH - IF( .NOT.ONEBCH ) THEN - CONNEC = LSAME( CONCT, 'C' ) - ELSE - CONNEC = .FALSE. - END IF -C - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - MMNOBR = MNOBR + MNOBR - NOBRM1 = NOBR - 1 - NOBR21 = NOBR + NOBRM1 - NOBR2 = NOBR21 + 1 - IWARN = 0 - INFO = 0 - IERR = 0 - IF( FIRST ) THEN - ICYCLE = 1 - MAXWRK = 1 - NSMPSM = 0 - END IF - NSMPSM = NSMPSM + NSMP - NR = LMNOBR + LMNOBR -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN - INFO = -2 - ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN - INFO = -3 - ELSE IF( .NOT. ONEBCH ) THEN - IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) - $ INFO = -4 - END IF - IF( INFO.EQ.0 ) THEN - IF( NOBR.LE.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LE.0 ) THEN - INFO = -7 - ELSE IF( NSMP.LT.NOBR2 .OR. - $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN - INFO = -8 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -10 - ELSE IF( LDY.LT.NSMP ) THEN - INFO = -12 - ELSE IF( LDR.LT.NR ) THEN - INFO = -14 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe -C the minimal amount of workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - NS = NSMP - NOBR21 - IF ( CHALG ) THEN - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = 2*( NR - M - L ) - ELSE - MINWRK = 1 - END IF - ELSE IF ( FQRALG ) THEN - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = NR*( M + L + 3 ) - ELSE IF ( FIRST .OR. INTERM ) THEN - MINWRK = NR*( M + L + 1 ) - ELSE - MINWRK = 2*NR*( M + L + 1 ) + NR - END IF - ELSE - MINWRK = 2*NR - MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, - $ -1 ) - IF ( FIRST ) THEN - IF ( LDR.LT.NS ) THEN - MINWRK = MINWRK + NR - MAXWRK = NS*NR + MAXWRK - END IF - ELSE - IF ( CONNEC ) THEN - MINWRK = MINWRK*( NOBR + 1 ) - ELSE - MINWRK = MINWRK + NR - END IF - MAXWRK = NS*NR + MAXWRK - END IF - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -17 - DWORK( 1 ) = MINWRK - END IF - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01MD', -INFO ) - RETURN - END IF -C - IF ( CHALG ) THEN -C -C Compute the R factor from a Cholesky factorization of the -C input-output data correlation matrix. -C -C Set the parameters for constructing the correlations of the -C current block. -C - LDRWRK = 2*NOBR2 - 2 - IF( FIRST ) THEN - UPD = ZERO - ELSE - UPD = ONE - END IF -C - IF( .NOT.FIRST .AND. CONNEC ) THEN -C -C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of -C U and Y into their appropriate position in sequential -C processing. The process is performed column-wise, in -C reverse order, first for Y and then for U. -C Workspace: need (4*NOBR-2)*(M+L). -C - IREV = NR - M - L - NOBR21 + 1 - ICOL = 2*( NR - M - L ) - LDRWRK + 1 -C - DO 10 J = 2, M + L - DO 5 I = NOBR21 - 1, 0, -1 - DWORK(ICOL+I) = DWORK(IREV+I) - 5 CONTINUE - IREV = IREV - NOBR21 - ICOL = ICOL - LDRWRK - 10 CONTINUE -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR21, M, U, LDU, DWORK(NOBR2), - $ LDRWRK ) - CALL DLACPY( 'Full', NOBR21, L, Y, LDY, - $ DWORK(LDRWRK*M+NOBR2), LDRWRK ) - END IF -C - IF ( M.GT.0 ) THEN -C -C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + -C ... + u_(i+NS-1)*u_(j+NS-1)', -C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, -C NS = NSMP - 2s + 1, and Guu0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed -C till the current block for BATCH = 'I' or 'L'. The matrix -C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The -C upper triangle of the U-U correlations, Guu, is computed -C (or updated) column-wise in the array R, that is, in the -C order Guu(1,1), Guu(1,2), Guu(2,2), ..., Guu(2s,2s). -C Only the submatrices of the first block-row are fully -C computed (or updated). The remaining ones are determined -C exploiting the block-Hankel structure, using the updating -C formula -C -C Guu(i+1,j+1) = Guu0(i+1,j+1) - Guu0(i,j) + Guu(i,j) + -C u_(i+NS)*u_(j+NS)' - u_i*u_j'. -C - IF( .NOT.FIRST ) THEN -C -C Subtract the contribution of the previous block of data -C in sequential processing. The columns must be processed -C in backward order. -C - DO 20 I = NOBR21*M, 1, -1 - CALL DAXPY( I, -ONE, R(1,I), 1, R(M+1,M+I), 1 ) - 20 CONTINUE -C - END IF -C -C Compute/update Guu(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR21, ONE, DWORK, - $ LDRWRK, UPD, R, LDR ) - CALL DSYRK( 'Upper', 'Transpose', M, NS, ONE, U, LDU, UPD, - $ R, LDR ) -C - JD = 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 70 J = 2, NOBR2 - JD = JD + M - ID = M + 1 -C -C Compute/update Guu(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, - $ U, LDU, U(J,1), LDU, UPD, R(1,JD), LDR ) -C -C Compute/update Guu(2:j,j), exploiting the -C block-Hankel structure. -C - IF( FIRST ) THEN -C - DO 30 I = JD - M, JD - 1 - CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) - 30 CONTINUE -C - ELSE -C - DO 40 I = JD - M, JD - 1 - CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) - 40 CONTINUE -C - END IF -C - DO 50 I = 2, J - 1 - CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, - $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) - CALL DGER( M, M, -ONE, U(I-1,1), LDU, U(J-1,1), - $ LDU, R(ID,JD), LDR ) - ID = ID + M - 50 CONTINUE -C - DO 60 I = 1, M - CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -U(J-1,I), U(J-1,1), LDU, - $ R(JD,JD+I-1), 1 ) - 60 CONTINUE -C - 70 CONTINUE -C - ELSE -C - DO 120 J = 2, NOBR2 - JD = JD + M - ID = M + 1 -C -C Compute/update Guu(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR21, - $ ONE, DWORK, LDRWRK, DWORK(J), LDRWRK, UPD, - $ R(1,JD), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, - $ U, LDU, U(J,1), LDU, ONE, R(1,JD), LDR ) -C -C Compute/update Guu(2:j,j) for sequential processing -C with connected blocks, exploiting the block-Hankel -C structure. -C - IF( FIRST ) THEN -C - DO 80 I = JD - M, JD - 1 - CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) - 80 CONTINUE -C - ELSE -C - DO 90 I = JD - M, JD - 1 - CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) - 90 CONTINUE -C - END IF -C - DO 100 I = 2, J - 1 - CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, - $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) - CALL DGER( M, M, -ONE, DWORK(I-1), LDRWRK, - $ DWORK(J-1), LDRWRK, R(ID,JD), LDR ) - ID = ID + M - 100 CONTINUE -C - DO 110 I = 1, M - CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -DWORK((I-1)*LDRWRK+J-1), - $ DWORK(J-1), LDRWRK, R(JD,JD+I-1), 1 ) - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C - IF ( LAST .AND. MOESP ) THEN -C -C Interchange past and future parts for MOESP algorithm. -C (Only the upper triangular parts are interchanged, and -C the (1,2) part is transposed in-situ.) -C - TEMP = R(1,1) - R(1,1) = R(MNOBR+1,MNOBR+1) - R(MNOBR+1,MNOBR+1) = TEMP -C - DO 130 J = 2, MNOBR - CALL DSWAP( J, R(1,J), 1, R(MNOBR+1,MNOBR+J), 1 ) - CALL DSWAP( J-1, R(1,MNOBR+J), 1, R(J,MNOBR+1), LDR ) - 130 CONTINUE -C - END IF -C -C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + -C ... + u_(i+NS-1)*y_(j+NS-1)', -C where u_i' is the i-th row of U, y_j' is the j-th row -C of Y, j = 1 : 2s, i = 1 : 2s, NS = NSMP - 2s + 1, and -C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it -C is the matrix Guy(i,j) computed till the current block for -C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The U-Y -C correlations, Guy, are computed (or updated) column-wise -C in the array R. Only the submatrices of the first block- -C column and block-row are fully computed (or updated). The -C remaining ones are determined exploiting the block-Hankel -C structure, using the updating formula -C -C Guy(i+1,j+1) = Guy0(i+1,j+1) - Guy0(i,j) + Guy(i,j) + -C u_(i+NS)*y(j+NS)' - u_i*y_j'. -C - II = MMNOBR - M - IF( .NOT.FIRST ) THEN -C -C Subtract the contribution of the previous block of data -C in sequential processing. The columns must be processed -C in backward order. -C - DO 140 I = NR - L, MMNOBR + 1, -1 - CALL DAXPY( II, -ONE, R(1,I), 1, R(M+1,L+I), 1 ) - 140 CONTINUE -C - END IF -C -C Compute/update the first block-column of Guy, Guy(i,1). -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 150 I = 1, NOBR2 - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U(I,1), LDU, Y, LDY, UPD, - $ R((I-1)*M+1,MMNOBR+1), LDR ) - 150 CONTINUE -C - ELSE -C - DO 160 I = 1, NOBR2 - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, - $ ONE, DWORK(I), LDRWRK, DWORK(LDRWRK*M+1), - $ LDRWRK, UPD, R((I-1)*M+1,MMNOBR+1), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U(I,1), LDU, Y, LDY, ONE, - $ R((I-1)*M+1,MMNOBR+1), LDR ) - 160 CONTINUE -C - END IF -C - JD = MMNOBR + 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 200 J = 2, NOBR2 - JD = JD + L - ID = M + 1 -C -C Compute/update Guy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U, LDU, Y(J,1), LDY, UPD, R(1,JD), LDR ) -C -C Compute/update Guy(2:2*s,j), exploiting the -C block-Hankel structure. -C - IF( FIRST ) THEN -C - DO 170 I = JD - L, JD - 1 - CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) - 170 CONTINUE -C - ELSE -C - DO 180 I = JD - L, JD - 1 - CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) - 180 CONTINUE -C - END IF -C - DO 190 I = 2, NOBR2 - CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, - $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) - CALL DGER( M, L, -ONE, U(I-1,1), LDU, Y(J-1,1), - $ LDY, R(ID,JD), LDR ) - ID = ID + M - 190 CONTINUE -C - 200 CONTINUE -C - ELSE -C - DO 240 J = 2, NOBR2 - JD = JD + L - ID = M + 1 -C -C Compute/update Guy(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, - $ ONE, DWORK, LDRWRK, DWORK(LDRWRK*M+J), - $ LDRWRK, UPD, R(1,JD), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, - $ U, LDU, Y(J,1), LDY, ONE, R(1,JD), LDR ) -C -C Compute/update Guy(2:2*s,j) for sequential -C processing with connected blocks, exploiting the -C block-Hankel structure. -C - IF( FIRST ) THEN -C - DO 210 I = JD - L, JD - 1 - CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) - 210 CONTINUE -C - ELSE -C - DO 220 I = JD - L, JD - 1 - CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) - 220 CONTINUE -C - END IF -C - DO 230 I = 2, NOBR2 - CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, - $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) - CALL DGER( M, L, -ONE, DWORK(I-1), LDRWRK, - $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), - $ LDR ) - ID = ID + M - 230 CONTINUE -C - 240 CONTINUE -C - END IF -C - IF ( LAST .AND. MOESP ) THEN -C -C Interchange past and future parts of U-Y correlations -C for MOESP algorithm. -C - DO 250 J = MMNOBR + 1, NR - CALL DSWAP( MNOBR, R(1,J), 1, R(MNOBR+1,J), 1 ) - 250 CONTINUE -C - END IF - END IF -C -C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + -C y_(i+NS-1)*y_(i+NS-1)', -C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, -C NS = NSMP - 2s + 1, and Gyy0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till -C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, -C and Gyy(j,j) is symmetric. The upper triangle of the Y-Y -C correlations, Gyy, is computed (or updated) column-wise in -C the corresponding part of the array R, that is, in the order -C Gyy(1,1), Gyy(1,2), Gyy(2,2), ..., Gyy(2s,2s). Only the -C submatrices of the first block-row are fully computed (or -C updated). The remaining ones are determined exploiting the -C block-Hankel structure, using the updating formula -C -C Gyy(i+1,j+1) = Gyy0(i+1,j+1) - Gyy0(i,j) + Gyy(i,j) + -C y_(i+NS)*y_(j+NS)' - y_i*y_j'. -C - JD = MMNOBR + 1 -C - IF( .NOT.FIRST ) THEN -C -C Subtract the contribution of the previous block of data -C in sequential processing. The columns must be processed in -C backward order. -C - DO 260 I = NR - L, MMNOBR + 1, -1 - CALL DAXPY( I-MMNOBR, -ONE, R(JD,I), 1, R(JD+L,L+I), 1 ) - 260 CONTINUE -C - END IF -C -C Compute/update Gyy(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR21, ONE, - $ DWORK(LDRWRK*M+1), LDRWRK, UPD, R(JD,JD), LDR ) - CALL DSYRK( 'Upper', 'Transpose', L, NS, ONE, Y, LDY, UPD, - $ R(JD,JD), LDR ) -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 310 J = 2, NOBR2 - JD = JD + L - ID = MMNOBR + L + 1 -C -C Compute/update Gyy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, - $ LDY, Y(J,1), LDY, UPD, R(MMNOBR+1,JD), LDR ) -C -C Compute/update Gyy(2:j,j), exploiting the block-Hankel -C structure. -C - IF( FIRST ) THEN -C - DO 270 I = JD - L, JD - 1 - CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 270 CONTINUE -C - ELSE -C - DO 280 I = JD - L, JD - 1 - CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 280 CONTINUE -C - END IF -C - DO 290 I = 2, J - 1 - CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), - $ LDY, R(ID,JD), LDR ) - CALL DGER( L, L, -ONE, Y(I-1,1), LDY, Y(J-1,1), LDY, - $ R(ID,JD), LDR ) - ID = ID + L - 290 CONTINUE -C - DO 300 I = 1, L - CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -Y(J-1,I), Y(J-1,1), LDY, R(JD,JD+I-1), - $ 1 ) - 300 CONTINUE -C - 310 CONTINUE -C - ELSE -C - DO 360 J = 2, NOBR2 - JD = JD + L - ID = MMNOBR + L + 1 -C -C Compute/update Gyy(1,j) for sequential processing with -C connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR21, - $ ONE, DWORK(LDRWRK*M+1), LDRWRK, - $ DWORK(LDRWRK*M+J), LDRWRK, UPD, - $ R(MMNOBR+1,JD), LDR ) - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, - $ LDY, Y(J,1), LDY, ONE, R(MMNOBR+1,JD), LDR ) -C -C Compute/update Gyy(2:j,j) for sequential processing -C with connected blocks, exploiting the block-Hankel -C structure. -C - IF( FIRST ) THEN -C - DO 320 I = JD - L, JD - 1 - CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 320 CONTINUE -C - ELSE -C - DO 330 I = JD - L, JD - 1 - CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, - $ R(MMNOBR+L+1,L+I), 1 ) - 330 CONTINUE -C - END IF -C - DO 340 I = 2, J - 1 - CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), - $ LDY, R(ID,JD), LDR ) - CALL DGER( L, L, -ONE, DWORK(LDRWRK*M+I-1), LDRWRK, - $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), - $ LDR ) - ID = ID + L - 340 CONTINUE -C - DO 350 I = 1, L - CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, - $ R(JD,JD+I-1), 1 ) - CALL DAXPY( I, -DWORK(LDRWRK*(M+I-1)+J-1), - $ DWORK(LDRWRK*M+J-1), LDRWRK, R(JD,JD+I-1), - $ 1 ) - 350 CONTINUE -C - 360 CONTINUE -C - END IF -C - IF ( .NOT.LAST ) THEN - IF ( CONNEC ) THEN -C -C For sequential processing with connected data blocks, -C save the remaining ("connection") elements of U and Y -C in the first (M+L)*(2*NOBR-1) locations of DWORK. -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR21, M, U(NS+1,1), LDU, DWORK, - $ NOBR21 ) - CALL DLACPY( 'Full', NOBR21, L, Y(NS+1,1), LDY, - $ DWORK(MMNOBR-M+1), NOBR21 ) - END IF -C -C Return to get new data. -C - ICYCLE = ICYCLE + 1 - IF ( ICYCLE.GT.MAXCYC ) - $ IWARN = 1 - RETURN -C - ELSE -C -C Try to compute the Cholesky factor of the correlation -C matrix. -C - CALL DPOTRF( 'Upper', NR, R, LDR, IERR ) - GO TO 370 - END IF - ELSE IF ( FQRALG ) THEN -C -C Compute the R factor from a fast QR factorization of the -C input-output data correlation matrix. -C - CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, - $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, - $ IERR ) - IF( .NOT.LAST ) - $ RETURN - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - 370 CONTINUE -C - IF( IERR.NE.0 ) THEN -C -C Error return from a fast factorization algorithm of the -C input-output data correlation matrix. -C - IF( ONEBCH ) THEN - QRALG = .TRUE. - IWARN = 2 - MINWRK = 2*NR - MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, - $ -1 ) - IF ( LDR.LT.NS ) THEN - MINWRK = MINWRK + NR - MAXWRK = NS*NR + MAXWRK - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -17 -C -C Return: Not enough workspace. -C - DWORK( 1 ) = MINWRK - CALL XERBLA( 'IB01MD', -INFO ) - RETURN - END IF - ELSE - INFO = 1 - RETURN - END IF - END IF -C - IF ( QRALG ) THEN -C -C Compute the R factor from a QR factorization of the matrix H -C of concatenated block Hankel matrices. -C -C Construct the matrix H. -C -C Set the parameters for constructing the current segment of the -C Hankel matrix, taking the available memory space into account. -C INITI+1 points to the beginning rows of U and Y from which -C data are taken when NCYCLE > 1 inner cycles are needed, -C or for sequential processing with connected blocks. -C LDRWMX is the number of rows that can fit in the working space. -C LDRWRK is the actual number of rows processed in this space. -C NSLAST is the number of samples to be processed at the last -C inner cycle. -C - INITI = 0 - LDRWMX = LDWORK / NR - 2 - NCYCLE = 1 - NSLAST = NSMP - LINR = .FALSE. - IF ( FIRST ) THEN - LINR = LDR.GE.NS - LDRWRK = NS - ELSE IF ( CONNEC ) THEN - LDRWRK = NSMP - ELSE - LDRWRK = NS - END IF - INICYC = 1 -C - IF ( .NOT.LINR ) THEN - IF ( LDRWMX.LT.LDRWRK ) THEN -C -C Not enough working space for doing a single inner cycle. -C NCYCLE inner cycles are to be performed for the current -C data block using the working space. -C - NCYCLE = LDRWRK / LDRWMX - NSLAST = MOD( LDRWRK, LDRWMX ) - IF ( NSLAST.NE.0 ) THEN - NCYCLE = NCYCLE + 1 - ELSE - NSLAST = LDRWMX - END IF - LDRWRK = LDRWMX - NS = LDRWRK - IF ( FIRST ) INICYC = 2 - END IF - MLDRW = M*LDRWRK - LLDRW = L*LDRWRK - INU = MLDRW*NOBR + 1 - INY = MLDRW*NOBR2 + 1 - END IF -C -C Process the data given at the current call. -C - IF ( .NOT.FIRST .AND. CONNEC ) THEN -C -C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of -C U and Y into their appropriate position in sequential -C processing. The process is performed column-wise, in -C reverse order, first for Y and then for U. -C - IREV = NR - M - L - NOBR21 + 1 - ICOL = INY + LLDRW - LDRWRK -C - DO 380 J = 1, L - DO 375 I = NOBR21 - 1, 0, -1 - DWORK(ICOL+I) = DWORK(IREV+I) - 375 CONTINUE - IREV = IREV - NOBR21 - ICOL = ICOL - LDRWRK - 380 CONTINUE -C - IF( MOESP ) THEN - ICOL = INU + MLDRW - LDRWRK - ELSE - ICOL = MLDRW - LDRWRK + 1 - END IF -C - DO 390 J = 1, M - DO 385 I = NOBR21 - 1, 0, -1 - DWORK(ICOL+I) = DWORK(IREV+I) - 385 CONTINUE - IREV = IREV - NOBR21 - ICOL = ICOL - LDRWRK - 390 CONTINUE -C - IF( MOESP ) - $ CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK, - $ DWORK, LDRWRK ) - END IF -C -C Data compression using QR factorization. -C - IF ( FIRST ) THEN -C -C Non-sequential data processing or first block in -C sequential data processing: -C Use the general QR factorization algorithm. -C - IF ( LINR ) THEN -C -C Put the input-output data in the array R. -C - IF( M.GT.0 ) THEN - IF( MOESP ) THEN -C - DO 400 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, - $ R(1,M*(I-1)+1), LDR ) - 400 CONTINUE -C - DO 410 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ R(1,MNOBR+M*(I-1)+1), LDR ) - 410 CONTINUE -C - ELSE -C - DO 420 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ R(1,M*(I-1)+1), LDR ) - 420 CONTINUE -C - END IF - END IF -C - DO 430 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, - $ R(1,MMNOBR+L*(I-1)+1), LDR ) - 430 CONTINUE -C -C Workspace: need 4*(M+L)*NOBR, -C prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB. -C - ITAU = 1 - JWORK = ITAU + NR - CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - ELSE -C -C Put the input-output data in the array DWORK. -C - IF( M.GT.0 ) THEN - ISHFTU = 1 - IF( MOESP ) THEN - ISHFT2 = INU -C - DO 440 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 440 CONTINUE -C - DO 450 I = 1, NOBR - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ DWORK(ISHFT2), LDRWRK ) - ISHFT2 = ISHFT2 + MLDRW - 450 CONTINUE -C - ELSE -C - DO 460 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, M, U(I,1), LDU, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 460 CONTINUE -C - END IF - END IF -C - ISHFTY = INY -C - DO 470 I = 1, NOBR2 - CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, - $ DWORK(ISHFTY), LDRWRK ) - ISHFTY = ISHFTY + LLDRW - 470 CONTINUE -C -C Workspace: need 2*(M+L)*NOBR + 4*(M+L)*NOBR, -C prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR -C + 2*(M+L)*NOBR*NB, -C used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, -C where NS = NSMP - 2*NOBR + 1, -C LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2). -C - ITAU = LDRWRK*NR + 1 - JWORK = ITAU + NR - CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R, - $ LDR ) - END IF -C - IF ( NS.LT.NR ) - $ CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO, - $ R(NS+1,NS+1), LDR ) - INITI = INITI + NS - END IF -C - IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN -C -C Remaining segments of the first data block or -C remaining segments/blocks in sequential data processing: -C Use a structure-exploiting QR factorization algorithm. -C - NSL = LDRWRK - IF ( .NOT.CONNEC ) NSL = NS - ITAU = LDRWRK*NR + 1 - JWORK = ITAU + NR -C - DO 560 NICYCL = INICYC, NCYCLE -C -C INIT denotes the beginning row where new data are put. -C - IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN - INIT = NOBR2 - ELSE - INIT = 1 - END IF - IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN -C -C Last samples in the last data segment of a block. -C - NS = NSLAST - NSL = NSLAST - END IF -C -C Put the input-output data in the array DWORK. -C - NSF = NS - IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21 - IF ( M.GT.0 ) THEN - ISHFTU = INIT -C - IF( MOESP ) THEN - ISHFT2 = INIT + INU - 1 -C - DO 480 I = 1, NOBR - CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1), - $ LDU, DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 480 CONTINUE -C - DO 490 I = 1, NOBR - CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, - $ DWORK(ISHFT2), LDRWRK ) - ISHFT2 = ISHFT2 + MLDRW - 490 CONTINUE -C - ELSE -C - DO 500 I = 1, NOBR2 - CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 500 CONTINUE -C - END IF - END IF -C - ISHFTY = INIT + INY - 1 -C - DO 510 I = 1, NOBR2 - CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY, - $ DWORK(ISHFTY), LDRWRK ) - ISHFTY = ISHFTY + LLDRW - 510 CONTINUE -C - IF ( INIT.GT.1 ) THEN -C -C Prepare the connection to the previous block of data -C in sequential processing. -C - IF( MOESP .AND. M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR), - $ LDRWRK ) -C -C Shift the elements from the connection to the previous -C block of data in sequential processing. -C - IF ( M.GT.0 ) THEN - ISHFTU = MLDRW + 1 -C - IF( MOESP ) THEN - ISHFT2 = MLDRW + INU -C - DO 520 I = 1, NOBRM1 - CALL DLACPY( 'Full', NOBR21, M, - $ DWORK(ISHFTU-MLDRW+1), LDRWRK, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 520 CONTINUE -C - DO 530 I = 1, NOBRM1 - CALL DLACPY( 'Full', NOBR21, M, - $ DWORK(ISHFT2-MLDRW+1), LDRWRK, - $ DWORK(ISHFT2), LDRWRK ) - ISHFT2 = ISHFT2 + MLDRW - 530 CONTINUE -C - ELSE -C - DO 540 I = 1, NOBR21 - CALL DLACPY( 'Full', NOBR21, M, - $ DWORK(ISHFTU-MLDRW+1), LDRWRK, - $ DWORK(ISHFTU), LDRWRK ) - ISHFTU = ISHFTU + MLDRW - 540 CONTINUE -C - END IF - END IF -C - ISHFTY = LLDRW + INY -C - DO 550 I = 1, NOBR21 - CALL DLACPY( 'Full', NOBR21, L, - $ DWORK(ISHFTY-LLDRW+1), LDRWRK, - $ DWORK(ISHFTY), LDRWRK ) - ISHFTY = ISHFTY + LLDRW - 550 CONTINUE -C - END IF -C -C Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR. -C - CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK, - $ DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK) - $ ) - INITI = INITI + NSF - 560 CONTINUE -C - END IF -C - IF ( .NOT.LAST ) THEN - IF ( CONNEC ) THEN -C -C For sequential processing with connected data blocks, -C save the remaining ("connection") elements of U and Y -C in the first (M+L)*(2*NOBR-1) locations of DWORK. -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU, - $ DWORK, NOBR21 ) - CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY, - $ DWORK(MMNOBR-M+1), NOBR21 ) - END IF -C -C Return to get new data. -C - ICYCLE = ICYCLE + 1 - IF ( ICYCLE.LE.MAXCYC ) - $ RETURN - IWARN = 1 - ICYCLE = 1 -C - END IF -C - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK( 1 ) = MAXWRK - IF ( LAST ) THEN - ICYCLE = 1 - MAXWRK = 1 - NSMPSM = 0 - END IF - RETURN -C -C *** Last line of IB01MD *** - END diff --git a/slycot/src/IB01MY.f b/slycot/src/IB01MY.f deleted file mode 100644 index a76f452a..00000000 --- a/slycot/src/IB01MY.f +++ /dev/null @@ -1,1094 +0,0 @@ - SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, - $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct an upper triangular factor R of the concatenated -C block Hankel matrices using input-output data, via a fast QR -C algorithm based on displacement rank. The input-output data can, -C optionally, be processed sequentially. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C BATCH CHARACTER*1 -C Specifies whether or not sequential data processing is to -C be used, and, for sequential processing, whether or not -C the current data block is the first block, an intermediate -C block, or the last block, as follows: -C = 'F': the first block in sequential data processing; -C = 'I': an intermediate block in sequential data -C processing; -C = 'L': the last block in sequential data processing; -C = 'O': one block only (non-sequential data processing). -C NOTE that when 100 cycles of sequential data processing -C are completed for BATCH = 'I', a warning is -C issued, to prevent for an infinite loop. -C -C CONCT CHARACTER*1 -C Specifies whether or not the successive data blocks in -C sequential data processing belong to a single experiment, -C as follows: -C = 'C': the current data block is a continuation of the -C previous data block and/or it will be continued -C by the next data block; -C = 'N': there is no connection between the current data -C block and the previous and/or the next ones. -C This parameter is not used if BATCH = 'O'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices to be processed. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, the -C estimated dimension of state vector.) -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C When M = 0, no system inputs are processed. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). (When sequential data processing is used, -C NSMP is the number of samples of the current data -C block.) -C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential -C processing; -C NSMP >= 2*NOBR, for sequential processing. -C The total number of samples when calling the routine with -C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. -C The NSMP argument may vary from a cycle to another in -C sequential data processing, but NOBR, M, and L should -C be kept constant. For efficiency, it is advisable to use -C NSMP as large as possible. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NSMP-by-M part of this array must contain the -C t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= NSMP, if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= NSMP. -C -C R (output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C If INFO = 0 and BATCH = 'L' or 'O', the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the upper triangular factor R from the -C QR factorization of the concatenated block Hankel -C matrices. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C Workspace -C -C IWORK INTEGER array, dimension (M+L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C The first (M+L)*2*NOBR*(M+L+c) elements of DWORK should -C be preserved during successive calls of the routine -C with BATCH = 'F' or 'I', till the final call with -C BATCH = 'L', where -C c = 1, if the successive data blocks do not belong to a -C single experiment (CONCT = 'N'); -C c = 2, if the successive data blocks belong to a single -C experiment (CONCT = 'C'). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= (M+L)*2*NOBR*(M+L+3), -C if BATCH <> 'O' and CONCT = 'C'; -C LDWORK >= (M+L)*2*NOBR*(M+L+1), -C if BATCH = 'F' or 'I' and CONCT = 'N'; -C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, -C if BATCH = 'L' and CONCT = 'N', -C or BATCH = 'O'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the number of 100 cycles in sequential data -C processing has been exhausted without signaling -C that the last block of data was get. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the fast QR factorization algorithm failed. The -C matrix H'*H is not (numerically) positive definite. -C -C METHOD -C -C Consider the t x 2(m+l)s matrix H of concatenated block Hankel -C matrices -C -C H = [ Uf' Up' Y' ], for METH = 'M', -C s+1,2s,t 1,s,t 1,2s,t -C -C H = [ U' Y' ], for METH = 'N', -C 1,2s,t 1,2s,t -C -C where Up , Uf , U , and Y are block -C 1,s,t s+1,2s,t 1,2s,t 1,2s,t -C Hankel matrices defined in terms of the input and output data [3]. -C The fast QR algorithm uses a factorization of H'*H which exploits -C the block-Hankel structure, via a displacement rank technique [5]. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Kressner, D., Mastronardi, N., Sima, V., Van Dooren, P., and -C Van Huffel, S. -C A Fast Algorithm for Subspace State-space System -C Identification via Exploitation of the Displacement Structure. -C J. Comput. Appl. Math., Vol.132, No.1, pp. 71-81, 2001. -C -C NUMERICAL ASPECTS -C -C The implemented method is reliable and efficient. Numerical -C difficulties are possible when the matrix H'*H is nearly rank -C defficient. The method cannot be used if the matrix H'*H is not -C numerically positive definite. -C 2 3 2 -C The algorithm requires 0(2t(m+l) s)+0(4(m+l) s ) floating point -C operations. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Universiteit Leuven, June 2000. -C Partly based on Matlab codes developed by N. Mastronardi, -C Katholieke Universiteit Leuven, February 2000. -C -C REVISIONS -C -C V. Sima, July 2000, August 2000, Feb. 2004, May 2009. -C -C KEYWORDS -C -C Displacement rank, Hankel matrix, Householder transformation, -C identification methods, multivariable systems. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - INTEGER MAXCYC - PARAMETER ( MAXCYC = 100 ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, - $ NSMP - CHARACTER BATCH, CONCT, METH -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) -C .. Local Scalars .. - DOUBLE PRECISION BETA, CS, SN, UPD, TAU - INTEGER I, ICJ, ICOL, ICONN, ICYCLE, IERR, IMAX, ING, - $ INGC, INGP, IPG, IPGC, IPY, IREV, ITAU, J, JD, - $ JDS, JWORK, K, LDRWRK, LLNOBR, LNOBR, LNRG, - $ MAXWRK, MINWRK, MMNOBR, MNOBR, MNRG, NOBR2, - $ NOBR21, NR, NRG, NS, NSM, NSMPSM - LOGICAL CONNEC, FIRST, INTERM, LAST, MOESP, N4SID, - $ ONEBCH -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLARF, DLARFG, - $ DLASET, DORMQR, DSCAL, DSWAP, DSYRK, MA02ED, - $ MA02FD, MB04ID, MB04OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, SQRT -C .. Save Statement .. -C ICYCLE is used to count the cycles for BATCH = 'I'. -C MAXWRK is used to store the optimal workspace. -C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. - SAVE ICYCLE, MAXWRK, NSMPSM -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - ONEBCH = LSAME( BATCH, 'O' ) - FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH - INTERM = LSAME( BATCH, 'I' ) - LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH - IF( .NOT.ONEBCH ) THEN - CONNEC = LSAME( CONCT, 'C' ) - ELSE - CONNEC = .FALSE. - END IF - MNOBR = M*NOBR - LNOBR = L*NOBR - MMNOBR = MNOBR + MNOBR - LLNOBR = LNOBR + LNOBR - NOBR2 = 2*NOBR - NOBR21 = NOBR2 - 1 - IWARN = 0 - INFO = 0 - IF( FIRST ) THEN - ICYCLE = 1 - MAXWRK = 1 - NSMPSM = 0 - END IF - NSMPSM = NSMPSM + NSMP - NR = MMNOBR + LLNOBR -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN - INFO = -2 - ELSE IF( .NOT. ONEBCH ) THEN - IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) - $ INFO = -3 - END IF - IF( INFO.EQ.0 ) THEN - IF( NOBR.LE.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( L.LE.0 ) THEN - INFO = -6 - ELSE IF( NSMP.LT.NOBR2 .OR. - $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -9 - ELSE IF( LDY.LT.NSMP ) THEN - INFO = -11 - ELSE IF( LDR.LT.NR ) THEN - INFO = -13 - ELSE -C -C Compute workspace. -C NRG is the number of positive (or negative) generators. -C - NRG = M + L + 1 - IF ( .NOT.ONEBCH .AND. CONNEC ) THEN - MINWRK = NR*( NRG + 2 ) - ELSE IF ( FIRST .OR. INTERM ) THEN - MINWRK = NR*NRG - ELSE - MINWRK = 2*NR*NRG + NR - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF( LDWORK.LT.MINWRK ) - $ INFO = -16 - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - NSMPSM = 0 - IF ( INFO.EQ.-16 ) - $ DWORK( 1 ) = MINWRK - CALL XERBLA( 'IB01MY', -INFO ) - RETURN - END IF -C -C Compute the R factor from a fast QR factorization of the -C matrix H, a concatenation of two block Hankel matrices. -C Specifically, a displacement rank technique is applied to -C the block Toeplitz matrix, G = (P*H)'*(P*H), where P is a -C 2-by-2 block diagonal matrix, having as diagonal blocks identity -C matrices with columns taken in the reverse order. -C The technique builds and processes the generators of G. The -C matrices G and G1 = H'*H have the same R factor. -C -C Set the parameters for constructing the correlations of the -C current block. -C NSM is the number of processed samples in U and Y, t - 2s. -C IPG and ING are pointers to the "positive" and "negative" -C generators, stored row-wise in the workspace. All "positive" -C generators are stored before any "negative" generators. -C If BATCH <> 'O' and CONCT = 'C', the "connection" elements of -C two successive batches are stored in the same workspace as the -C "negative" generators (which will be computed later on). -C IPY is a pointer to the Y part of the "positive" generators. -C LDRWRK is used as a leading dimension for the workspace part used -C to store the "connection" elements. -C - NS = NSMP - NOBR21 - NSM = NS - 1 - MNRG = M*NRG - LNRG = L*NRG -C - LDRWRK = 2*NOBR2 - IF( FIRST ) THEN - UPD = ZERO - ELSE - UPD = ONE - END IF - DUM(1) = ZERO -C - IPG = 1 - IPY = IPG + M - ING = IPG + NRG*NR - ICONN = ING -C - IF( .NOT.FIRST .AND. CONNEC ) THEN -C -C Restore the saved (M+L)*2*NOBR "connection" elements of -C U and Y into their appropriate position in sequential -C processing. The process is performed column-wise, in -C reverse order, first for Y and then for U. -C ICONN is a pointer to the first saved "connection" element. -C Workspace: need (M+L)*2*NOBR*(M+L+3). -C - IREV = ICONN + NR - ICOL = ICONN + 2*NR -C - DO 10 I = 2, M + L - IREV = IREV - NOBR2 - ICOL = ICOL - LDRWRK - CALL DCOPY( NOBR2, DWORK(IREV), 1, DWORK(ICOL), 1 ) - 10 CONTINUE -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR2, M, U, LDU, DWORK(ICONN+NOBR2), - $ LDRWRK ) - CALL DLACPY( 'Full', NOBR2, L, Y, LDY, - $ DWORK(ICONN+LDRWRK*M+NOBR2), LDRWRK ) - END IF -C - IF ( M.GT.0 ) THEN -C -C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + -C ... + u_(i+NSM-1)*u_(j+NSM-1)', -C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, -C NSM = NSMP - 2s, and Guu0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed -C till the current block for BATCH = 'I' or 'L'. The matrix -C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The -C submatrices of the first block-row, Guu(1,j), are needed only. -C -C Compute/update Guu(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR2, ONE, - $ DWORK(ICONN), LDRWRK, UPD, DWORK(IPG), NRG ) - CALL DSYRK( 'Upper', 'Transpose', M, NSM, ONE, U, LDU, UPD, - $ DWORK(IPG), NRG ) - CALL MA02ED( 'Upper', M, DWORK(IPG), NRG ) -C - JD = 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 20 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Guu(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, - $ U, LDU, U(J,1), LDU, UPD, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - 20 CONTINUE -C - ELSE -C - DO 30 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Guu(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR2, - $ ONE, DWORK(ICONN), LDRWRK, DWORK(ICONN+J-1), - $ LDRWRK, UPD, DWORK(IPG+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, - $ U, LDU, U(J,1), LDU, ONE, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - 30 CONTINUE -C - END IF -C -C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + -C ... + u_(i+NSM-1)*y_(j+NSM-1)', -C where u_i' is the i-th row of U, y_j' is the j-th row -C of Y, j = 1 : 2s, i = 1 : 2s, NSM = NSMP - 2s, and -C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it -C is the matrix Guy(i,j) computed till the current block for -C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The submatrices -C of the first block-row, Guy(1,j), as well as the transposes -C of the submatrices of the first block-column, i.e., Gyu(1,j), -C are needed only. -C - JD = MMNOBR + 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 40 J = 1, NOBR2 -C -C Compute/update Guy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, - $ U, LDU, Y(J,1), LDY, UPD, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - JD = JD + L - 40 CONTINUE -C - ELSE -C - DO 50 J = 1, NOBR2 -C -C Compute/update Guy(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR2, - $ ONE, DWORK(ICONN), LDRWRK, - $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, - $ U, LDU, Y(J,1), LDY, ONE, - $ DWORK(IPG+(JD-1)*NRG), NRG ) - JD = JD + L - 50 CONTINUE -C - END IF -C -C Now, the first M "positive" generators have been built. -C Transpose Guy(1,1) in the first block of the Y part of the -C "positive" generators. -C - DO 60 J = 1, L - CALL DCOPY( M, DWORK(IPG+(MMNOBR+J-1)*NRG), 1, - $ DWORK(IPY+J-1), NRG ) - 60 CONTINUE -C - JD = 1 -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 70 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Gyu(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, - $ Y, LDY, U(J,1), LDU, UPD, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - 70 CONTINUE -C - ELSE -C - DO 80 J = 2, NOBR2 - JD = JD + M -C -C Compute/update Gyu(1,j) for sequential processing -C with connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NOBR2, - $ ONE, DWORK(ICONN+LDRWRK*M), LDRWRK, - $ DWORK(ICONN+J-1), LDRWRK, UPD, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, - $ Y, LDY, U(J,1), LDU, ONE, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - 80 CONTINUE -C - END IF -C - END IF -C -C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + -C y_(i+NSM-1)*y_(i+NSM-1)', -C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, -C NSM = NSMP - 2s, and Gyy0(i,j) is a zero matrix for -C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till -C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, -C and Gyy(j,j) is symmetric. The submatrices of the first -C block-row, Gyy(1,j), are needed only. -C - JD = MMNOBR + 1 -C -C Compute/update Gyy(1,1). -C - IF( .NOT.FIRST .AND. CONNEC ) - $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR2, ONE, - $ DWORK(ICONN+LDRWRK*M), LDRWRK, UPD, - $ DWORK(IPY+MMNOBR*NRG), NRG ) - CALL DSYRK( 'Upper', 'Transpose', L, NSM, ONE, Y, LDY, UPD, - $ DWORK(IPY+MMNOBR*NRG), NRG ) - CALL MA02ED( 'Upper', L, DWORK(IPY+MMNOBR*NRG), NRG ) -C - IF( FIRST .OR. .NOT.CONNEC ) THEN -C - DO 90 J = 2, NOBR2 - JD = JD + L -C -C Compute/update Gyy(1,j). -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, - $ LDY, Y(J,1), LDY, UPD, DWORK(IPY+(JD-1)*NRG), - $ NRG ) - 90 CONTINUE -C - ELSE -C - DO 100 J = 2, NOBR2 - JD = JD + L -C -C Compute/update Gyy(1,j) for sequential processing with -C connected blocks. -C - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR2, ONE, - $ DWORK(ICONN+LDRWRK*M), LDRWRK, - $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, - $ DWORK(IPY+(JD-1)*NRG), NRG ) - CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, - $ LDY, Y(J,1), LDY, ONE, DWORK(IPY+(JD-1)*NRG), - $ NRG ) - 100 CONTINUE -C - END IF -C - IF ( .NOT.LAST ) THEN - IF ( FIRST ) THEN -C -C For sequential processing, save the first 2*NOBR-1 rows of -C the first block of U and Y in the appropriate -C (M+L)*(2*NOBR-1) locations of DWORK starting at (1+M)*NRG. -C These will be used to construct the last negative generator. -C - JD = NRG - IF ( M.GT.0 ) THEN - CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) -C - DO 110 J = 1, NOBR21 - JD = JD + MNRG - CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) - 110 CONTINUE -C - JD = JD + MNRG - END IF - CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) -C - DO 120 J = 1, NOBR21 - JD = JD + LNRG - CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) - 120 CONTINUE -C - END IF -C - IF ( CONNEC ) THEN -C -C For sequential processing with connected data blocks, -C save the remaining ("connection") elements of U and Y -C in (M+L)*2*NOBR locations of DWORK starting at ICONN. -C - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', NOBR2, M, U(NS,1), LDU, - $ DWORK(ICONN), NOBR2 ) - CALL DLACPY( 'Full', NOBR2, L, Y(NS,1), LDY, - $ DWORK(ICONN+MMNOBR), NOBR2 ) - END IF -C -C Return to get new data. -C - ICYCLE = ICYCLE + 1 - IF ( ICYCLE.GT.MAXCYC ) - $ IWARN = 1 - RETURN - END IF -C - IF ( LAST ) THEN -C -C Try to compute the R factor. -C -C Scale the first M+L positive generators and set the first -C M+L negative generators. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+M+L. -C - JWORK = NRG*2*NR + 1 - CALL DCOPY( M, DWORK(IPG), NRG+1, DWORK(JWORK), 1 ) - CALL DCOPY( L, DWORK(IPY+MMNOBR*NRG), NRG+1, DWORK(JWORK+M), - $ 1 ) -C - DO 130 I = 1, M + L - IWORK(I) = IDAMAX( M+L, DWORK(JWORK), 1 ) - DWORK(JWORK+IWORK(I)-1) = ZERO - 130 CONTINUE -C - DO 150 I = 1, M + L - IMAX = IWORK(I) - IF ( IMAX.LE.M ) THEN - ICOL = IMAX - ELSE - ICOL = MMNOBR - M + IMAX - END IF - BETA = SQRT( ABS( DWORK(IPG+IMAX-1+(ICOL-1)*NRG) ) ) - IF ( BETA.EQ.ZERO ) THEN -C -C Error exit. -C - INFO = 1 - RETURN - END IF - CALL DSCAL( NR, ONE / BETA, DWORK(IPG+IMAX-1), NRG ) - CALL DCOPY( NR, DWORK(IPG+IMAX-1), NRG, DWORK(ING+IMAX-1), - $ NRG ) - DWORK(IPG+IMAX-1+(ICOL-1)*NRG) = BETA - DWORK(ING+IMAX-1+(ICOL-1)*NRG) = ZERO -C - DO 140 J = I + 1, M + L - DWORK(IPG+IWORK(J)-1+(ICOL-1)*NRG) = ZERO - 140 CONTINUE -C - 150 CONTINUE -C -C Compute the last two generators. -C - IF ( .NOT.FIRST ) THEN -C -C For sequential processing, move the stored last negative -C generator. -C - CALL DCOPY( NR, DWORK(NRG), NRG, DWORK(ING+NRG-1), NRG ) - END IF -C - JD = NRG - IF ( M.GT.0 ) THEN -C - DO 160 J = NS, NSMP - CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) - JD = JD + MNRG - 160 CONTINUE -C - END IF -C - DO 170 J = NS, NSMP - CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) - JD = JD + LNRG - 170 CONTINUE -C - IF ( FIRST ) THEN - IF ( M.GT.0 ) THEN - CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) -C - DO 180 J = 1, NOBR21 - JD = JD + MNRG - CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) - 180 CONTINUE -C - JD = JD + MNRG - END IF - CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) -C - DO 190 J = 1, NOBR21 - JD = JD + LNRG - CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) - 190 CONTINUE -C - END IF -C - ITAU = JWORK - IPGC = IPG + MMNOBR*NRG -C - IF ( M.GT.0 ) THEN -C -C Process the input part of the generators. -C - JWORK = ITAU + M -C -C Reduce the first M columns of the matrix G1 of positive -C generators to an upper triangular form. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*M; -C prefer (M+L)*4*NOBR*(M+L+1)+M+M*NB. -C - INGC = ING - CALL DGEQRF( NRG, M, DWORK(IPG), NRG, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR; -C prefer (M+L)*4*NOBR*(M+L+1)+M+ -C ((M+L)*2*NOBR-M)*NB. -C - CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK(IPG), - $ NRG, DWORK(ITAU), DWORK(IPG+MNRG), NRG, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Annihilate, column by column, the first M columns of the -C matrix G2 of negative generators, using Householder -C transformations and modified hyperbolic plane rotations. -C In the DLARF calls, ITAU is a pointer to the workspace -C array. -C - DO 210 J = 1, M - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, NR-J, DWORK(INGC), 1, TAU, - $ DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPG+(J-1)*(NRG+1)), DWORK(INGC), CS, - $ SN, IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 200 I = J*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 200 CONTINUE -C - INGC = INGP - 210 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', M, NR, DWORK(IPG), NRG, R, LDR ) -C - DO 220 I = ( MMNOBR - M )*NRG, MNRG, -MNRG - CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, - $ DWORK(IPG+I), NRG ) - 220 CONTINUE -C - DO 230 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG - CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 230 CONTINUE -C - CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) -C -C Update the input part of generators using Schur algorithm. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*(M+L)-M. -C - JDS = MNRG - ICOL = M -C - DO 280 K = 2, NOBR2 - CALL MB04OD( 'Full', M, NR-ICOL-M, L+1, DWORK(IPG+JDS), - $ NRG, DWORK(IPY+JDS), NRG, - $ DWORK(IPG+JDS+MNRG), NRG, - $ DWORK(IPY+JDS+MNRG), NRG, DWORK(ITAU), - $ DWORK(JWORK) ) -C - DO 250 J = 1, M - ICJ = ICOL + J - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, NR-ICJ, DWORK(INGC), 1, TAU, - $ DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPG+J-1+(ICJ-1)*NRG), DWORK(INGC), - $ CS, SN, IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 240 I = ICJ*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 240 CONTINUE -C - INGC = INGP - 250 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', M, NR-ICOL, DWORK(IPG+JDS), NRG, - $ R(ICOL+1,ICOL+1), LDR ) - ICOL = ICOL + M -C - DO 260 I = ( MMNOBR - M )*NRG, ICOL*NRG, -MNRG - CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, - $ DWORK(IPG+I), NRG ) - 260 CONTINUE -C - DO 270 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG - CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 270 CONTINUE -C - CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) - JDS = JDS + MNRG - 280 CONTINUE -C - END IF -C -C Process the output part of the generators. -C - JWORK = ITAU + L -C -C Reduce the first L columns of the submatrix -C G1(1:M+L+1,2*M*NOBR+1:2*(M+L)*NOBR) to upper triangular form. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*L; -C prefer (M+L)*4*NOBR*(M+L+1)+L+L*NB. -C - INGC = ING + MMNOBR*NRG - CALL DGEQRF( NRG, L, DWORK(IPGC), NRG, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need (M+L)*4*NOBR*(M+L+1)+L*2*NOBR; -C prefer (M+L)*4*NOBR*(M+L+1)+L+(L*2*NOBR-L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, - $ DWORK(IPGC), NRG, DWORK(ITAU), DWORK(IPGC+LNRG), - $ NRG, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Annihilate, column by column, the first L columns of the -C output part of the matrix G2 of negative generators, using -C Householder transformations and modified hyperbolic rotations. -C - DO 300 J = 1, L - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, LLNOBR-J, DWORK(INGC), 1, TAU, - $ DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPGC+(J-1)*(NRG+1)), DWORK(INGC), CS, SN, - $ IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 290 I = ( J + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 290 CONTINUE -C - INGC = INGP - 300 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', L, LLNOBR, DWORK(IPGC), NRG, - $ R(MMNOBR+1,MMNOBR+1), LDR ) -C - DO 310 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG - CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 310 CONTINUE -C -C Update the output part of generators using the Schur algorithm. -C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*L-L. -C - JDS = LNRG - ICOL = L -C - DO 350 K = 2, NOBR2 - CALL MB04OD( 'Full', L, LLNOBR-ICOL-L, M+1, DWORK(IPGC+JDS), - $ NRG, DWORK(IPGC+L+JDS), NRG, - $ DWORK(IPGC+JDS+LNRG), NRG, - $ DWORK(IPGC+L+JDS+LNRG), NRG, DWORK(ITAU), - $ DWORK(JWORK) ) -C - DO 330 J = 1, L - ICJ = ICOL + J - CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) - BETA = DWORK(INGC) - DWORK(INGC) = ONE - INGP = INGC + NRG - CALL DLARF( 'Left', NRG, LLNOBR-ICJ, DWORK(INGC), 1, - $ TAU, DWORK(INGP), NRG, DWORK(ITAU) ) - DWORK(INGC) = BETA -C -C Compute the coefficients of the modified hyperbolic -C rotation. -C - CALL MA02FD( DWORK(IPGC+J-1+(ICJ-1)*NRG), DWORK(INGC), - $ CS, SN, IERR ) - IF( IERR.NE.0 ) THEN -C -C Error return: the matrix H'*H is not (numerically) -C positive definite. -C - INFO = 1 - RETURN - END IF -C - DO 320 I = ( ICJ + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG - DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - - $ SN * DWORK(ING+I) ) / CS - DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + - $ CS * DWORK(ING+I) - 320 CONTINUE -C - INGC = INGP - 330 CONTINUE -C -C Save one block row of R, and shift the generators for the -C calculation of the following row. -C - CALL DLACPY( 'Upper', L, LLNOBR-ICOL, DWORK(IPGC+JDS), NRG, - $ R(MMNOBR+ICOL+1,MMNOBR+ICOL+1), LDR ) -C - DO 340 I = ( NR - L )*NRG, ( MMNOBR + ICOL )*NRG, -LNRG - CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, - $ DWORK(IPG+I), NRG ) - 340 CONTINUE -C - ICOL = ICOL + L - JDS = JDS + LNRG - 350 CONTINUE -C - IF ( MOESP .AND. M.GT.0 ) THEN -C -C For the MOESP algorithm, interchange the past and future -C input parts of the R factor, and compute the new R factor -C using a specialized QR factorization. A tailored fast -C QR factorization for the MOESP algorithm could be slightly -C more efficient. -C - DO 360 J = 1, MNOBR - CALL DSWAP( J, R(1,J), 1, R(1,MNOBR+J), 1 ) - CALL DCOPY( MNOBR, R(J+1,MNOBR+J), 1, R(J+1,J), 1 ) - CALL DCOPY( MMNOBR-J, DUM, 0, R(J+1,MNOBR+J), 1 ) - 360 CONTINUE -C -C Triangularize the first two block columns (using structure), -C and apply the transformation to the corresponding part of -C the remaining block columns. -C Workspace: need 2*(M+L)*NOBR. -C - ITAU = 1 - JWORK = ITAU + MMNOBR - CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, - $ R(1,MMNOBR+1), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF - END IF -C - NSMPSM = 0 - ICYCLE = 1 -C -C Return optimal workspace in DWORK(1). -C - DWORK( 1 ) = MAXWRK - MAXWRK = 1 - RETURN -C -C *** Last line of IB01MY *** - END diff --git a/slycot/src/IB01ND.f b/slycot/src/IB01ND.f deleted file mode 100644 index ad315b4c..00000000 --- a/slycot/src/IB01ND.f +++ /dev/null @@ -1,731 +0,0 @@ - SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the singular value decomposition (SVD) giving the system -C order, using the triangular factor of the concatenated block -C Hankel matrices. Related preliminary calculations needed for -C computing the system matrices are also performed. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C JOBD CHARACTER*1 -C Specifies whether or not the matrices B and D should later -C be computed using the MOESP approach, as follows: -C = 'M': the matrices B and D should later be computed -C using the MOESP approach; -C = 'N': the matrices B and D should not be computed using -C the MOESP approach. -C This parameter is not relevant for METH = 'N'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C block Hankel matrices. NOBR > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C R (input/output) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper -C triangular part of this array must contain the upper -C triangular factor R from the QR factorization of the -C concatenated block Hankel matrices. Denote R_ij, -C i,j = 1:4, the ij submatrix of R, partitioned by -C M*NOBR, M*NOBR, L*NOBR, and L*NOBR rows and columns. -C On exit, if INFO = 0, the leading -C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this -C array contains the matrix S, the processed upper -C triangular factor R, as required by other subroutines. -C Specifically, let S_ij, i,j = 1:4, be the ij submatrix -C of S, partitioned by M*NOBR, L*NOBR, M*NOBR, and -C L*NOBR rows and columns. The submatrix S_22 contains -C the matrix of left singular vectors needed subsequently. -C Useful information is stored in S_11 and in the -C block-column S_14 : S_44. For METH = 'M' and JOBD = 'M', -C the upper triangular part of S_31 contains the upper -C triangular factor in the QR factorization of the matrix -C R_1c = [ R_12' R_22' R_11' ]', and S_12 contains the -C corresponding leading part of the transformed matrix -C R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', the -C subarray S_41 : S_43 contains the transpose of the -C matrix contained in S_14 : S_34. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), -C for METH = 'M' and JOBD = 'M'; -C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or -C for METH = 'N'. -C -C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) -C The singular values of the relevant part of the triangular -C factor from the QR factorization of the concatenated block -C Hankel matrices. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not used for METH = 'M'. -C -C Workspace -C -C IWORK INTEGER array, dimension ((M+L)*NOBR) -C This parameter is not referenced for METH = 'M'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, for METH = 'N', DWORK(2) and DWORK(3) -C contain the reciprocal condition numbers of the -C triangular factors of the matrices U_f and r_1 [6]. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), -C if METH = 'M' and JOBD = 'M'; -C LDWORK >= 5*L*NOBR, if METH = 'M' and JOBD = 'N'; -C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N'. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problems with coefficient matrix -C U_f, used for computing the weighted oblique -C projection (for METH = 'N'), have a rank-deficient -C coefficient matrix; -C = 5: the least squares problem with coefficient matrix -C r_1 [6], used for computing the weighted oblique -C projection (for METH = 'N'), has a rank-deficient -C coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C A singular value decomposition (SVD) of a certain matrix is -C computed, which reveals the order n of the system as the number -C of "non-zero" singular values. For the MOESP approach, this matrix -C is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), -C where R is the upper triangular factor R constructed by SLICOT -C Library routine IB01MD. For the N4SID approach, a weighted -C oblique projection is computed from the upper triangular factor R -C and its SVD is then found. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Verhaegen M. -C Subspace Model Identification. Part 3: Analysis of the -C ordinary output-error state-space model identification -C algorithm. -C Int. J. Control, 58, pp. 555-586, 1993. -C -C [3] Verhaegen M. -C Identification of the deterministic part of MIMO state space -C models given in innovations form from input-output data. -C Automatica, Vol.30, No.1, pp.61-74, 1994. -C -C [4] Van Overschee, P., and De Moor, B. -C N4SID: Subspace Algorithms for the Identification of -C Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [5] Van Overschee, P., and De Moor, B. -C Subspace Identification for Linear Systems: Theory - -C Implementation - Applications. -C Kluwer Academic Publishers, Boston/London/Dordrecht, 1996. -C -C [6] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 -C The algorithm requires 0(((m+l)s) ) floating point operations. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C Feb. 2000, Feb. 2001, Feb. 2004, March 2005. -C -C KEYWORDS -C -C Identification methods, multivariable systems, QR decomposition, -C singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDR, LDWORK, M, NOBR - CHARACTER JOBD, METH -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION EPS, RCOND1, RCOND2, SVLMAX, THRESH, TOLL - INTEGER I, IERR, ITAU, ITAU2, ITAU3, J, JWORK, LLMNOB, - $ LLNOBR, LMMNOB, LMNOBR, LNOBR, MAXWRK, MINWRK, - $ MMNOBR, MNOBR, NR, NR2, NR3, NR4, NRSAVE, RANK, - $ RANK1 - LOGICAL JOBDM, MOESP, N4SID -C .. Local Arrays .. - DOUBLE PRECISION DUM(1), SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, - $ DTRCON, MA02AD, MB03OD, MB03UD, MB04ID, MB04IY, - $ MB04OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - JOBDM = LSAME( JOBD, 'M' ) - MNOBR = M*NOBR - LNOBR = L*NOBR - LLNOBR = LNOBR + LNOBR - LMNOBR = LNOBR + MNOBR - MMNOBR = MNOBR + MNOBR - LMMNOB = MMNOBR + LNOBR - NR = LMNOBR + LMNOBR - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( NOBR.LE.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LE.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. - $ LDR.LT.3*MNOBR ) ) THEN - INFO = -7 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MINWRK = 1 - IF ( LDWORK.GE.1 ) THEN - IF ( MOESP ) THEN - MINWRK = 5*LNOBR - IF ( JOBDM ) - $ MINWRK = MAX( MMNOBR - NOBR, LMNOBR, MINWRK ) - MAXWRK = LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, - $ LNOBR, -1, -1 ) - ELSE -C - MINWRK = MAX( MINWRK, 5*LMNOBR + 1 ) - MAXWRK = MAX( MNOBR + MNOBR*ILAENV( 1, 'DGEQRF', ' ', - $ MMNOBR, MNOBR, -1, -1 ), - $ MNOBR + LLNOBR*ILAENV( 1, 'DORMQR', 'LT', - $ MMNOBR, LLNOBR, MNOBR, -1 ) ) - MAXWRK = MAX( MAXWRK, MNOBR + LNOBR*ILAENV( 1, 'DORMQR', - $ 'LN', MMNOBR, LNOBR, MNOBR, - $ -1 ) ) - MAXWRK = MAX( MAXWRK, LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', - $ ' ', LMMNOB, LNOBR, -1, -1 ) ) - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -12 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01ND', -INFO ) - RETURN - END IF -C -C Compute pointers to the needed blocks of R. -C - NR2 = MNOBR + 1 - NR3 = MMNOBR + 1 - NR4 = LMMNOB + 1 - ITAU = 1 - JWORK = ITAU + MNOBR -C - IF( MOESP ) THEN -C -C MOESP approach. -C - IF( M.GT.0 .AND. JOBDM ) THEN -C -C Rearrange the blocks of R: -C Copy the (1,1) block into the position (3,2) and -C copy the (1,4) block into (3,3). -C - CALL DLACPY( 'Upper', MNOBR, MNOBR, R, LDR, R(NR3,NR2), - $ LDR ) - CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR4), LDR, - $ R(NR3,NR3), LDR ) -C -C Using structure, triangularize the matrix -C R_1c = [ R_12' R_22' R_11' ]' -C and then apply the transformations to the matrix -c R_2c = [ R_13' R_23' R_14' ]'. -C Workspace: need M*NOBR + MAX(M-1,L)*NOBR. -C - CALL MB04OD( 'Upper', MNOBR, LNOBR, MNOBR, R(NR2,NR2), LDR, - $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR3,NR3), - $ LDR, DWORK(ITAU), DWORK(JWORK) ) - CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LNOBR, R(1,NR2), LDR, - $ R(1,NR3), LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Copy the leading M*NOBR x M*NOBR and M*NOBR x L*NOBR -C submatrices of R_1c and R_2c, respectively, into their -C final positions, required by SLICOT Library routine IB01PD. -C - CALL DLACPY( 'Upper', MNOBR, MNOBR, R(1,NR2), LDR, - $ R(LMNOBR+1,1), LDR ) - CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR3), LDR, R(1,NR2), - $ LDR ) - END IF -C -C Copy [ R_24' R_34' ]' in [ R_22' R_32' ]'. -C - CALL DLACPY( 'Full', LMNOBR, LNOBR, R(NR2,NR4), LDR, - $ R(NR2,NR2), LDR ) -C -C Triangularize the matrix in [ R_22' R_32' ]'. -C Workspace: need 2*L*NOBR; prefer L*NOBR + L*NOBR*NB. -C - JWORK = ITAU + LNOBR - CALL DGEQRF( LMNOBR, LNOBR, R(NR2,NR2), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C - ELSE -C -C N4SID approach. -C - DUM(1) = ZERO - LLMNOB = LLNOBR + MNOBR -C -C Set the precision parameters. A threshold value EPS**(2/3) is -C used for deciding to use pivoting or not, where EPS is the -C relative machine precision (see LAPACK Library routine DLAMCH). -C - TOLL = TOL - EPS = DLAMCH( 'Precision' ) - THRESH = EPS**( TWO/THREE ) -C - IF( M.GT.0 ) THEN -C -C For efficiency of later calculations, interchange the first -C two block-columns. The corresponding submatrices are -C redefined according to their new position. -C - DO 10 I = 1, MNOBR - CALL DSWAP( I, R(1,I), 1, R(1,MNOBR+I), 1 ) - CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(I+1,I), 1 ) - CALL DCOPY( MMNOBR-I, DUM, 0, R(I+1,MNOBR+I), 1 ) - 10 CONTINUE -C -C Now, -C -C U_f = [ R_11' R_21' 0 0 ]', -C U_p = [ R_12' 0 0 0 ]', -C Y_p = [ R_13' R_23' R_33' 0 ]', and -C Y_f = [ R_14' R_24' R_34' R_44' ]', -C -C where R_21, R_12, R_33, and R_44 are upper triangular. -C Define W_p := [ U_p Y_p ]. -C -C Prepare the computation of residuals of the two least -C squares problems giving the weighted oblique projection P: -C -C r_1 = W_p - U_f X_1, X_1 = arg min || U_f X - W_p ||, -C r_2 = Y_f - U_f X_2, X_2 = arg min || U_f X - Y_f ||, -C -C P = (arg min || r_1 X - r_2 ||)' r_1'. (1) -C -C Alternately, P' is given by the projection -C P' = Q_1 (Q_1)' r_2, -C where Q_1 contains the first k columns of the orthogonal -C matrix in the QR factorization of r_1, k := rank(r_1). -C -C Triangularize the matrix U_f = q r (using structure), and -C apply the transformation q' to the corresponding part of -C the matrices W_p, and Y_f. -C Workspace: need 2*(M+L)*NOBR. -C - CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LLMNOB, R, LDR, - $ R(1,NR2), LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Save updated Y_f (transposed) in the last block-row of R. -C - CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), - $ LDR ) -C -C Check the condition of the triangular factor r and decide -C to use pivoting or not. -C Workspace: need 4*M*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R, LDR, - $ RCOND1, DWORK(JWORK), IWORK, IERR ) -C - IF( TOLL.LE.ZERO ) - $ TOLL = MNOBR*MNOBR*EPS - IF ( RCOND1.GT.MAX( TOLL, THRESH ) ) THEN -C -C U_f is considered full rank and no pivoting is used. -C - CALL DLASET( 'Full', MNOBR, LLMNOB, ZERO, ZERO, R(1,NR2), - $ LDR ) - ELSE -C -C Save information about q in the (2,1) block of R. -C Use QR factorization with column pivoting, r P = Q R. -C Information on Q is stored in the strict lower triangle -C of R_11 and in DWORK(ITAU2). -C - DO 20 I = 1, MNOBR - 1 - DO 15 J = MMNOBR, NR2, -1 - R(J,I) = R(J-MNOBR+I,I) - 15 CONTINUE - CALL DCOPY( MNOBR-I, DUM, 0, R(I+1,I), 1 ) - IWORK(I) = 0 - 20 CONTINUE -C - IWORK(MNOBR) = 0 -C -C Workspace: need 5*M*NOBR+1. -C prefer 4*M*NOBR + (M*NOBR+1)*NB. -C - ITAU2 = JWORK - JWORK = ITAU2 + MNOBR - SVLMAX = ZERO - CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL, - $ SVLMAX, DWORK(ITAU2), RANK, SVAL, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need 2*M*NOBR + (M+2*L)*NOBR; -C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', MNOBR, LLMNOB, MNOBR, - $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( RANK.LT.MNOBR ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 4 - END IF -C -C Determine residuals r_1 and r_2: premultiply by Q and -C then by q. -C Workspace: need 2*M*NOBR + (M+2*L)*NOBR); -C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. -C - CALL DLASET( 'Full', RANK, LLMNOB, ZERO, ZERO, R(1,NR2), - $ LDR ) - CALL DORMQR( 'Left', 'NoTranspose', MNOBR, LLMNOB, MNOBR, - $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU2 -C -C Restore the transformation q. -C - DO 30 I = 1, MNOBR - 1 - DO 25 J = NR2, MMNOBR - R(J-MNOBR+I,I) = R(J,I) - 25 CONTINUE - 30 CONTINUE -C - END IF -C -C Premultiply by the transformation q (apply transformations -C in backward order). -C Workspace: need M*NOBR + (M+2*L)*NOBR; -C prefer larger. -C - CALL MB04IY( 'Left', 'NoTranspose', MMNOBR, LLMNOB, MNOBR, - $ MNOBR-1, R, LDR, DWORK(ITAU), R(1,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - ELSE -C -C Save Y_f (transposed) in the last block-row of R. -C - CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), - $ LDR ) - RCOND1 = ONE - END IF -C -C Triangularize the matrix r_1 for determining the oblique -C projection P in least squares problem in (1). Exploit the -C fact that the third block-row of r_1 has the structure -C [ 0 T ], where T is an upper triangular matrix. Then apply -C the corresponding transformations Q' to the matrix r_2. -C Workspace: need 2*M*NOBR; -C prefer M*NOBR + M*NOBR*NB. -C - CALL DGEQRF( MMNOBR, MNOBR, R(1,NR2), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Workspace: need M*NOBR + 2*L*NOBR; -C prefer M*NOBR + 2*L*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', MMNOBR, LLNOBR, MNOBR, - $ R(1,NR2), LDR, DWORK(ITAU), R(1,NR3), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - NRSAVE = NR2 -C - ITAU2 = JWORK - JWORK = ITAU2 + LNOBR - CALL MB04ID( LMNOBR, LNOBR, LNOBR-1, LNOBR, R(NR2,NR3), LDR, - $ R(NR2,NR4), LDR, DWORK(ITAU2), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Check the condition of the triangular matrix of order (m+l)*s -C just determined, and decide to use pivoting or not. -C Workspace: need 4*(M+L)*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LMNOBR, R(1,NR2), - $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) -C - IF( TOL.LE.ZERO ) - $ TOLL = LMNOBR*LMNOBR*EPS - IF ( RCOND2.LE.MAX( TOLL, THRESH ) ) THEN - IF ( M.GT.0 ) THEN -C -C Save information about Q in R_11 (in the strict lower -C triangle), R_21 and R_31 (transposed information). -C - CALL DLACPY( 'Lower', MMNOBR-1, MNOBR, R(2,NR2), LDR, - $ R(2,1), LDR ) - NRSAVE = 1 -C - DO 40 I = NR2, LMNOBR - CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(MNOBR+I,1), - $ LDR ) - 40 CONTINUE -C - END IF -C - CALL DLASET( 'Lower', LMNOBR-1, LMNOBR-1, ZERO, ZERO, - $ R(2,NR2), LDR ) -C -C Use QR factorization with column pivoting. -C Workspace: need 5*(M+L)*NOBR+1. -C prefer 4*(M+L)*NOBR + ((M+L)*NOBR+1)*NB. -C - DO 50 I = 1, LMNOBR - IWORK(I) = 0 - 50 CONTINUE -C - ITAU3 = JWORK - JWORK = ITAU3 + LMNOBR - SVLMAX = ZERO - CALL MB03OD( 'QR', LMNOBR, LMNOBR, R(1,NR2), LDR, IWORK, - $ TOLL, SVLMAX, DWORK(ITAU3), RANK1, SVAL, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need 2*(M+L)*NOBR + L*NOBR; -C prefer 2*(M+L)*NOBR + L*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR, - $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( RANK1.LT.LMNOBR ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 5 - END IF -C -C Apply the orthogonal transformations, in backward order, to -C [r_2(1:rank(r_1),:)' 0]', to obtain P'. -C Workspace: need 2*(M+L)*NOBR + L*NOBR; -C prefer 2*(M+L)*NOBR + L*NOBR*NB. -C - CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO, - $ R(RANK1+1,NR4), LDR ) - CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR, - $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU3 -C - IF ( M.GT.0 ) THEN -C -C Restore the saved transpose matrix from R_31. -C - DO 60 I = NR2, LMNOBR - CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I), - $ 1 ) - 60 CONTINUE -C - END IF -C - END IF -C -C Workspace: need M*NOBR + L*NOBR; -C prefer larger. -C - CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR, - $ LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2), - $ R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need M*NOBR + L*NOBR; -C prefer M*NOBR + L*NOBR*NB. -C - JWORK = ITAU2 - CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR, - $ R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Now, the matrix P' is available in R_14 : R_34. -C Triangularize the matrix P'. -C Workspace: need 2*L*NOBR; -C prefer L*NOBR + L*NOBR*NB. -C - JWORK = ITAU + LNOBR - CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Copy the triangular factor to its final position, R_22. -C - CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2), - $ LDR ) -C -C Restore Y_f. -C - CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4), - $ LDR ) - END IF -C -C Find the singular value decomposition of R_22. -C Workspace: need 5*L*NOBR. -C - CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR, - $ DUM, 1, SV, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C -C Transpose R(m*s+1:(m+L)*s,m*s+1:(m+L)*s) in-situ; its -C columns will then be the singular vectors needed subsequently. -C - DO 70 I = NR2+1, LMNOBR - CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR ) - 70 CONTINUE -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C numbers, if METH = 'N'. -C - DWORK(1) = MAXWRK - IF ( N4SID ) THEN - DWORK(2) = RCOND1 - DWORK(3) = RCOND2 - END IF - RETURN -C -C *** Last line of IB01ND *** - END diff --git a/slycot/src/IB01OD.f b/slycot/src/IB01OD.f deleted file mode 100644 index 69d22c5e..00000000 --- a/slycot/src/IB01OD.f +++ /dev/null @@ -1,214 +0,0 @@ - SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the system order, based on the singular values of the -C relevant part of the triangular factor of the concatenated block -C Hankel matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C CTRL CHARACTER*1 -C Specifies whether or not the user's confirmation of the -C system order estimate is desired, as follows: -C = 'C': user's confirmation; -C = 'N': no confirmation. -C If CTRL = 'C', a reverse communication routine, IB01OY, -C is called, and, after inspecting the singular values and -C system order estimate, n, the user may accept n or set -C a new value. -C IB01OY is not called by the routine if CTRL = 'N'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the processed input and -C output block Hankel matrices. NOBR > 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C SV (input) DOUBLE PRECISION array, dimension ( L*NOBR ) -C The singular values of the relevant part of the triangular -C factor from the QR factorization of the concatenated block -C Hankel matrices. -C -C N (output) INTEGER -C The estimated order of the system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Absolute tolerance used for determining an estimate of -C the system order. If TOL >= 0, the estimate is -C indicated by the index of the last singular value greater -C than or equal to TOL. (Singular values less than TOL -C are considered as zero.) When TOL = 0, an internally -C computed default value, TOL = NOBR*EPS*SV(1), is used, -C where SV(1) is the maximal singular value, and EPS is -C the relative machine precision (see LAPACK Library routine -C DLAMCH). When TOL < 0, the estimate is indicated by the -C index of the singular value that has the largest -C logarithmic gap to its successor. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 3: all singular values were exactly zero, hence N = 0. -C (Both input and output were identically zero.) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The singular values are compared to the given, or default TOL, and -C the estimated order n is returned, possibly after user's -C confirmation. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C August 2000. -C -C KEYWORDS -C -C Identification methods, multivariable systems, singular value -C decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, N, NOBR - CHARACTER CTRL -C .. Array Arguments .. - DOUBLE PRECISION SV(*) -C .. Local Scalars .. - DOUBLE PRECISION GAP, RNRM, TOLL - INTEGER I, IERR, LNOBR - LOGICAL CONTRL -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL IB01OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, LOG10 -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - CONTRL = LSAME( CTRL, 'C' ) - LNOBR = L*NOBR - IWARN = 0 - INFO = 0 - IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( NOBR.LE.0 ) THEN - INFO = -2 - ELSE IF( L.LE.0 ) THEN - INFO = -3 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01OD', -INFO ) - RETURN - END IF -C -C Set TOL if necessay. -C - TOLL = TOL - IF ( TOLL.EQ.ZERO) - $ TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR ) -C -C Obtain the system order. -C - N = 0 - IF ( SV(1).NE.ZERO ) THEN - N = NOBR - IF ( TOLL.GE.ZERO) THEN -C -C Estimate n based on the tolerance TOLL. -C - DO 10 I = 1, NOBR - 1 - IF ( SV(I+1).LT.TOLL ) THEN - N = I - GO TO 30 - END IF - 10 CONTINUE - ELSE -C -C Estimate n based on the largest logarithmic gap between -C two consecutive singular values. -C - GAP = ZERO - DO 20 I = 1, NOBR - 1 - RNRM = SV(I+1) - IF ( RNRM.NE.ZERO ) THEN - RNRM = LOG10( SV(I) ) - LOG10( RNRM ) - IF ( RNRM.GT.GAP ) THEN - GAP = RNRM - N = I - END IF - ELSE - IF ( GAP.EQ.ZERO ) - $ N = I - GO TO 30 - END IF - 20 CONTINUE - END IF - END IF -C - 30 CONTINUE - IF ( N.EQ.0 ) THEN -C -C Return with N = 0 if all singular values are zero. -C - IWARN = 3 - RETURN - END IF -C - IF ( CONTRL ) THEN -C -C Ask confirmation of the system order. -C - CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR ) - END IF - RETURN -C -C *** Last line of IB01OD *** - END diff --git a/slycot/src/IB01OY.f b/slycot/src/IB01OY.f deleted file mode 100644 index 1e475d75..00000000 --- a/slycot/src/IB01OY.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To ask for user's confirmation of the system order found by -C SLICOT Library routine IB01OD. This routine may be modified, -C but its interface must be preserved. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NS (input) INTEGER -C The number of singular values. NS > 0. -C -C NMAX (input) INTEGER -C The maximum value of the system order. 0 <= NMAX <= NS. -C -C N (input/output) INTEGER -C On entry, the estimate of the system order computed by -C IB01OD routine. 0 <= N <= NS. -C On exit, the user's estimate of the system order, which -C could be identical with the input value of N. -C Note that the output value of N should be less than -C or equal to NMAX. -C -C SV (input) DOUBLE PRECISION array, dimension ( NS ) -C The singular values, in descending order, used for -C determining the system order. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Identification, parameter estimation, singular values, structure -C identification. -C -C ********************************************************************* -C -C .. Parameters .. - INTEGER INTRMN, OUTRMN - PARAMETER ( INTRMN = 5, OUTRMN = 6 ) -C INTRMN is the unit number for the (terminal) input device. -C OUTRMN is the unit number for the (terminal) output device. -C .. -C .. Scalar Arguments .. - INTEGER INFO, N, NMAX, NS -C .. -C .. Array Arguments .. - DOUBLE PRECISION SV( * ) -C .. -C .. Local Scalars .. - LOGICAL YES - INTEGER I - CHARACTER ANS -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF( NS.LE.0 ) THEN - INFO = -1 - ELSE IF( NMAX.LT.0 .OR. NMAX.GT.NS ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. N.GT.NS ) THEN - INFO = -3 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01OY', -INFO ) - RETURN - END IF -C - WRITE( OUTRMN, '(/'' Singular values (in descending order) used'', - $ '' to estimate the system order:'', // - $ (5D15.8) )' ) ( SV(I), I = 1, NS ) - WRITE( OUTRMN, '(/'' Estimated order of the system, n = '', I5 )' - $ ) N - WRITE( OUTRMN, '(/'' Do you want this value of n to be used'', - $ '' to determine the system matrices?'' )' ) -C - 10 CONTINUE - WRITE( OUTRMN, '(/'' Type "yes" or "no": '' )' ) - READ ( INTRMN, '( A )' ) ANS - YES = LSAME( ANS, 'Y' ) - IF( YES ) THEN - IF( N.LE.NMAX ) THEN -C -C The value of n is adequate and has been confirmed. -C - RETURN - ELSE -C -C The estimated value of n is not acceptable. -C - WRITE( OUTRMN, '(/'' n should be less than or equal'', - $ '' to '', I5 )' ) NMAX - WRITE( OUTRMN, '( '' (It may be useful to restart'', - $ '' with a larger tolerance.)'' )' ) - GO TO 20 - END IF -C - ELSE IF( LSAME( ANS, 'N' ) ) THEN - GO TO 20 - ELSE -C -C Wrong answer should be re-entered. -C - GO TO 10 - END IF -C -C Enter the desired value of n. -C - 20 CONTINUE - WRITE( OUTRMN,'(/'' Enter the desired value of n (n <= '', I5, - $ ''); n = '' )' ) NMAX - READ ( INTRMN, * ) N - IF ( N.LT.0 ) THEN -C -C The specified value of n is not acceptable. -C - WRITE( OUTRMN, '(/'' n should be larger than zero.'' )' ) - GO TO 20 - ELSE IF ( N.GT.NMAX ) THEN -C -C The specified value of n is not acceptable. -C - WRITE( OUTRMN, '(/'' n should be less than or equal to '', - $ I5 )' ) NMAX - GO TO 20 - END IF -C - RETURN -C -C *** Last line of IB01OY *** - END diff --git a/slycot/src/IB01PD.f b/slycot/src/IB01PD.f deleted file mode 100644 index 45c3e0f1..00000000 --- a/slycot/src/IB01PD.f +++ /dev/null @@ -1,1232 +0,0 @@ - SUBROUTINE IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, - $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, - $ RY, LDRY, S, LDS, O, LDO, TOL, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the matrices A, C, B, and D of a linear time-invariant -C (LTI) state space model, using the singular value decomposition -C information provided by other routines. Optionally, the system and -C noise covariance matrices, needed for the Kalman gain, are also -C determined. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C JOB CHARACTER*1 -C Specifies which matrices should be computed, as follows: -C = 'A': compute all system matrices, A, B, C, and D; -C = 'C': compute the matrices A and C only; -C = 'B': compute the matrix B only; -C = 'D': compute the matrices B and D only. -C -C JOBCV CHARACTER*1 -C Specifies whether or not the covariance matrices are to -C be computed, as follows: -C = 'C': the covariance matrices should be computed; -C = 'N': the covariance matrices should not be computed. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMPL (input) INTEGER -C If JOBCV = 'C', the total number of samples used for -C calculating the covariance matrices. -C NSMPL >= 2*(M+L)*NOBR. -C This parameter is not meaningful if JOBCV = 'N'. -C -C R (input/workspace) DOUBLE PRECISION array, dimension -C ( LDR,2*(M+L)*NOBR ) -C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part -C of this array must contain the relevant data for the MOESP -C or N4SID algorithms, as constructed by SLICOT Library -C routines IB01AD or IB01ND. Let R_ij, i,j = 1:4, be the -C ij submatrix of R (denoted S in IB01AD and IB01ND), -C partitioned by M*NOBR, L*NOBR, M*NOBR, and L*NOBR -C rows and columns. The submatrix R_22 contains the matrix -C of left singular vectors used. Also needed, for -C METH = 'N' or JOBCV = 'C', are the submatrices R_11, -C R_14 : R_44, and, for METH = 'M' and JOB <> 'C', the -C submatrices R_31 and R_12, containing the processed -C matrices R_1c and R_2c, respectively, as returned by -C SLICOT Library routines IB01AD or IB01ND. -C Moreover, if METH = 'N' and JOB = 'A' or 'C', the -C block-row R_41 : R_43 must contain the transpose of the -C block-column R_14 : R_34 as returned by SLICOT Library -C routines IB01AD or IB01ND. -C The remaining part of R is used as workspace. -C On exit, part of this array is overwritten. Specifically, -C if METH = 'M', R_22 and R_31 are overwritten if -C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, -C and possibly R_11 are overwritten if JOBCV = 'C'; -C if METH = 'N', all needed submatrices are overwritten. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= 2*(M+L)*NOBR. -C -C A (input or output) DOUBLE PRECISION array, dimension -C (LDA,N) -C On entry, if METH = 'N' and JOB = 'B' or 'D', the -C leading N-by-N part of this array must contain the system -C state matrix. -C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), -C this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, the -C leading N-by-N part of this array contains the system -C state matrix. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' and -C JOB = 'B' or 'D'; -C LDA >= 1, otherwise. -C -C C (input or output) DOUBLE PRECISION array, dimension -C (LDC,N) -C On entry, if METH = 'N' and JOB = 'B' or 'D', the -C leading L-by-N part of this array must contain the system -C output matrix. -C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), -C this array need not be set on input. -C On exit, if JOB = 'A' or 'C' and INFO = 0, or -C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading -C L-by-N part of this array contains the system output -C matrix. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' and -C JOB = 'B' or 'D'; -C LDC >= 1, otherwise. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the -C leading N-by-M part of this array contains the system -C input matrix. If M = 0 or JOB = 'C', this array is -C not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; -C LDB >= 1, if M = 0 or JOB = 'C'. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix. If M = 0 or JOB = 'C' or 'B', this array is -C not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'A' or 'D'; -C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C If JOBCV = 'C', the leading N-by-N part of this array -C contains the positive semidefinite state covariance matrix -C to be used as state weighting matrix when computing the -C Kalman gain. -C This parameter is not referenced if JOBCV = 'N'. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= N, if JOBCV = 'C'; -C LDQ >= 1, if JOBCV = 'N'. -C -C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) -C If JOBCV = 'C', the leading L-by-L part of this array -C contains the positive (semi)definite output covariance -C matrix to be used as output weighting matrix when -C computing the Kalman gain. -C This parameter is not referenced if JOBCV = 'N'. -C -C LDRY INTEGER -C The leading dimension of the array RY. -C LDRY >= L, if JOBCV = 'C'; -C LDRY >= 1, if JOBCV = 'N'. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,L) -C If JOBCV = 'C', the leading N-by-L part of this array -C contains the state-output cross-covariance matrix to be -C used as cross-weighting matrix when computing the Kalman -C gain. -C This parameter is not referenced if JOBCV = 'N'. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= N, if JOBCV = 'C'; -C LDS >= 1, if JOBCV = 'N'. -C -C O (output) DOUBLE PRECISION array, dimension ( LDO,N ) -C If METH = 'M' and JOBCV = 'C', or METH = 'N', -C the leading L*NOBR-by-N part of this array contains -C the estimated extended observability matrix, i.e., the -C first N columns of the relevant singular vectors. -C If METH = 'M' and JOBCV = 'N', this array is not -C referenced. -C -C LDO INTEGER -C The leading dimension of the array O. -C LDO >= L*NOBR, if JOBCV = 'C' or METH = 'N'; -C LDO >= 1, otherwise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = N, if METH = 'M' and M = 0 -C or JOB = 'C' and JOBCV = 'N'; -C LIWORK = M*NOBR+N, if METH = 'M', JOB = 'C', -C and JOBCV = 'C'; -C LIWORK = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', -C and JOBCV = 'N'; -C LIWORK = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', -C and JOBCV = 'C'; -C LIWORK = max(M*NOBR+N,M*(N+L)), if METH = 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and -C DWORK(5) contain the reciprocal condition numbers of the -C triangular factors of the matrices, defined in the code, -C GaL (GaL = Un(1:(s-1)*L,1:n)), R_1c (if METH = 'M'), -C M (if JOBCV = 'C' or METH = 'N'), and Q or T (see -C SLICOT Library routines IB01PY or IB01PX), respectively. -C If METH = 'N', DWORK(3) is set to one without any -C calculations. Similarly, if METH = 'M' and JOBCV = 'N', -C DWORK(4) is set to one. If M = 0 or JOB = 'C', -C DWORK(3) and DWORK(5) are set to one. -C On exit, if INFO = -30, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( LDW1,LDW2 ), where, if METH = 'M', -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), -C if JOB = 'C' or JOB = 'A' and M = 0; -C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, -C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ -C max( L+M*NOBR, L*NOBR + -C max( 3*L*NOBR+1, M ) ) ) -C if M > 0 and JOB = 'A', 'B', or 'D'; -C LDW2 >= 0, if JOBCV = 'N'; -C LDW2 >= max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), -C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), -C if JOBCV = 'C', -C where Aw = N+N*N, if M = 0 or JOB = 'C'; -C Aw = 0, otherwise; -C and, if METH = 'N', -C LDW1 >= max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, N+4*(M*NOBR+N)+1, -C M*NOBR+3*N+L ); -C LDW2 >= 0, if M = 0 or JOB = 'C'; -C LDW2 >= M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), -C if M > 0 and JOB = 'A', 'B', or 'D'. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: a least squares problem to be solved has a -C rank-deficient coefficient matrix; -C = 5: the computed covariance matrices are too small. -C The problem seems to be a deterministic one. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge; -C = 3: a singular upper triangular matrix was found. -C -C METHOD -C -C In the MOESP approach, the matrices A and C are first -C computed from an estimated extended observability matrix [1], -C and then, the matrices B and D are obtained by solving an -C extended linear system in a least squares sense. -C In the N4SID approach, besides the estimated extended -C observability matrix, the solutions of two least squares problems -C are used to build another least squares problem, whose solution -C is needed to compute the system matrices A, C, B, and D. The -C solutions of the two least squares problems are also optionally -C used by both approaches to find the covariance matrices. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error state- -C space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C [4] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C FURTHER COMMENTS -C -C In some applications, it is useful to compute the system matrices -C using two calls to this routine, the first one with JOB = 'C', -C and the second one with JOB = 'B' or 'D'. This is slightly less -C efficient than using a single call with JOB = 'A', because some -C calculations are repeated. If METH = 'N', all the calculations -C at the first call are performed again at the second call; -C moreover, it is required to save the needed submatrices of R -C before the first call and restore them before the second call. -C If the covariance matrices are desired, JOBCV should be set -C to 'C' at the second call. If B and D are both needed, they -C should be computed at once. -C It is possible to compute the matrices A and C using the MOESP -C algorithm (METH = 'M'), and the matrices B and D using the N4SID -C algorithm (METH = 'N'). This combination could be slightly more -C efficient than N4SID algorithm alone and it could be more accurate -C than MOESP algorithm. No saving/restoring is needed in such a -C combination, provided JOBCV is set to 'N' at the first call. -C Recommended usage: either one call with JOB = 'A', or -C first call with METH = 'M', JOB = 'C', JOBCV = 'N', -C second call with METH = 'M', JOB = 'D', JOBCV = 'C', or -C first call with METH = 'M', JOB = 'C', JOBCV = 'N', -C second call with METH = 'N', JOB = 'D', JOBCV = 'C'. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. -C -C REVISIONS -C -C March 2000, Feb. 2001, Sep. 2001, March 2005. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDO, LDQ, - $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL - CHARACTER JOB, JOBCV, METH -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), O(LDO, *), Q(LDQ, *), R(LDR, *), - $ RY(LDRY, *), S(LDS, *) - INTEGER IWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION EPS, RCOND1, RCOND2, RCOND3, RCOND4, RNRM, - $ SVLMAX, THRESH, TOLL, TOLL1 - INTEGER I, IAW, ID, IERR, IGAL, IHOUS, ISV, ITAU, - $ ITAU1, ITAU2, IU, IUN2, IWARNL, IX, JWORK, - $ LDUN2, LDUNN, LDW, LMMNOB, LMMNOL, LMNOBR, - $ LNOBR, LNOBRN, MAXWRK, MINWRK, MNOBR, MNOBRN, - $ N2, NCOL, NN, NPL, NR, NR2, NR3, NR4, NR4MN, - $ NR4PL, NROW, RANK, RANK11, RANKM - CHARACTER FACT, JOBP, JOBPY - LOGICAL FULLR, MOESP, N4SID, SHIFT, WITHAL, WITHB, - $ WITHC, WITHCO, WITHD -C .. Local Array .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, - $ DSYRK, DTRCON, DTRSM, DTRTRS, IB01PX, IB01PY, - $ MA02AD, MA02ED, MB02QY, MB02UD, MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - WITHAL = LSAME( JOB, 'A' ) - WITHC = LSAME( JOB, 'C' ) .OR. WITHAL - WITHD = LSAME( JOB, 'D' ) .OR. WITHAL - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - WITHCO = LSAME( JOBCV, 'C' ) - MNOBR = M*NOBR - LNOBR = L*NOBR - LMNOBR = LNOBR + MNOBR - LMMNOB = LNOBR + 2*MNOBR - MNOBRN = MNOBR + N - LNOBRN = LNOBR - N - LDUN2 = LNOBR - L - LDUNN = LDUN2*N - LMMNOL = LMMNOB + L - NR = LMNOBR + LMNOBR - NPL = N + L - N2 = N + N - NN = N*N - MINWRK = 1 - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN - INFO = -2 - ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCV, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -4 - ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LE.0 ) THEN - INFO = -7 - ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN - INFO = -8 - ELSE IF( LDR.LT.NR ) THEN - INFO = -10 - ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) - $ .AND. LDA.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) - $ .AND. LDC.LT.L ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) - $ THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -18 - ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN - INFO = -20 - ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN - INFO = -24 - ELSE IF( LDO.LT.1 .OR. ( ( WITHCO .OR. N4SID ) .AND. - $ LDO.LT.LNOBR ) ) THEN - INFO = -26 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IAW = 0 - MINWRK = LDUNN + 4*N - MAXWRK = LDUNN + N + N*ILAENV( 1, 'DGEQRF', ' ', LDUN2, N, -1, - $ -1 ) - IF( MOESP ) THEN - ID = 0 - IF( WITHC ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) - MAXWRK = MAX( MAXWRK, 2*LDUNN + N + N*ILAENV( 1, - $ 'DORMQR', 'LT', LDUN2, N, N, -1 ) ) - END IF - ELSE - ID = N - END IF -C - IF( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN - MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) - IF ( MOESP ) - $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + - $ MAX( L + MNOBR, LNOBR + - $ MAX( 3*LNOBR + 1, M ) ) ) - ELSE - IF( MOESP ) - $ IAW = N + NN - END IF -C - IF( N4SID .OR. WITHCO ) THEN - MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), - $ ID + 4*MNOBRN+1, ID + MNOBRN + NPL ) - MAXWRK = MAX( MAXWRK, LDUNN + IAW + N2 + - $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', LNOBR, N, -1, - $ -1 ), LMMNOB* - $ ILAENV( 1, 'DORMQR', 'LT', LNOBR, - $ LMMNOB, N, -1 ), LMMNOL* - $ ILAENV( 1, 'DORMQR', 'LT', LDUN2, - $ LMMNOL, N, -1 ) ), - $ ID + N + N*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, - $ N, -1, -1 ), - $ ID + N + NPL*ILAENV( 1, 'DORMQR', 'LT', - $ LMNOBR, NPL, N, -1 ) ) - IF( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) - $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + - $ MAX( NPL**2, 4*M*NPL + 1 ) ) - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -30 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01PD', -INFO ) - RETURN - END IF -C - NR2 = MNOBR + 1 - NR3 = LMNOBR + 1 - NR4 = LMMNOB + 1 -C -C Set the precision parameters. A threshold value EPS**(2/3) is -C used for deciding to use pivoting or not, where EPS is the -C relative machine precision (see LAPACK Library routine DLAMCH). -C - EPS = DLAMCH( 'Precision' ) - THRESH = EPS**( TWO/THREE ) - SVLMAX = ZERO - RCOND4 = ONE -C -C Let Un be the matrix of left singular vectors (stored in R_22). -C Copy un1 = GaL = Un(1:(s-1)*L,1:n) in the workspace. -C - IGAL = 1 - CALL DLACPY( 'Full', LDUN2, N, R(NR2,NR2), LDR, DWORK(IGAL), - $ LDUN2 ) -C -C Factor un1 = Q1*[r1' 0]' (' means transposition). -C Workspace: need L*(NOBR-1)*N+2*N, -C prefer L*(NOBR-1)*N+N+N*NB. -C - ITAU1 = IGAL + LDUNN - JWORK = ITAU1 + N - LDW = JWORK - CALL DGEQRF( LDUN2, N, DWORK(IGAL), LDUN2, DWORK(ITAU1), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Compute the reciprocal of the condition number of r1. -C Workspace: need L*(NOBR-1)*N+4*N. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', N, DWORK(IGAL), LDUN2, - $ RCOND1, DWORK(JWORK), IWORK, INFO ) -C - TOLL1 = TOL - IF( TOLL1.LE.ZERO ) - $ TOLL1 = NN*EPS -C - IF ( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN - JOBP = 'P' - IF ( WITHAL ) THEN - JOBPY = 'D' - ELSE - JOBPY = JOB - END IF - ELSE - JOBP = 'N' - END IF -C - IF ( MOESP ) THEN - NCOL = 0 - IUN2 = JWORK - IF ( WITHC ) THEN -C -C Set C = Un(1:L,1:n) and then compute the system matrix A. -C -C Set un2 = Un(L+1:L*s,1:n) in DWORK(IUN2). -C Workspace: need 2*L*(NOBR-1)*N+N. -C - CALL DLACPY( 'Full', L, N, R(NR2,NR2), LDR, C, LDC ) - CALL DLACPY( 'Full', LDUN2, N, R(NR2+L,NR2), LDR, - $ DWORK(IUN2), LDUN2 ) -C -C Note that un1 has already been factored as -C un1 = Q1*[r1' 0]' and usually (generically, assuming -C observability) has full column rank. -C Update un2 <-- Q1'*un2 in DWORK(IUN2) and save its -C first n rows in A. -C Workspace: need 2*L*(NOBR-1)*N+2*N; -C prefer 2*L*(NOBR-1)*N+N+N*NB. -C - JWORK = IUN2 + LDUNN - CALL DORMQR( 'Left', 'Transpose', LDUN2, N, N, DWORK(IGAL), - $ LDUN2, DWORK(ITAU1), DWORK(IUN2), LDUN2, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - CALL DLACPY( 'Full', N, N, DWORK(IUN2), LDUN2, A, LDA ) - NCOL = N - JWORK = IUN2 - END IF -C - IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN -C -C The triangular factor r1 is considered to be of full rank. -C Solve for A (if requested), r1*A = un2(1:n,:) in A. -C - IF ( WITHC ) THEN - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, N, - $ DWORK(IGAL), LDUN2, A, LDA, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - END IF - RANK = N - ELSE -C -C Rank-deficient triangular factor r1. Use SVD of r1, -C r1 = U*S*V', also for computing A (if requested) from -C r1*A = un2(1:n,:). Matrix U is computed in DWORK(IU), -C and V' overwrites r1. If B is requested, the -C pseudoinverse of r1 and then of GaL are also computed -C in R(NR3,NR2). -C Workspace: need c*L*(NOBR-1)*N+N*N+7*N, -C where c = 1 if B and D are not needed, -C c = 2 if B and D are needed; -C prefer larger. -C - IU = IUN2 - ISV = IU + NN - JWORK = ISV + N - IF ( M.GT.0 .AND. WITHB ) THEN -C -C Save the elementary reflectors used for computing r1, -C if B, D are needed. -C Workspace: need 2*L*(NOBR-1)*N+2*N+N*N. -C - IHOUS = JWORK - JWORK = IHOUS + LDUNN - CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, - $ DWORK(IHOUS), LDUN2 ) - ELSE - IHOUS = IGAL - END IF -C - CALL MB02UD( 'Not factored', 'Left', 'NoTranspose', JOBP, N, - $ NCOL, ONE, TOLL1, RANK, DWORK(IGAL), LDUN2, - $ DWORK(IU), N, DWORK(ISV), A, LDA, R(NR3,NR2), - $ LDR, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - IF ( RANK.EQ.0 ) THEN - JOBP = 'N' - ELSE IF ( M.GT.0 .AND. WITHB ) THEN -C -C Compute pinv(GaL) in R(NR3,NR2) if B, D are needed. -C Workspace: need 2*L*(NOBR-1)*N+N*N+3*N; -C prefer 2*L*(NOBR-1)*N+N*N+2*N+N*NB. -C - CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, - $ R(NR3,NR2+N), LDR ) - CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, - $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), - $ R(NR3,NR2), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( WITHCO ) THEN -C -C Save pinv(GaL) in DWORK(IGAL). -C - CALL DLACPY( 'Full', N, LDUN2, R(NR3,NR2), LDR, - $ DWORK(IGAL), N ) - END IF - JWORK = IUN2 - END IF - LDW = JWORK - END IF -C - IF ( M.GT.0 .AND. WITHB ) THEN -C -C Computation of B and D. -C -C Compute the reciprocal of the condition number of R_1c. -C Workspace: need L*(NOBR-1)*N+N+3*M*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R(NR3,1), - $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) -C - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = MNOBR*MNOBR*EPS -C -C Compute the right hand side and solve for K (in R_23), -C K*R_1c' = u2'*R_2c', -C where u2 = Un(:,n+1:L*s), and K is (Ls-n) x ms. -C - CALL DGEMM( 'Transpose', 'Transpose', LNOBRN, MNOBR, LNOBR, - $ ONE, R(NR2,NR2+N), LDR, R(1,NR2), LDR, ZERO, - $ R(NR2,NR3), LDR ) -C - IF ( RCOND2.GT.MAX( TOLL, THRESH ) ) THEN -C -C The triangular factor R_1c is considered to be of full -C rank. Solve for K, K*R_1c' = u2'*R_2c'. -C - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ LNOBRN, MNOBR, ONE, R(NR3,1), LDR, - $ R(NR2,NR3), LDR ) - ELSE -C -C Rank-deficient triangular factor R_1c. Use SVD of R_1c -C for computing K from K*R_1c' = u2'*R_2c', where -C R_1c = U1*S1*V1'. Matrix U1 is computed in R_33, -C and V1' overwrites R_1c. -C Workspace: need L*(NOBR-1)*N+N+6*M*NOBR; -C prefer larger. -C - ISV = LDW - JWORK = ISV + MNOBR - CALL MB02UD( 'Not factored', 'Right', 'Transpose', - $ 'No pinv', LNOBRN, MNOBR, ONE, TOLL, RANK11, - $ R(NR3,1), LDR, R(NR3,NR3), LDR, DWORK(ISV), - $ R(NR2,NR3), LDR, DWORK(JWORK), 1, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = LDW - END IF -C -C Compute the triangular factor of the structured matrix Q -C and apply the transformations to the matrix Kexpand, where -C Q and Kexpand are defined in SLICOT Library routine -C IB01PY. Compute also the matrices B, D. -C Workspace: need L*(NOBR-1)*N+N+max(L+M*NOBR,L*NOBR+ -C max(3*L*NOBR+1,M)); -C prefer larger. -C - IF ( WITHCO ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) - CALL IB01PY( METH, JOBPY, NOBR, N, M, L, RANK, R(NR2,NR2), - $ LDR, DWORK(IGAL), LDUN2, DWORK(ITAU1), - $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR4,NR2), - $ LDR, R(NR4,NR3), LDR, B, LDB, D, LDD, TOL, - $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARN, - $ INFO ) - IF ( INFO.NE.0 ) - $ RETURN - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - RCOND4 = DWORK(JWORK+1) - IF ( WITHCO ) - $ CALL DLACPY( 'Full', LNOBR, N, O, LDO, R(NR2,1), LDR ) -C - ELSE - RCOND2 = ONE - END IF -C - IF ( .NOT.WITHCO ) THEN - RCOND3 = ONE - GO TO 30 - END IF - ELSE -C -C For N4SID, set RCOND2 to one. -C - RCOND2 = ONE - END IF -C -C If needed, save the first n columns, representing Gam, of the -C matrix of left singular vectors, Un, in R_21 and in O. -C - IF ( N4SID .OR. ( WITHC .AND. .NOT.WITHAL ) ) THEN - IF ( M.GT.0 ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, R(NR2,1), - $ LDR ) - CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) - END IF -C -C Computations for covariance matrices, and system matrices (N4SID). -C Solve the least squares problems Gam*Y = R4(1:L*s,1:(2*m+L)*s), -C GaL*X = R4(L+1:L*s,:), where -C GaL = Gam(1:L*(s-1),:), Gam has full column rank, and -C R4 = [ R_14' R_24' R_34' R_44L' ], R_44L = R_44(1:L,:), as -C returned by SLICOT Library routine IB01ND. -C First, find the QR factorization of Gam, Gam = Q*R. -C Workspace: need L*(NOBR-1)*N+Aw+3*N; -C prefer L*(NOBR-1)*N+Aw+2*N+N*NB, where -C Aw = N+N*N, if (M = 0 or JOB = 'C'), rank(r1) < N, -C and METH = 'M'; -C Aw = 0, otherwise. -C - ITAU2 = LDW - JWORK = ITAU2 + N - CALL DGEQRF( LNOBR, N, R(NR2,1), LDR, DWORK(ITAU2), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C For METH = 'M' or when JOB = 'B' or 'D', transpose -C [ R_14' R_24' R_34' ]' in the last block-row of R, obtaining Z, -C and for METH = 'N' and JOB = 'A' or 'C', use the matrix Z -C already available in the last block-row of R, and then apply -C the transformations, Z <-- Q'*Z. -C Workspace: need L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR; -C prefer L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR*NB. -C - IF ( MOESP .OR. ( WITHB .AND. .NOT. WITHAL ) ) - $ CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), - $ LDR ) - CALL DORMQR( 'Left', 'Transpose', LNOBR, LMMNOB, N, R(NR2,1), LDR, - $ DWORK(ITAU2), R(NR4,1), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Solve for Y, RY = Z in Z and save the transpose of the -C solution Y in the second block-column of R. -C - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOB, - $ R(NR2,1), LDR, R(NR4,1), LDR, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - CALL MA02AD( 'Full', N, LMMNOB, R(NR4,1), LDR, R(1,NR2), LDR ) - NR4MN = NR4 - N - NR4PL = NR4 + L - NROW = LMMNOL -C -C SHIFT is .TRUE. if some columns of R_14 : R_44L should be -C shifted to the right, to avoid overwriting useful information. -C - SHIFT = M.EQ.0 .AND. LNOBR.LT.N2 -C - IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN -C -C The triangular factor r1 of GaL (GaL = Q1*r1) is -C considered to be of full rank. -C -C Transpose [ R_14' R_24' R_34' R_44L' ]'(:,L+1:L*s) in the -C last block-row of R (beginning with the (L+1)-th row), -C obtaining Z1, and then apply the transformations, -C Z1 <-- Q1'*Z1. -C Workspace: need L*(NOBR-1)*N+Aw+2*N+ (2*M+L)*NOBR + L; -C prefer L*(NOBR-1)*N+Aw+2*N+((2*M+L)*NOBR + L)*NB. -C - CALL MA02AD( 'Full', LMMNOL, LDUN2, R(1,NR4PL), LDR, - $ R(NR4PL,1), LDR ) - CALL DORMQR( 'Left', 'Transpose', LDUN2, LMMNOL, N, - $ DWORK(IGAL), LDUN2, DWORK(ITAU1), R(NR4PL,1), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Solve for X, r1*X = Z1 in Z1, and copy the transpose of X -C into the last part of the third block-column of R. -C - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOL, - $ DWORK(IGAL), LDUN2, R(NR4PL,1), LDR, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF -C - IF ( SHIFT ) THEN - NR4MN = NR4 -C - DO 10 I = L - 1, 0, -1 - CALL DCOPY( LMMNOL, R(1,NR4+I), 1, R(1,NR4+N+I), 1 ) - 10 CONTINUE -C - END IF - CALL MA02AD( 'Full', N, LMMNOL, R(NR4PL,1), LDR, R(1,NR4MN), - $ LDR ) - NROW = 0 - END IF -C - IF ( N4SID .OR. NROW.GT.0 ) THEN -C -C METH = 'N' or rank-deficient triangular factor r1. -C For METH = 'N', use SVD of r1, r1 = U*S*V', for computing -C X' from X'*GaL' = Z1', if rank(r1) < N. Matrix U is -C computed in DWORK(IU) and V' overwrites r1. Then, the -C pseudoinverse of GaL is determined in R(NR4+L,NR2). -C For METH = 'M', the pseudoinverse of GaL is already available -C if M > 0 and B is requested; otherwise, the SVD of r1 is -C available in DWORK(IU), DWORK(ISV), and DWORK(IGAL). -C Workspace for N4SID: need 2*L*(NOBR-1)*N+N*N+8*N; -C prefer larger. -C - IF ( MOESP ) THEN - FACT = 'F' - IF ( M.GT.0 .AND. WITHB ) - $ CALL DLACPY( 'Full', N, LDUN2, DWORK(IGAL), N, - $ R(NR4PL,NR2), LDR ) - ELSE -C -C Save the elementary reflectors used for computing r1. -C - IHOUS = JWORK - CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, - $ DWORK(IHOUS), LDUN2 ) - FACT = 'N' - IU = IHOUS + LDUNN - ISV = IU + NN - JWORK = ISV + N - END IF -C - CALL MB02UD( FACT, 'Right', 'Transpose', JOBP, NROW, N, ONE, - $ TOLL1, RANK, DWORK(IGAL), LDUN2, DWORK(IU), N, - $ DWORK(ISV), R(1,NR4PL), LDR, R(NR4PL,NR2), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( NROW.GT.0 ) THEN - IF ( SHIFT ) THEN - NR4MN = NR4 - CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4), LDR, - $ R(1,NR4-L), LDR ) - CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, - $ R(1,NR4MN), LDR ) - CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4-L), LDR, - $ R(1,NR4+N), LDR ) - ELSE - CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, - $ R(1,NR4MN), LDR ) - END IF - END IF -C - IF ( N4SID ) THEN - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Compute pinv(GaL) in R(NR4+L,NR2). -C Workspace: need 2*L*(NOBR-1)*N+3*N; -C prefer 2*L*(NOBR-1)*N+2*N+N*NB. -C - JWORK = IU - CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, R(NR4PL,NR2+N), - $ LDR ) - CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, - $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), - $ R(NR4PL,NR2), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF - END IF -C -C For METH = 'N', find part of the solution (corresponding to A -C and C) and, optionally, for both METH = 'M', or METH = 'N', -C find the residual of the least squares problem that gives the -C covariances, M*V = N, where -C ( R_11 ) -C M = ( Y' ), N = ( X' R4'(:,1:L) ), V = V(n+m*s, n+L), -C ( 0 0 ) -C with M((2*m+L)*s+L, n+m*s), N((2*m+L)*s+L, n+L), R4' being -C stored in the last block-column of R. The last L rows of M -C are not explicitly considered. Note that, for efficiency, the -C last m*s columns of M are in the first positions of arrray R. -C This permutation does not affect the residual, only the -C solution. (The solution is not needed for METH = 'M'.) -C Note that R_11 corresponds to the future outputs for both -C METH = 'M', or METH = 'N' approaches. (For METH = 'N', the -C first two block-columns have been interchanged.) -C For METH = 'N', A and C are obtained as follows: -C [ A' C' ] = V(m*s+1:m*s+n,:). -C -C First, find the QR factorization of Y'(m*s+1:(2*m+L)*s,:) -C and apply the transformations to the corresponding part of N. -C Compress the workspace for N4SID by moving the scalar reflectors -C corresponding to Q. -C Workspace: need d*N+2*N; -C prefer d*N+N+N*NB; -C where d = 0, for MOESP, and d = 1, for N4SID. -C - IF ( MOESP ) THEN - ITAU = 1 - ELSE - CALL DCOPY( N, DWORK(ITAU2), 1, DWORK, 1 ) - ITAU = N + 1 - END IF -C - JWORK = ITAU + N - CALL DGEQRF( LMNOBR, N, R(NR2,NR2), LDR, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Workspace: need d*N+N+(N+L); -C prefer d*N+N+(N+L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', LMNOBR, NPL, N, R(NR2,NR2), LDR, - $ DWORK(ITAU), R(NR2,NR4MN), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C - CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(NR4+1,NR4), LDR ) -C -C Now, matrix M with permuted block-columns has been -C triangularized. -C Compute the reciprocal of the condition number of its -C triangular factor in R(1:m*s+n,1:m*s+n). -C Workspace: need d*N+3*(M*NOBR+N). -C - JWORK = ITAU - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBRN, R, LDR, RCOND3, - $ DWORK(JWORK), IWORK, INFO ) -C - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = MNOBRN*MNOBRN*EPS - IF ( RCOND3.GT.MAX( TOLL, THRESH ) ) THEN -C -C The triangular factor is considered to be of full rank. -C Solve for V(m*s+1:m*s+n,:), giving [ A' C' ]. -C - FULLR = .TRUE. - RANKM = MNOBRN - IF ( N4SID ) - $ CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, - $ NPL, ONE, R(NR2,NR2), LDR, R(NR2,NR4MN), LDR ) - ELSE - FULLR = .FALSE. -C -C Use QR factorization (with pivoting). For METH = 'N', save -C (and then restore) information about the QR factorization of -C Gam, for later use. Note that R_11 could be modified by -C MB03OD, but the corresponding part of N is also modified -C accordingly. -C Workspace: need d*N+4*(M*NOBR+N)+1; -C prefer d*N+3*(M*NOBR+N)+(M*NOBR+N+1)*NB. -C - DO 20 I = 1, MNOBRN - IWORK(I) = 0 - 20 CONTINUE -C - IF ( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,1), LDR, R(NR4,1), - $ LDR ) - JWORK = ITAU + MNOBRN - CALL DLASET( 'Lower', MNOBRN-1, MNOBRN, ZERO, ZERO, R(2,1), - $ LDR ) - CALL MB03OD( 'QR', MNOBRN, MNOBRN, R, LDR, IWORK, TOLL, - $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need d*N+M*NOBR+N+N+L; -C prefer d*N+M*NOBR+N+(N+L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', MNOBRN, NPL, MNOBRN, - $ R, LDR, DWORK(ITAU), R(1,NR4MN), LDR, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C - IF ( WITHCO ) THEN -C -C The residual (transposed) of the least squares solution -C (multiplied by a matrix with orthogonal columns) is stored -C in the rows RANKM+1:(2*m+L)*s+L of V, and it should be -C squared-up for getting the covariance matrices. (Generically, -C RANKM = m*s+n.) -C - RNRM = ONE/DBLE( NSMPL ) - IF ( MOESP ) THEN - CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, - $ R(RANKM+1,NR4MN), LDR, ZERO, R, LDR ) - CALL DLACPY( 'Upper', N, N, R, LDR, Q, LDQ ) - CALL DLACPY( 'Full', N, L, R(1,N+1), LDR, S, LDS ) - CALL DLACPY( 'Upper', L, L, R(N+1,N+1), LDR, RY, LDRY ) - ELSE - CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, - $ R(RANKM+1,NR4MN), LDR, ZERO, DWORK(JWORK), NPL ) - CALL DLACPY( 'Upper', N, N, DWORK(JWORK), NPL, Q, LDQ ) - CALL DLACPY( 'Full', N, L, DWORK(JWORK+N*NPL), NPL, S, - $ LDS ) - CALL DLACPY( 'Upper', L, L, DWORK(JWORK+N*(NPL+1)), NPL, RY, - $ LDRY ) - END IF - CALL MA02ED( 'Upper', N, Q, LDQ ) - CALL MA02ED( 'Upper', L, RY, LDRY ) -C -C Check the magnitude of the residual. -C - RNRM = DLANGE( '1-norm', LMMNOL-RANKM, NPL, R(RANKM+1,NR4MN), - $ LDR, DWORK(JWORK) ) - IF ( RNRM.LT.THRESH ) - $ IWARN = 5 - END IF -C - IF ( N4SID ) THEN - IF ( .NOT.FULLR ) THEN - IWARN = 4 -C -C Compute part of the solution of the least squares problem, -C M*V = N, for the rank-deficient problem. -C Remark: this computation should not be performed before the -C symmetric updating operation above. -C Workspace: need M*NOBR+3*N+L; -C prefer larger. -C - CALL MB03OD( 'No QR', N, N, R(NR2,NR2), LDR, IWORK, TOLL1, - $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - CALL MB02QY( N, N, NPL, RANKM, R(NR2,NR2), LDR, IWORK, - $ R(NR2,NR4MN), LDR, DWORK(ITAU+MNOBR), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU - IF ( M.GT.0 .AND. WITHB ) - $ CALL DLACPY( 'Full', LNOBR, N, R(NR4,1), LDR, R(NR2,1), - $ LDR ) - END IF -C - IF ( WITHC ) THEN -C -C Obtain A and C, noting that block-permutations have been -C implicitly used. -C - CALL MA02AD( 'Full', N, N, R(NR2,NR4MN), LDR, A, LDA ) - CALL MA02AD( 'Full', N, L, R(NR2,NR4MN+N), LDR, C, LDC ) - ELSE -C -C Use the given A and C. -C - CALL MA02AD( 'Full', N, N, A, LDA, R(NR2,NR4MN), LDR ) - CALL MA02AD( 'Full', L, N, C, LDC, R(NR2,NR4MN+N), LDR ) - END IF -C - IF ( M.GT.0 .AND. WITHB ) THEN -C -C Obtain B and D. -C First, compute the transpose of the matrix K as -C N(1:m*s,:) - M(1:m*s,m*s+1:m*s+n)*[A' C'], in the first -C m*s rows of R(1,NR4MN). -C - CALL DGEMM ( 'NoTranspose', 'NoTranspose', MNOBR, NPL, N, - $ -ONE, R(1,NR2), LDR, R(NR2,NR4MN), LDR, ONE, - $ R(1,NR4MN), LDR ) -C -C Denote M = pinv(GaL) and construct -C -C [ [ A ] -1 ] [ R ] -C and L = [ [ ] R 0 ] Q', where Gam = Q * [ ]. -C [ [ C ] ] [ 0 ] -C -C Then, solve the least squares problem. -C - CALL DLACPY( 'Full', N, N, A, LDA, R(NR2,NR4), LDR ) - CALL DLACPY( 'Full', L, N, C, LDC, R(NR2+N,NR4), LDR ) - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', - $ NPL, N, ONE, R(NR2,1), LDR, R(NR2,NR4), LDR ) - CALL DLASET( 'Full', NPL, LNOBRN, ZERO, ZERO, R(NR2,NR4+N), - $ LDR ) -C -C Workspace: need 2*N+L; prefer N + (N+L)*NB. -C - CALL DORMQR( 'Right', 'Transpose', NPL, LNOBR, N, R(NR2,1), - $ LDR, DWORK, R(NR2,NR4), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Obtain the matrix K by transposition, and find B and D. -C Workspace: need NOBR*(M*(N+L))**2+M*NOBR*(N+L)+ -C max((N+L)**2,4*M*(N+L)+1); -C prefer larger. -C - CALL MA02AD( 'Full', MNOBR, NPL, R(1,NR4MN), LDR, - $ R(NR2,NR3), LDR ) - IX = MNOBR*NPL**2*M + 1 - JWORK = IX + MNOBR*NPL - CALL IB01PX( JOBPY, NOBR, N, M, L, R, LDR, O, LDO, - $ R(NR2,NR4), LDR, R(NR4PL,NR2), LDR, R(NR2,NR3), - $ LDR, DWORK, MNOBR*NPL, DWORK(IX), B, LDB, D, - $ LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, - $ IWARNL, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - IWARN = MAX( IWARN, IWARNL ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - RCOND4 = DWORK(JWORK+1) -C - END IF - END IF -C - 30 CONTINUE -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C numbers in the next locations. -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND1 - DWORK(3) = RCOND2 - DWORK(4) = RCOND3 - DWORK(5) = RCOND4 - RETURN -C -C *** Last line of IB01PD *** - END diff --git a/slycot/src/IB01PX.f b/slycot/src/IB01PX.f deleted file mode 100644 index cf19feb4..00000000 --- a/slycot/src/IB01PX.f +++ /dev/null @@ -1,474 +0,0 @@ - SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL, - $ LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB, - $ D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To build and solve the least squares problem T*X = Kv, and -C estimate the matrices B and D of a linear time-invariant (LTI) -C state space model, using the solution X, and the singular -C value decomposition information and other intermediate results, -C provided by other routines. -C -C The matrix T is computed as a sum of Kronecker products, -C -C T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i), for i = 1 : s, -C -C (with T initialized by zero), where Uf is the triangular -C factor of the QR factorization of the future input part (see -C SLICOT Library routine IB01ND), N_i is given by the i-th block -C row of the matrix -C -C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ] [ I_L 0 ] -C [ Q_12 Q_13 ... Q_1,s-1 Q_1s 0 ] [ ] -C N = [ Q_13 Q_14 ... Q_1s 0 0 ] * [ ], -C [ : : : : : ] [ ] -C [ Q_1s 0 ... 0 0 0 ] [ 0 GaL ] -C -C and where -C -C [ -L_1|1 ] [ M_i-1 - L_1|i ] -C Q_11 = [ ], Q_1i = [ ], i = 2:s, -C [ I_L - L_2|1 ] [ -L_2|i ] -C -C are (n+L)-by-L matrices, and GaL is built from the first n -C relevant singular vectors, GaL = Un(1:L(s-1),1:n), computed -C by IB01ND. -C -C The vector Kv is vec(K), with the matrix K defined by -C -C K = [ K_1 K_2 K_3 ... K_s ], -C -C where K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. -C The given matrices are Uf, GaL, and -C -C [ L_1|1 ... L_1|s ] -C L = [ ], (n+L)-by-L*s, -C [ L_2|1 ... L_2|s ] -C -C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and -C K, (n+L)-by-m*s. -C -C Matrix M is the pseudoinverse of the matrix GaL, computed by -C SLICOT Library routine IB01PD. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies which of the matrices B and D should be -C computed, as follows: -C = 'B': compute the matrix B, but not the matrix D; -C = 'D': compute both matrices B and D. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C UF (input/output) DOUBLE PRECISION array, dimension -C ( LDUF,M*NOBR ) -C On entry, the leading M*NOBR-by-M*NOBR upper triangular -C part of this array must contain the upper triangular -C factor of the QR factorization of the future input part, -C as computed by SLICOT Library routine IB01ND. -C The strict lower triangle need not be set to zero. -C On exit, the leading M*NOBR-by-M*NOBR upper triangular -C part of this array is unchanged, and the strict lower -C triangle is set to zero. -C -C LDUF INTEGER -C The leading dimension of the array UF. -C LDUF >= MAX( 1, M*NOBR ). -C -C UN (input) DOUBLE PRECISION array, dimension ( LDUN,N ) -C The leading L*(NOBR-1)-by-N part of this array must -C contain the matrix GaL, i.e., the leading part of the -C first N columns of the matrix Un of relevant singular -C vectors. -C -C LDUN INTEGER -C The leading dimension of the array UN. -C LDUN >= L*(NOBR-1). -C -C UL (input/output) DOUBLE PRECISION array, dimension -C ( LDUL,L*NOBR ) -C On entry, the leading (N+L)-by-L*NOBR part of this array -C must contain the given matrix L. -C On exit, if M > 0, the leading (N+L)-by-L*NOBR part of -C this array is overwritten by the matrix -C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ]. -C -C LDUL INTEGER -C The leading dimension of the array UL. LDUL >= N+L. -C -C PGAL (input) DOUBLE PRECISION array, dimension -C ( LDPGAL,L*(NOBR-1) ) -C The leading N-by-L*(NOBR-1) part of this array must -C contain the pseudoinverse of the matrix GaL, computed by -C SLICOT Library routine IB01PD. -C -C LDPGAL INTEGER -C The leading dimension of the array PGAL. LDPGAL >= N. -C -C K (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR ) -C The leading (N+L)-by-M*NOBR part of this array must -C contain the given matrix K. -C -C LDK INTEGER -C The leading dimension of the array K. LDK >= N+L. -C -C R (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) ) -C The leading (N+L)*M*NOBR-by-M*(N+L) part of this array -C contains details of the complete orthogonal factorization -C of the coefficient matrix T of the least squares problem -C which is solved for getting the system matrices B and D. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 1, (N+L)*M*NOBR ). -C -C X (output) DOUBLE PRECISION array, dimension -C ( (N+L)*M*NOBR ) -C The leading M*(N+L) elements of this array contain the -C least squares solution of the system T*X = Kv. -C The remaining elements are used as workspace (to store the -C corresponding part of the vector Kv = vec(K)). -C -C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) -C The leading N-by-M part of this array contains the system -C input matrix. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= N. -C -C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) -C If JOB = 'D', the leading L-by-M part of this array -C contains the system input-output matrix. -C If JOB = 'B', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if JOB = 'D'; -C LDD >= 1, if JOB = 'B'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension ( M*(N+L) ) -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, if M > 0, DWORK(2) contains the -C reciprocal condition number of the triangular factor of -C the matrix T. -C On exit, if INFO = -26, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ). -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix T is computed, evaluating the sum of Kronecker -C products, and then the linear system T*X = Kv is solved in a -C least squares sense. The matrices B and D are then directly -C obtained from the least squares solution. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Universiteit Leuven, Sep. 2001. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDB, LDD, LDK, LDPGAL, LDR, - $ LDUF, LDUL, LDUN, LDWORK, M, N, NOBR - CHARACTER JOB -C .. Array Arguments .. - DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), K(LDK, *), - $ PGAL(LDPGAL, *), R(LDR, *), UF(LDUF, *), - $ UL(LDUL, *), UN(LDUN, *), X(*) - INTEGER IWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, TOLL - INTEGER I, IERR, J, JWORK, LDUN2, LNOBR, LP1, MAXWRK, - $ MINWRK, MKRON, MNOBR, NKRON, NP1, NPL, RANK - LOGICAL WITHB, WITHD -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGELSY, DGEMM, DLACPY, DLASET, DTRCON, MB01VD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - MNOBR = M*NOBR - LNOBR = L*NOBR - LDUN2 = LNOBR - L - LP1 = L + 1 - NP1 = N + 1 - NPL = N + L - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.WITHB ) THEN - INFO = -1 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -2 - ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LE.0 ) THEN - INFO = -5 - ELSE IF( LDUF.LT.MAX( 1, MNOBR ) ) THEN - INFO = -7 - ELSE IF( LDUN.LT.LDUN2 ) THEN - INFO = -9 - ELSE IF( LDUL.LT.NPL ) THEN - INFO = -11 - ELSE IF( LDPGAL.LT.N ) THEN - INFO = -13 - ELSE IF( LDK.LT.NPL ) THEN - INFO = -15 - ELSE IF( LDR.LT.MAX( 1, MNOBR*NPL ) ) THEN - INFO = -17 - ELSE IF( LDB.LT.N ) THEN - INFO = -20 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L ) ) THEN - INFO = -22 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 ) -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -26 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01PX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Construct the matrix [ Q_11 Q_12 ... Q_1,s-1 Q_1s ] in UL. -C - DO 20 J = 1, L -C - DO 10 I = 1, NPL - UL(I,J) = -UL(I,J) - 10 CONTINUE -C - UL(N+J,J) = ONE + UL(N+J,J) - 20 CONTINUE -C - DO 50 J = LP1, LNOBR -C - DO 30 I = 1, N - UL(I,J) = PGAL(I,J-L) - UL(I,J) - 30 CONTINUE -C - DO 40 I = NP1, NPL - UL(I,J) = -UL(I,J) - 40 CONTINUE -C - 50 CONTINUE -C -C Compute the coefficient matrix T using Kronecker products. -C Workspace: (N+L)*(N+L). -C In the same loop, vectorize K in X. -C - CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR ) - CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1), - $ LDUF ) - JWORK = NPL*L + 1 -C - DO 60 I = 1, NOBR - CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK, - $ NPL ) - IF ( I.LT.NOBR ) THEN - CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N, - $ L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN, - $ ZERO, DWORK(JWORK), NPL ) - ELSE - CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL ) - END IF - CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL, - $ NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK, - $ NPL, R, LDR, MKRON, NKRON, IERR ) - CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK, - $ X((I-1)*NKRON+1), NPL ) - 60 CONTINUE -C -C Compute the tolerance. -C - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = MKRON*NKRON*DLAMCH( 'Precision' ) -C -C Solve the least square problem T*X = vec(K). -C Workspace: need 4*M*(N+L)+1; -C prefer 3*M*(N+L)+(M*(N+L)+1)*NB. -C - DO 70 I = 1, NKRON - IWORK(I) = 0 - 70 CONTINUE -C - CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK, - $ DWORK, LDWORK, IERR ) - MAXWRK = DWORK(1) -C -C Compute the reciprocal of the condition number of the triangular -C factor R of T. -C Workspace: need 3*M*(N+L). -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND, - $ DWORK, IWORK, IERR ) -C - IF ( RANK.LT.NKRON ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 4 - END IF -C -C Construct the matrix D, if needed. -C - IF ( WITHD ) - $ CALL DLACPY( 'Full', L, M, X, NPL, D, LDD ) -C -C Construct the matrix B. -C - CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB ) -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C number in DWORK(2). -C - DWORK(1) = MAX( MINWRK, MAXWRK ) - DWORK(2) = RCOND -C - RETURN -C -C *** Last line of IB01PX *** - END diff --git a/slycot/src/IB01PY.f b/slycot/src/IB01PY.f deleted file mode 100644 index 4b4ff2f5..00000000 --- a/slycot/src/IB01PY.f +++ /dev/null @@ -1,768 +0,0 @@ - SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL, - $ R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR, - $ H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C 1. To compute the triangular (QR) factor of the p-by-L*s -C structured matrix Q, -C -C [ Q_1s Q_1,s-1 Q_1,s-2 ... Q_12 Q_11 ] -C [ 0 Q_1s Q_1,s-1 ... Q_13 Q_12 ] -C Q = [ 0 0 Q_1s ... Q_14 Q_13 ], -C [ : : : : : ] -C [ 0 0 0 ... 0 Q_1s ] -C -C and apply the transformations to the p-by-m matrix Kexpand, -C -C [ K_1 ] -C [ K_2 ] -C Kexpand = [ K_3 ], -C [ : ] -C [ K_s ] -C -C where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and -C Q_1i = u2(L*(i-1)+1:L*i,:)' is (Ls-n)-by-L, for i = 1:s, -C u2 = Un(1:L*s,n+1:L*s), K_i = K(:,(i-1)*m+1:i*m) (i = 1:s) -C is (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L), -C and -C -C [ -L_1|1 ] [ M_i-1 - L_1|i ] -C Q_11 = [ ], Q_1i = [ ], i = 2:s, -C [ I_L - L_2|1 ] [ -L_2|i ] -C -C are (n+L)-by-L matrices, and -C K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. -C The given matrices are: -C For METH = 'M', u2 = Un(1:L*s,n+1:L*s), -C K(1:Ls-n,1:m*s); -C -C [ L_1|1 ... L_1|s ] -C For METH = 'N', L = [ ], (n+L)-by-L*s, -C [ L_2|1 ... L_2|s ] -C -C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and -C K, (n+L)-by-m*s. -C Matrix M is the pseudoinverse of the matrix GaL, -C built from the first n relevant singular -C vectors, GaL = Un(1:L(s-1),1:n), and computed -C by SLICOT Library routine IB01PD for METH = 'N'. -C -C Matrix Q is triangularized (in R), exploiting its structure, -C and the transformations are applied from the left to Kexpand. -C -C 2. To estimate the matrices B and D of a linear time-invariant -C (LTI) state space model, using the factor R, transformed matrix -C Kexpand, and the singular value decomposition information provided -C by other routines. -C -C IB01PY routine is intended for speed and efficient use of the -C memory space. It is generally not recommended for METH = 'N', as -C IB01PX routine can produce more accurate results. -C -C ARGUMENTS -C -C Mode Parameters -C -C METH CHARACTER*1 -C Specifies the subspace identification method to be used, -C as follows: -C = 'M': MOESP algorithm with past inputs and outputs; -C = 'N': N4SID algorithm. -C -C JOB CHARACTER*1 -C Specifies whether or not the matrices B and D should be -C computed, as follows: -C = 'B': compute the matrix B, but not the matrix D; -C = 'D': compute both matrices B and D; -C = 'N': do not compute the matrices B and D, but only the -C R factor of Q and the transformed Kexpand. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C The number of block rows, s, in the input and output -C Hankel matrices processed by other routines. NOBR > 1. -C -C N (input) INTEGER -C The order of the system. NOBR > N > 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C RANKR1 (input) INTEGER -C The effective rank of the upper triangular matrix r1, -C i.e., the triangular QR factor of the matrix GaL, -C computed by SLICOT Library routine IB01PD. It is also -C the effective rank of the matrix GaL. 0 <= RANKR1 <= N. -C If JOB = 'N', or M = 0, or METH = 'N', this -C parameter is not used. -C -C UL (input/workspace) DOUBLE PRECISION array, dimension -C ( LDUL,L*NOBR ) -C On entry, if METH = 'M', the leading L*NOBR-by-L*NOBR -C part of this array must contain the matrix Un of -C relevant singular vectors. The first N columns of UN -C need not be specified for this routine. -C On entry, if METH = 'N', the leading (N+L)-by-L*NOBR -C part of this array must contain the given matrix L. -C On exit, the leading LDF-by-L*(NOBR-1) part of this array -C is overwritten by the matrix F of the algorithm in [4], -C where LDF = MAX( 1, L*NOBR-N-L ), if METH = 'M'; -C LDF = N, if METH = 'N'. -C -C LDUL INTEGER -C The leading dimension of the array UL. -C LDUL >= L*NOBR, if METH = 'M'; -C LDUL >= N+L, if METH = 'N'. -C -C R1 (input) DOUBLE PRECISION array, dimension ( LDR1,N ) -C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, -C the leading L*(NOBR-1)-by-N part of this array must -C contain details of the QR factorization of the matrix -C GaL, as computed by SLICOT Library routine IB01PD. -C Specifically, the leading N-by-N upper triangular part -C must contain the upper triangular factor r1 of GaL, -C and the lower L*(NOBR-1)-by-N trapezoidal part, together -C with array TAU1, must contain the factored form of the -C orthogonal matrix Q1 in the QR factorization of GaL. -C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' -C and RANKR1 < N, this array is not referenced. -C -C LDR1 INTEGER -C The leading dimension of the array R1. -C LDR1 >= L*(NOBR-1), if JOB <> 'N', M > 0, METH = 'M', -C and RANKR1 = N; -C LDR1 >= 1, otherwise. -C -C TAU1 (input) DOUBLE PRECISION array, dimension ( N ) -C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, -C this array must contain the scalar factors of the -C elementary reflectors used in the QR factorization of the -C matrix GaL, computed by SLICOT Library routine IB01PD. -C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' -C and RANKR1 < N, this array is not referenced. -C -C PGAL (input) DOUBLE PRECISION array, dimension -C ( LDPGAL,L*(NOBR-1) ) -C If METH = 'N', or JOB <> 'N', M > 0, METH = 'M' and -C RANKR1 < N, the leading N-by-L*(NOBR-1) part of this -C array must contain the pseudoinverse of the matrix GaL, -C as computed by SLICOT Library routine IB01PD. -C If METH = 'M' and JOB = 'N', or M = 0, or -C RANKR1 = N, this array is not referenced. -C -C LDPGAL INTEGER -C The leading dimension of the array PGAL. -C LDPGAL >= N, if METH = 'N', or JOB <> 'N', M > 0, -C and METH = 'M' and RANKR1 < N; -C LDPGAL >= 1, otherwise. -C -C K (input/output) DOUBLE PRECISION array, dimension -C ( LDK,M*NOBR ) -C On entry, the leading (p/s)-by-M*NOBR part of this array -C must contain the given matrix K defined above. -C On exit, the leading (p/s)-by-M*NOBR part of this array -C contains the transformed matrix K. -C -C LDK INTEGER -C The leading dimension of the array K. LDK >= p/s. -C -C R (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR ) -C If JOB = 'N', or M = 0, or Q has full rank, the -C leading L*NOBR-by-L*NOBR upper triangular part of this -C array contains the R factor of the QR factorization of -C the matrix Q. -C If JOB <> 'N', M > 0, and Q has not a full rank, the -C leading L*NOBR-by-L*NOBR upper trapezoidal part of this -C array contains details of the complete orhogonal -C factorization of the matrix Q, as constructed by SLICOT -C Library routines MB03OD and MB02QY. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= L*NOBR. -C -C H (output) DOUBLE PRECISION array, dimension ( LDH,M ) -C If JOB = 'N' or M = 0, the leading L*NOBR-by-M part -C of this array contains the updated part of the matrix -C Kexpand corresponding to the upper triangular factor R -C in the QR factorization of the matrix Q. -C If JOB <> 'N', M > 0, and METH = 'N' or METH = 'M' -C and RANKR1 < N, the leading L*NOBR-by-M part of this -C array contains the minimum norm least squares solution of -C the linear system Q*X = Kexpand, from which the matrices -C B and D are found. The first NOBR-1 row blocks of X -C appear in the reverse order in H. -C If JOB <> 'N', M > 0, METH = 'M' and RANKR1 = N, the -C leading L*(NOBR-1)-by-M part of this array contains the -C matrix product Q1'*X, and the subarray -C L*(NOBR-1)+1:L*NOBR-by-M contains the corresponding -C submatrix of X, with X defined in the phrase above. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= L*NOBR. -C -C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) -C If M > 0, JOB = 'B' or 'D' and INFO = 0, the leading -C N-by-M part of this array contains the system input -C matrix. -C If M = 0 or JOB = 'N', this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if M > 0 and JOB = 'B' or 'D'; -C LDB >= 1, if M = 0 or JOB = 'N'. -C -C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) -C If M > 0, JOB = 'D' and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix. -C If M = 0 or JOB = 'B' or 'N', this array is not -C referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'D'; -C LDD >= 1, if M = 0 or JOB = 'B' or 'N'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; an m-by-n matrix whose estimated -C condition number is less than 1/TOL is considered to -C be of full rank. If the user sets TOL <= 0, then an -C implicitly computed, default tolerance, defined by -C TOLDEF = m*n*EPS, is used instead, where EPS is the -C relative machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not used if M = 0 or JOB = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension ( LIWORK ) -C where LIWORK >= 0, if JOB = 'N', or M = 0; -C LIWORK >= L*NOBR, if JOB <> 'N', and M > 0. -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and, if JOB <> 'N', and M > 0, DWORK(2) -C contains the reciprocal condition number of the triangular -C factor of the matrix R. -C On exit, if INFO = -28, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ), -C if JOB = 'N', or M = 0; -C LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ), -C if JOB <> 'N', and M > 0. -C For good performance, LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 3: a singular upper triangular matrix was found. -C -C METHOD -C -C The QR factorization is computed exploiting the structure, -C as described in [4]. -C The matrices B and D are then obtained by solving certain -C linear systems in a least squares sense. -C -C REFERENCES -C -C [1] Verhaegen M., and Dewilde, P. -C Subspace Model Identification. Part 1: The output-error -C state-space model identification class of algorithms. -C Int. J. Control, 56, pp. 1187-1210, 1992. -C -C [2] Van Overschee, P., and De Moor, B. -C N4SID: Two Subspace Algorithms for the Identification -C of Combined Deterministic-Stochastic Systems. -C Automatica, Vol.30, No.1, pp. 75-93, 1994. -C -C [3] Van Overschee, P. -C Subspace Identification : Theory - Implementation - -C Applications. -C Ph. D. Thesis, Department of Electrical Engineering, -C Katholieke Universiteit Leuven, Belgium, Feb. 1995. -C -C [4] Sima, V. -C Subspace-based Algorithms for Multivariable System -C Identification. -C Studies in Informatics and Control, 5, pp. 335-344, 1996. -C -C NUMERICAL ASPECTS -C -C The implemented method for computing the triangular factor and -C updating Kexpand is numerically stable. -C -C FURTHER COMMENTS -C -C The computed matrices B and D are not the least squares solutions -C delivered by either MOESP or N4SID algorithms, except for the -C special case n = s - 1, L = 1. However, the computed B and D are -C frequently good enough estimates, especially for METH = 'M'. -C Better estimates could be obtained by calling SLICOT Library -C routine IB01PX, but it is less efficient, and requires much more -C workspace. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999. -C -C REVISIONS -C -C Feb. 2000, Sep. 2001, March 2005. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDB, LDD, LDH, LDK, LDPGAL, - $ LDR, LDR1, LDUL, LDWORK, M, N, NOBR, RANKR1 - CHARACTER JOB, METH -C .. Array Arguments .. - DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), H(LDH, *), - $ K(LDK, *), PGAL(LDPGAL, *), R(LDR, *), - $ R1(LDR1, *), TAU1(*), UL(LDUL, *) - INTEGER IWORK( * ) -C .. Local Scalars .. - DOUBLE PRECISION EPS, RCOND, SVLMAX, THRESH, TOLL - INTEGER I, IERR, ITAU, J, JI, JL, JM, JWORK, LDUN2, - $ LNOBR, LP1, MAXWRK, MINWRK, MNOBR, NOBRH, - $ NROW, NROWML, RANK - LOGICAL MOESP, N4SID, WITHB, WITHD -C .. Local Array .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, - $ DTRCON, DTRSM, DTRTRS, MA02AD, MB02QY, MB03OD, - $ MB04OD, MB04OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MOD -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MOESP = LSAME( METH, 'M' ) - N4SID = LSAME( METH, 'N' ) - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - MNOBR = M*NOBR - LNOBR = L*NOBR - LDUN2 = LNOBR - L - LP1 = L + 1 - IF ( MOESP ) THEN - NROW = LNOBR - N - ELSE - NROW = N + L - END IF - NROWML = NROW - L - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( MOESP .OR. N4SID ) ) THEN - INFO = -1 - ELSE IF( .NOT.( WITHB .OR. LSAME( JOB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( NOBR.LE.1 ) THEN - INFO = -3 - ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( L.LE.0 ) THEN - INFO = -6 - ELSE IF( ( MOESP .AND. WITHB .AND. M.GT.0 ) .AND. - $ ( RANKR1.LT.ZERO .OR. RANKR1.GT.N ) ) THEN - INFO = -7 - ELSE IF( ( MOESP .AND. LDUL.LT.LNOBR ) .OR. - $ ( N4SID .AND. LDUL.LT.NROW ) ) THEN - INFO = -9 - ELSE IF( LDR1.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. MOESP .AND. - $ LDR1.LT.LDUN2 .AND. RANKR1.EQ.N ) ) THEN - INFO = -11 - ELSE IF( LDPGAL.LT.1 .OR. - $ ( LDPGAL.LT.N .AND. ( N4SID .OR. ( WITHB .AND. M.GT.0 - $ .AND. ( MOESP .AND. RANKR1.LT.N ) ) ) ) ) - $ THEN - INFO = -14 - ELSE IF( LDK.LT.NROW ) THEN - INFO = -16 - ELSE IF( LDR.LT.LNOBR ) THEN - INFO = -18 - ELSE IF( LDH.LT.LNOBR ) THEN - INFO = -20 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. LDB.LT.N ) ) - $ THEN - INFO = -22 - ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. WITHD .AND. LDD.LT.L ) ) - $ THEN - INFO = -24 - ELSE -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MINWRK = MAX( 2*L, LNOBR, L + MNOBR ) - MAXWRK = MINWRK - MAXWRK = MAX( MAXWRK, L + L*ILAENV( 1, 'DGEQRF', ' ', NROW, L, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, L + LDUN2*ILAENV( 1, 'DORMQR', 'LT', - $ NROW, LDUN2, L, -1 ) ) - MAXWRK = MAX( MAXWRK, L + MNOBR*ILAENV( 1, 'DORMQR', 'LT', - $ NROW, MNOBR, L, -1 ) ) -C - IF( M.GT.0 .AND. WITHB ) THEN - MINWRK = MAX( MINWRK, 4*LNOBR+1, LNOBR + M ) - MAXWRK = MAX( MINWRK, MAXWRK, LNOBR + - $ M*ILAENV( 1, 'DORMQR', 'LT', LNOBR, M, LNOBR, - $ -1 ) ) - END IF -C - IF ( LDWORK.LT.MINWRK ) THEN - INFO = -28 - DWORK( 1 ) = MINWRK - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01PY', -INFO ) - RETURN - END IF -C -C Construct in R the first block-row of Q, i.e., the -C (p/s)-by-L*s matrix [ Q_1s ... Q_12 Q_11 ], where -C Q_1i, defined above, is (p/s)-by-L, for i = 1:s. -C - IF ( MOESP ) THEN -C - DO 10 I = 1, NOBR - CALL MA02AD( 'Full', L, NROW, UL(L*(I-1)+1,N+1), LDUL, - $ R(1,L*(NOBR-I)+1), LDR ) - 10 CONTINUE -C - ELSE - JL = LNOBR - JM = LDUN2 -C - DO 50 JI = 1, LDUN2, L -C - DO 40 J = JI + L - 1, JI, -1 -C - DO 20 I = 1, N - R(I,J) = PGAL(I,JM) - UL(I,JL) - 20 CONTINUE -C - DO 30 I = N + 1, NROW - R(I,J) = -UL(I,JL) - 30 CONTINUE -C - JL = JL - 1 - JM = JM - 1 - 40 CONTINUE -C - 50 CONTINUE -C - DO 70 J = LNOBR, LDUN2 + 1, -1 -C - DO 60 I = 1, NROW - R(I,J) = -UL(I,JL) - 60 CONTINUE -C - JL = JL - 1 - R(N+J-LDUN2,J) = ONE + R(N+J-LDUN2,J) - 70 CONTINUE - END IF -C -C Triangularize the submatrix Q_1s using an orthogonal matrix S. -C Workspace: need 2*L, prefer L+L*NB. -C - ITAU = 1 - JWORK = ITAU + L -C - CALL DGEQRF( NROW, L, R, LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Apply the transformation S' to the matrix -C [ Q_1,s-1 ... Q_11 ]. Therefore, -C -C [ R P_s-1 P_s-2 ... P_2 P_1 ] -C S'[ Q_1,s ... Q_11 ] = [ ]. -C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] -C -C Workspace: need L*NOBR, prefer L+(L*NOBR-L)*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, LDUN2, L, R, LDR, - $ DWORK(ITAU), R(1,LP1), LDR, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Apply the transformation S' to each of the submatrices K_i of -C Kexpand = [ K_1' K_2' ... K_s' ]', K_i = K(:,(i-1)*m+1:i*m) -C (i = 1:s) being (p/s)-by-m. Denote ( H_i' G_i' )' = S'K_i -C (i = 1:s), where H_i has L rows. -C Finally, H_i is saved in H(L*(i-1)+1:L*i,1:m), i = 1:s. -C (G_i is in K(L+1:p/s,(i-1)*m+1:i*m), i = 1:s.) -C Workspace: need L+M*NOBR, prefer L+M*NOBR*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, MNOBR, L, R, LDR, - $ DWORK(ITAU), K, LDK, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) -C -C Put the rows to be annihilated (matrix F) in UL(1:p/s-L,1:L*s-L). -C - CALL DLACPY( 'Full', NROWML, LDUN2, R(LP1,LP1), LDR, UL, LDUL ) -C -C Now, the structure of the transformed matrices is: -C -C [ R P_s-1 P_s-2 ... P_2 P_1 ] [ H_1 ] -C [ 0 R P_s-1 ... P_3 P_2 ] [ H_2 ] -C [ 0 0 R ... P_4 P_3 ] [ H_3 ] -C [ : : : : : ] [ : ] -C [ 0 0 0 ... R P_s-1 ] [ H_s-1 ] -C Q = [ 0 0 0 ... 0 R ], Kexpand = [ H_s ], -C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] [ G_1 ] -C [ 0 0 F_s-1 ... F_3 F_2 ] [ G_2 ] -C [ : : : : : ] [ : ] -C [ 0 0 0 ... 0 F_s-1 ] [ G_s-1 ] -C [ 0 0 0 ... 0 0 ] [ G_s ] -C -C where the block-rows have been permuted, to better exploit the -C structure. The block-rows having R on the diagonal are dealt -C with successively in the array R. -C The F submatrices are stored in the array UL, as a block-row. -C -C Copy H_1 in H(1:L,1:m). -C - CALL DLACPY( 'Full', L, M, K, LDK, H, LDH ) -C -C Triangularize the transformed matrix exploiting its structure. -C Workspace: need L+MAX(L-1,L*NOBR-2*L,M*(NOBR-1)). -C - DO 90 I = 1, NOBR - 1 -C -C Copy part of the preceding block-row and then annihilate the -C current submatrix F_s-i using an orthogonal matrix modifying -C the corresponding submatrix R. Simultaneously, apply the -C transformation to the corresponding block-rows of the matrices -C R and F. -C - CALL DLACPY( 'Upper', L, LNOBR-L*I, R(L*(I-1)+1,L*(I-1)+1), - $ LDR, R(L*I+1,L*I+1), LDR ) - CALL MB04OD( 'Full', L, LNOBR-L*(I+1), NROWML, R(L*I+1,L*I+1), - $ LDR, UL(1,L*(I-1)+1), LDUL, R(L*I+1,L*(I+1)+1), - $ LDR, UL(1,L*I+1), LDUL, DWORK(ITAU), DWORK(JWORK) - $ ) -C -C Apply the transformation to the corresponding block-rows of -C the matrix G and copy H_(i+1) in H(L*i+1:L*(i+1),1:m). -C - DO 80 J = 1, L - CALL MB04OY( NROWML, M*(NOBR-I), UL(1,L*(I-1)+J), DWORK(J), - $ K(J,M*I+1), LDK, K(LP1,1), LDK, DWORK(JWORK) ) - 80 CONTINUE -C - CALL DLACPY( 'Full', L, M, K(1,M*I+1), LDK, H(L*I+1,1), LDH ) - 90 CONTINUE -C -C Return if only the factorization is needed. -C - IF( M.EQ.0 .OR. .NOT.WITHB ) THEN - DWORK(1) = MAXWRK - RETURN - END IF -C -C Set the precision parameters. A threshold value EPS**(2/3) is -C used for deciding to use pivoting or not, where EPS is the -C relative machine precision (see LAPACK Library routine DLAMCH). -C - EPS = DLAMCH( 'Precision' ) - THRESH = EPS**( TWO/THREE ) - TOLL = TOL - IF( TOLL.LE.ZERO ) - $ TOLL = LNOBR*LNOBR*EPS - SVLMAX = ZERO -C -C Compute the reciprocal of the condition number of the triangular -C factor R of Q. -C Workspace: need 3*L*NOBR. -C - CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LNOBR, R, LDR, RCOND, - $ DWORK, IWORK, IERR ) -C - IF ( RCOND.GT.MAX( TOLL, THRESH ) ) THEN -C -C The triangular factor R is considered to be of full rank. -C Solve for X, R*X = H. -C - CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'Non-unit', - $ LNOBR, M, ONE, R, LDR, H, LDH ) - ELSE -C -C Rank-deficient triangular factor R. Compute the -C minimum-norm least squares solution of R*X = H using -C the complete orthogonal factorization of R. -C - DO 100 I = 1, LNOBR - IWORK(I) = 0 - 100 CONTINUE -C -C Workspace: need 4*L*NOBR+1; -C prefer 3*L*NOBR+(L*NOBR+1)*NB. -C - JWORK = ITAU + LNOBR - CALL DLASET( 'Lower', LNOBR-1, LNOBR, ZERO, ZERO, R(2,1), LDR ) - CALL MB03OD( 'QR', LNOBR, LNOBR, R, LDR, IWORK, TOLL, SVLMAX, - $ DWORK(ITAU), RANK, SVAL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need L*NOBR+M; prefer L*NOBR+M*NB. -C - CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR, - $ DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) - IF ( RANK.LT.LNOBR ) THEN -C -C The least squares problem is rank-deficient. -C - IWARN = 4 - END IF -C -C Workspace: need L*NOBR+max(L*NOBR,M); prefer larger. -C - CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH, - $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C -C Construct the matrix D, if needed. -C - IF ( WITHD ) - $ CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD ) -C -C Compute B by solving another linear system (possibly in -C a least squares sense). -C -C Make a block-permutation of the rows of the right-hand side, H, -C to construct the matrix -C -C [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ] -C -C in H(1:L*s-L,1:n). -C - NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1 -C - DO 120 J = 1, M -C - DO 110 I = 1, NOBRH - CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 ) - 110 CONTINUE -C - 120 CONTINUE -C -C Solve for B the matrix equation GaL*B = H(1:L*s-L,:), using -C the available QR factorization of GaL, if METH = 'M' and -C rank(GaL) = n, or the available pseudoinverse of GaL, otherwise. -C - IF ( MOESP .AND. RANKR1.EQ.N ) THEN -C -C The triangular factor r1 of GaL is considered to be of -C full rank. Compute Q1'*H in H and then solve for B, -C r1*B = H(1:n,:) in B, where Q1 is the orthogonal matrix -C in the QR factorization of GaL. -C Workspace: need M; prefer M*NB. -C - CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1, - $ TAU1, H, LDH, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C -C Compute the solution in B. -C - CALL DLACPY( 'Full', N, M, H, LDH, B, LDB ) -C - CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1, - $ B, LDB, IERR ) - IF ( IERR.GT.0 ) THEN - INFO = 3 - RETURN - END IF - ELSE -C -C Rank-deficient triangular factor r1. Use the available -C pseudoinverse of GaL for computing B from GaL*B = H. -C - CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE, - $ PGAL, LDPGAL, H, LDH, ZERO, B, LDB ) - END IF -C -C Return optimal workspace in DWORK(1) and reciprocal condition -C number in DWORK(2). -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND -C - RETURN -C -C *** Last line of IB01PY *** - END diff --git a/slycot/src/IB01QD.f b/slycot/src/IB01QD.f deleted file mode 100644 index 93bf1566..00000000 --- a/slycot/src/IB01QD.f +++ /dev/null @@ -1,1081 +0,0 @@ - SUBROUTINE IB01QD( JOBX0, JOB, N, M, L, NSMP, A, LDA, C, LDC, U, - $ LDU, Y, LDY, X0, B, LDB, D, LDD, TOL, IWORK, - $ DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the initial state and the system matrices B and D -C of a linear time-invariant (LTI) discrete-time system, given the -C matrix pair (A,C) and the input and output trajectories of the -C system. The model structure is : -C -C x(k+1) = Ax(k) + Bu(k), k >= 0, -C y(k) = Cx(k) + Du(k), -C -C where x(k) is the n-dimensional state vector (at time k), -C u(k) is the m-dimensional input vector, -C y(k) is the l-dimensional output vector, -C and A, B, C, and D are real matrices of appropriate dimensions. -C Matrix A is assumed to be in a real Schur form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX0 CHARACTER*1 -C Specifies whether or not the initial state should be -C computed, as follows: -C = 'X': compute the initial state x(0); -C = 'N': do not compute the initial state (x(0) is known -C to be zero). -C -C JOB CHARACTER*1 -C Specifies which matrices should be computed, as follows: -C = 'B': compute the matrix B only (D is known to be zero); -C = 'D': compute the matrices B and D. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples, t). -C NSMP >= N*M + a + e, where -C a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'; -C e = 0, if JOBX0 = 'X' and JOB = 'B'; -C e = 1, if JOBX0 = 'N' and JOB = 'B'; -C e = M, if JOB = 'D'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array must contain the -C system output matrix C (corresponding to the real Schur -C form of A). -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= L. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,M) -C On entry, the leading NSMP-by-M part of this array must -C contain the t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C On exit, if JOB = 'D', the leading NSMP-by-M part of -C this array contains details of the QR factorization of -C the t-by-m matrix U, possibly computed sequentially -C (see METHOD). -C If JOB = 'B', this array is unchanged on exit. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,NSMP), if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C If JOBX0 = 'X', the estimated initial state of the -C system, x(0). -C If JOBX0 = 'N', x(0) is set to zero without any -C calculations. -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C If N > 0, M > 0, and INFO = 0, the leading N-by-M -C part of this array contains the system input matrix B -C in the coordinates corresponding to the real Schur form -C of A. -C If N = 0 or M = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if N > 0 and M > 0; -C LDB >= 1, if N = 0 or M = 0. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C If M > 0, JOB = 'D', and INFO = 0, the leading -C L-by-M part of this array contains the system input-output -C matrix D. -C If M = 0 or JOB = 'B', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'D'; -C LDD >= 1, if M = 0 or JOB = 'B'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; a matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then EPS is used -C instead, where EPS is the relative machine precision -C (see LAPACK Library routine DLAMCH). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= N*M + a, if JOB = 'B', -C LIWORK >= max( N*M + a, M ), if JOB = 'D', -C with a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; DWORK(2) contains the reciprocal condition -C number of the triangular factor of the QR factorization of -C the matrix W2 (see METHOD); if M > 0 and JOB = 'D', -C DWORK(3) contains the reciprocal condition number of the -C triangular factor of the QR factorization of U. -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( LDW1, min( LDW2, LDW3 ) ), where -C LDW1 = 2, if M = 0 or JOB = 'B', -C LDW1 = 3, if M > 0 and JOB = 'D', -C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), -C LDW2 = LDWa, if M = 0 or JOB = 'B', -C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C LDWb = (b + r)*(r + 1) + -C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), -C LDW3 = LDWb, if M = 0 or JOB = 'B', -C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), -C if M > 0 and JOB = 'D', -C r = N*M + a, -C a = 0, if JOBX0 = 'N', -C a = N, if JOBX0 = 'X'; -C b = 0, if JOB = 'B', -C b = L*M, if JOB = 'D'; -C c = 0, if JOBX0 = 'N', -C c = L*N, if JOBX0 = 'X'; -C d = 0, if JOBX0 = 'N', -C d = 2*N*N + N, if JOBX0 = 'X'; -C f = 2*r, if JOB = 'B' or M = 0, -C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; -C q = b + r*L. -C For good performance, LDWORK should be larger. -C If LDWORK >= LDW2 or -C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + -C max( d, f ), -C then standard QR factorizations of the matrices U and/or -C W2 (see METHOD) are used. -C Otherwise, the QR factorizations are computed sequentially -C by performing NCYCLE cycles, each cycle (except possibly -C the last one) processing s < t samples, where s is -C chosen from the equation -C LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + -C max( d, f ). -C (s is at least N*M+a+e, the minimum value of NSMP.) -C The computational effort may increase and the accuracy may -C decrease with the decrease of s. Recommended value is -C LDWORK = LDW2, assuming a large enough cache size, to -C also accommodate A, C, U, and Y. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C An extension and refinement of the method in [1,2] is used. -C Specifically, denoting -C -C X = [ vec(D')' vec(B)' x0' ]', -C -C where vec(M) is the vector obtained by stacking the columns of -C the matrix M, then X is the least squares solution of the -C system S*X = vec(Y), with the matrix S = [ diag(U) W ], -C defined by -C -C ( U | | ... | | | ... | | ) -C ( U | 11 | ... | n1 | 12 | ... | nm | ) -C S = ( : | y | ... | y | y | ... | y | P*Gamma ), -C ( : | | ... | | | ... | | ) -C ( U | | ... | | | ... | | ) -C ij -C diag(U) having L block rows and columns. In this formula, y -C are the outputs of the system for zero initial state computed -C using the following model, for j = 1:m, and for i = 1:n, -C ij ij ij -C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, -C -C ij ij -C y (k) = Cx (k), -C -C where e_i is the i-th n-dimensional unit vector, Gamma is -C given by -C -C ( C ) -C ( C*A ) -C Gamma = ( C*A^2 ), -C ( : ) -C ( C*A^(t-1) ) -C -C and P is a permutation matrix that groups together the rows of -C Gamma depending on the same row of C, namely -C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. -C The first block column, diag(U), is not explicitly constructed, -C but its structure is exploited. The last block column is evaluated -C using powers of A with exponents 2^k. No interchanges are applied. -C A special QR decomposition of the matrix S is computed. Let -C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where -C r is M-by-M. Then, diag(q') is applied to W and vec(Y). -C The block-rows of S and vec(Y) are implicitly permuted so that -C matrix S becomes -C -C ( diag(r) W1 ) -C ( 0 W2 ), -C -C where W1 has L*M rows. Then, the QR decomposition of W2 is -C computed (sequentially, if M > 0) and used to obtain B and x0. -C The intermediate results and the QR decomposition of U are -C needed to find D. If a triangular factor is too ill conditioned, -C then singular value decomposition (SVD) is employed. SVD is not -C generally needed if the input sequence is sufficiently -C persistently exciting and NSMP is large enough. -C If the matrix W cannot be stored in the workspace (i.e., -C LDWORK < LDW2), the QR decompositions of W2 and U are -C computed sequentially. -C -C REFERENCES -C -C [1] Verhaegen M., and Varga, A. -C Some Experience with the MOESP Class of Subspace Model -C Identification Methods in Identifying the BO105 Helicopter. -C Report TR R165-94, DLR Oberpfaffenhofen, 1994. -C -C [2] Sima, V., and Varga, A. -C RASP-IDENT : Subspace Model Identification Programs. -C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., -C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C FURTHER COMMENTS -C -C The algorithm for computing the system matrices B and D is -C less efficient than the MOESP or N4SID algorithms implemented in -C SLICOT Library routine IB01PD, because a large least squares -C problem has to be solved, but the accuracy is better, as the -C computed matrices B and D are fitted to the input and output -C trajectories. However, if matrix A is unstable, the computed -C matrices B and D could be inaccurate. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, - $ LDWORK, LDY, M, N, NSMP - CHARACTER JOB, JOBX0 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, RCONDU, TOLL - INTEGER I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, - $ IG, IGAM, IGS, INI, INIH, INIR, INIS, INY, - $ INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU, - $ ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J, - $ JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB, - $ MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL, - $ NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK - LOGICAL FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0 -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, - $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM, - $ MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD -C .. Executable Statements .. -C -C Check the input parameters. -C - WITHD = LSAME( JOB, 'D' ) - WITHB = LSAME( JOB, 'B' ) .OR. WITHD - WITHX0 = LSAME( JOBX0, 'X' ) -C - IWARN = 0 - INFO = 0 - LM = L*M - LN = L*N - NN = N*N - NM = N*M - N2M = N*NM - NCOL = NM - IF( WITHX0 ) - $ NCOL = NCOL + N - MINSMP = NCOL - IF( WITHD ) THEN - MINSMP = MINSMP + M - IQ = MINSMP - ELSE IF ( .NOT.WITHX0 ) THEN - IQ = MINSMP - MINSMP = MINSMP + 1 - ELSE - IQ = MINSMP - END IF -C - IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.WITHB ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LE.0 ) THEN - INFO = -5 - ELSE IF( NSMP.LT.MINSMP ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.L ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -12 - ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) - $ THEN - INFO = -17 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -19 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -20 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - NSMPL = NSMP*L - IQ = IQ*L - NCP1 = NCOL + 1 - ISIZE = NSMPL*NCP1 - IF ( N.GT.0 .AND. WITHX0 ) THEN - IC = 2*NN + N - ELSE - IC = 0 - END IF - MINWLS = NCOL*NCP1 - IF ( WITHD ) - $ MINWLS = MINWLS + LM*NCP1 - IF ( M.GT.0 .AND. WITHD ) THEN - IA = M + MAX( 2*NCOL, M ) - ELSE - IA = 2*NCOL - END IF - ITAU = N2M + MAX( IC, IA ) - IF ( WITHX0 ) - $ ITAU = ITAU + LN - LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) - LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) - IF ( M.GT.0 .AND. WITHD ) THEN - LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) - LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) - END IF - MINWRK = MIN( LDW2, LDW3 ) - MINWRK = MAX( MINWRK, 2 ) - IF ( M.GT.0 .AND. WITHD ) - $ MINWRK = MAX( MINWRK, 3 ) - IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN - IF ( M.GT.0 .AND. WITHD ) THEN - MAXWRK = ISIZE + N + M + - $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ), - $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M, - $ NCOL, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, ISIZE + N + M + - $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP, - $ NCP1, M, -1 ), - $ NCOL + ILAENV( 1, 'DORMQR', 'LT', - $ NSMP-M, 1, NCOL, -1 ) ) ) - ELSE - MAXWRK = ISIZE + N + NCOL + - $ MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL, - $ -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL, - $ -1 ) ) - END IF - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF -C - IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN - INFO = -23 - DWORK(1) = MINWRK - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M ).EQ.0 ) THEN - DWORK(2) = ONE - IF ( M.GT.0 .AND. WITHD ) THEN - DWORK(1) = THREE - DWORK(3) = ONE - ELSE - DWORK(1) = TWO - END IF - RETURN - END IF -C -C Set up the least squares problem, either directly, if enough -C workspace, or sequentially, otherwise. -C - IYPNT = 1 - IUPNT = 1 - LDDW = ( LDWORK - MINWLS - ITAU )/NCP1 - NOBS = MIN( NSMP, LDDW/L ) -C - IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN -C -C Enough workspace for solving the problem directly. -C - NCYCLE = 1 - NOBS = NSMP - LDDW = MAX( 1, NSMPL ) - IF ( WITHD ) THEN - INIR = M + 1 - ELSE - INIR = 1 - END IF - INY = 1 - INIS = 1 - ELSE -C -C NCYCLE > 1 cycles are needed for solving the problem -C sequentially, taking NOBS samples in each cycle (or the -C remaining samples in the last cycle). -C - LNOB = L*NOBS - LDDW = MAX( 1, LNOB ) - NCYCLE = NSMP/NOBS - IF ( MOD( NSMP, NOBS ).NE.0 ) - $ NCYCLE = NCYCLE + 1 - INIR = 1 - INIH = INIR + NCOL*NCOL - INIS = INIH + NCOL - IF ( WITHD ) THEN - INY = INIS + LM*NCP1 - ELSE - INY = INIS - END IF - END IF -C - NCYC = NCYCLE.GT.1 - INYGAM = INY + LDDW*NM - IRHS = INY + LDDW*NCOL - IXINIT = IRHS + LDDW - IF( NCYC ) THEN - IC = IXINIT + N2M - IF ( WITHX0 ) THEN - IA = IC + LN - ELSE - IA = IC - END IF - LDR = MAX( 1, NCOL ) - IE = INY - ELSE - IF ( WITHD ) THEN - INIH = IRHS + M - ELSE - INIH = IRHS - END IF - IA = IXINIT + N - LDR = LDDW - IE = IXINIT - END IF - IF ( N.GT.0 .AND. WITHX0 ) - $ IAS = IA + NN -C - ITAUU = IA - IF ( WITHD ) THEN - ITAU = ITAUU + M - ELSE - ITAU = ITAUU - END IF - DUM(1) = ZERO -C - DO 190 ICYCLE = 1, NCYCLE - FIRST = ICYCLE.EQ.1 - IF ( .NOT.FIRST ) THEN - IF ( ICYCLE.EQ.NCYCLE ) THEN - NOBS = NSMP - ( NCYCLE - 1 )*NOBS - LNOB = L*NOBS - END IF - END IF -C - IY = INY - IXSAVE = IXINIT -C -C Compute the M*N output trajectories for zero initial state -C or for the saved final state value of the previous cycle. -C This can be performed in parallel. -C Workspace: need s*L*(r + 1) + b + w, -C where r = M*N + a, s = NOBS, -C a = 0, if JOBX0 = 'N'; -C a = N, if JOBX0 = 'X'; -C b = N, if NCYCLE = 1; -C b = N*N*M, if NCYCLE > 1; -C w = 0, if NCYCLE = 1; -C w = r*(r+1), if NCYCLE > 1, JOB = 'B'; -C w = (M*L+r)*(r+1), if NCYCLE > 1, JOB = 'D'. -C - DO 40 J = 1, M - DO 30 I = 1, N -C ij -C Compute the y trajectory and put the vectorized form -C of it in an appropriate column of DWORK. To gain in -C efficiency, a specialization of SLICOT Library routine -C TF01ND is used. -C - IF ( FIRST ) - $ CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 ) - CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 ) - INI = IY -C - DO 20 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1, - $ ZERO, DWORK(IY), NOBS ) - IY = IY + 1 - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 10 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2) - 10 CONTINUE -C - X0(I) = X0(I) + U(IUPNT+K-1,J) - CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 ) - 20 CONTINUE -C - IF ( NCYC ) - $ IXSAVE = IXSAVE + N - IY = INI + LDDW - 30 CONTINUE -C - 40 CONTINUE -C - IF ( N.GT.0 .AND. WITHX0 ) THEN -C -C Compute the permuted extended observability matrix Gamma -C ij -C in the following N columns of DWORK (after the y -C trajectories). Gamma is directly constructed in the -C required row structure. -C Workspace: need s*L*(r + 1) + 2*N*N + N + b + c + w, -C where c = 0, if NCYCLE = 1; -C c = L*N, if NCYCLE > 1. -C - JWORK = IAS + NN - IG = INYGAM - IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) - IREM = NOBS - 2**IEXPON - POWER2 = IREM.EQ.0 - IF ( .NOT.POWER2 ) - $ IEXPON = IEXPON + 1 -C - IF ( FIRST ) THEN -C - DO 50 I = 1, N - CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS ) - IG = IG + LDDW - 50 CONTINUE -C - ELSE -C - DO 60 I = IC, IC + LN - 1, L - CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS ) - IG = IG + LDDW - 60 CONTINUE -C - END IF -C p -C Use powers of the matrix A: A , p = 2**(J-1). -C - CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) - IF( N.GT.1 ) - $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) - I2 = 1 - NROW = 0 -C - DO 90 J = 1, IEXPON - IGAM = INYGAM - IF ( J.LT.IEXPON .OR. POWER2 ) THEN - NROW = I2 - ELSE - NROW = IREM - END IF -C - DO 80 I = 1, L - CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW, - $ DWORK(IGAM+I2), LDDW ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', - $ 'Non Unit', NROW, N, ONE, DWORK(IA), N, - $ DWORK(IGAM+I2), LDDW ) - IG = IGAM -C p -C Compute the contribution of the subdiagonal of A -C to the product. -C - DO 70 IX = 1, N - 1 - CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), - $ DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 ) - IG = IG + LDDW - 70 CONTINUE -C - IGAM = IGAM + NOBS - 80 CONTINUE -C - IF ( J.LT.IEXPON ) THEN - CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), - $ N ) - IF( N.GT.1 ) - $ CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), - $ N+1 ) - CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, - $ DWORK(JWORK), IERR ) - I2 = I2*2 - END IF - 90 CONTINUE -C - IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN - IG = INYGAM + I2 + NROW - 1 - IGS = IG -C - DO 100 I = IC, IC + LN - 1, L - CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 ) - IG = IG + LDDW - 100 CONTINUE -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', - $ L, N, ONE, A, LDA, DWORK(IC), L ) - IG = IGS -C -C Compute the contribution of the subdiagonal of A to the -C product. -C - DO 110 IX = 1, N - 1 - CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS, - $ DWORK(IC+(IX-1)*L), 1 ) - IG = IG + LDDW - 110 CONTINUE -C - END IF - END IF -C -C Setup (part of) the right hand side of the least squares -C problem. -C - IY = IRHS -C - DO 120 K = 1, L - CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 ) - IY = IY + NOBS - 120 CONTINUE -C -C Compress the data using a special QR factorization. -C Workspace: need v + y, -C where v = s*L*(r + 1) + b + c + w + x, -C x = M, y = max( 2*r, M ), -C if JOB = 'D' and M > 0, -C x = 0, y = 2*r, if JOB = 'B' or M = 0. -C - IF ( M.GT.0 .AND. WITHD ) THEN -C -C Case 1: D is requested. -C - JWORK = ITAU - IF ( FIRST ) THEN - INI = INY + M -C -C Compress the first or single segment of U, U1 = Q1*R1. -C Workspace: need v + M; -C prefer v + M*NB. -C - CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C ij -C Apply diag(Q1') to the matrix [ y Gamma Y ]. -C Workspace: need v + r + 1, -C prefer v + (r + 1)*NB. -C - DO 130 K = 1, L - CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U, - $ LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS), - $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, - $ IERR ) - 130 CONTINUE -C - IF ( NCOL.GT.0 ) THEN -C -C Compress the first part of the first data segment of -C ij -C [ y Gamma ]. -C Workspace: need v + 2*r, -C prefer v + r + r*NB. -C - JWORK = ITAU + NCOL - CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW, - $ DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Apply the transformation to the corresponding right -C hand side part. -C Workspace: need v + r + 1, -C prefer v + r + NB. -C - CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL, - $ DWORK(INI), LDDW, DWORK(ITAU), - $ DWORK(IRHS+M), LDDW, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) -C -C Compress the remaining parts of the first data segment -C ij -C of [ y Gamma ]. -C Workspace: need v + r - 1. -C - DO 140 K = 2, L - CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI), - $ LDDW, DWORK(INI+(K-1)*NOBS), LDDW, - $ DWORK(IRHS+M), LDDW, - $ DWORK(IRHS+M+(K-1)*NOBS), LDDW, - $ DWORK(ITAU), DWORK(JWORK) ) - 140 CONTINUE -C - END IF -C - IF ( NCYC ) THEN -C ij -C Save the triangular factor of [ y Gamma ], the -C corresponding right hand side, and the first M rows -C in each NOBS group of rows. -C Workspace: need v. -C - CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW, - $ DWORK(INIR), LDR ) -C - DO 150 K = 1, L - CALL DLACPY( 'Full', M, NCP1, - $ DWORK(INY +(K-1)*NOBS), LDDW, - $ DWORK(INIS+(K-1)*M), LM ) - 150 CONTINUE -C - END IF - ELSE -C -C Compress the current data segment of U, Ui = Qi*Ri, -C i = ICYCLE. -C Workspace: need v + r + 1. -C - CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1), - $ LDU, DWORK(INIS), LM, DWORK(INY), LDDW, - $ DWORK(ITAUU), DWORK(JWORK) ) -C -C Apply diag(Qi') to the appropriate part of the matrix -C ij -C [ y Gamma Y ]. -C Workspace: need v + r + 1. -C - DO 170 K = 2, L -C - DO 160 IX = 1, M - CALL MB04OY( NOBS, NCP1, U(IUPNT,IX), - $ DWORK(ITAUU+IX-1), - $ DWORK(INIS+(K-1)*M+IX-1), LM, - $ DWORK(INY+(K-1)*NOBS), LDDW, - $ DWORK(JWORK) ) - 160 CONTINUE -C - 170 CONTINUE -C - IF ( NCOL.GT.0 ) THEN -C - JWORK = ITAU + NCOL -C -C Compress the current (but not the first) data segment -C ij -C of [ y Gamma ]. -C Workspace: need v + r - 1. -C - DO 180 K = 1, L - CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR), - $ LDR, DWORK(INY+(K-1)*NOBS), LDDW, - $ DWORK(INIH), LDR, - $ DWORK(IRHS+(K-1)*NOBS), LDDW, - $ DWORK(ITAU), DWORK(JWORK) ) - 180 CONTINUE -C - END IF - END IF -C - ELSE IF ( NCOL.GT.0 ) THEN -C -C Case 2: D is known to be zero. -C - JWORK = ITAU + NCOL - IF ( FIRST ) THEN -C -C Compress the first or single data segment of -C ij -C [ y Gamma ]. -C Workspace: need v + 2*r, -C prefer v + r + r*NB. -C - CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Apply the transformation to the right hand side. -C Workspace: need v + r + 1, -C prefer v + r + NB. -C - CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL, - $ DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS), - $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( NCYC ) THEN -C ij -C Save the triangular factor of [ y Gamma ] and the -C corresponding right hand side. -C Workspace: need v. -C - CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW, - $ DWORK(INIR), LDR ) - END IF - ELSE -C -C Compress the current (but not the first) data segment. -C Workspace: need v + r - 1. -C - CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR, - $ DWORK(INY), LDDW, DWORK(INIH), LDR, - $ DWORK(IRHS), LDDW, DWORK(ITAU), - $ DWORK(JWORK) ) - END IF - END IF -C - IUPNT = IUPNT + NOBS - IYPNT = IYPNT + NOBS - 190 CONTINUE -C -C Estimate the reciprocal condition number of the triangular factor -C of the QR decomposition. -C Workspace: need u + 3*r, where -C u = t*L*(r + 1), if NCYCLE = 1; -C u = w, if NCYCLE > 1. -C - CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR), - $ LDR, RCOND, DWORK(IE), IWORK, IERR ) -C - TOLL = TOL - IF ( TOLL.LE.ZERO ) - $ TOLL = DLAMCH( 'Precision' ) - IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN - IWARN = 4 -C -C The least squares problem is ill-conditioned. -C Use SVD to solve it. -C Workspace: need u + 6*r; -C prefer larger. -C - IF ( NCOL.GT.1 ) - $ CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO, - $ DWORK(INIR+1), LDR ) - ISV = IE - JWORK = ISV + NCOL - CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, - $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( IERR.GT.0 ) THEN -C -C Return if SVD algorithm did not converge. -C - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) - ELSE -C -C Find the least squares solution using QR decomposition only. -C - CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL, - $ 1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR ) - END IF -C -C Setup the estimated n-by-m input matrix B, and the estimated -C initial state of the system x0. -C - CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB ) -C - IF ( N.GT.0 .AND. WITHX0 ) THEN - CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 ) - ELSE - CALL DCOPY( N, DUM, 0, X0, 1 ) - END IF -C - IF ( M.GT.0 .AND. WITHD ) THEN -C -C Compute the estimated l-by-m input/output matrix D. -C - IF ( NCYC ) THEN - IRHS = INIS + LM*NCOL - CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS), - $ LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 ) - ELSE -C - DO 200 K = 1, L - CALL DGEMV( 'No Transpose', M, NCOL, -ONE, - $ DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1, - $ ONE, DWORK(IRHS+(K-1)*NOBS), 1 ) - 200 CONTINUE -C - DO 210 K = 2, L - CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1, - $ DWORK(IRHS+(K-1)*M), 1 ) - 210 CONTINUE -C - END IF -C -C Estimate the reciprocal condition number of the triangular -C factor of the QR decomposition of the matrix U. -C Workspace: need u + 3*M. -C - CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU, - $ RCONDU, DWORK(IE), IWORK, IERR ) - IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN - IWARN = 4 -C -C The least squares problem is ill-conditioned. -C Use SVD to solve it. (QR decomposition of U is preserved.) -C Workspace: need u + 2*M*M + 6*M; -C prefer larger. -C - IQ = IE + M*M - ISV = IQ + M*M - JWORK = ISV + M - CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M ) - CALL MB02UD( 'Not Factored', 'Left', 'No Transpose', - $ 'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE), - $ M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M, - $ DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR ) - IF ( IERR.GT.0 ) THEN -C -C Return if SVD algorithm did not converge. -C - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) - ELSE - CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M, - $ L, ONE, U, LDU, DWORK(IRHS), M ) - END IF - CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD ) -C - END IF -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND - IF ( M.GT.0 .AND. WITHD ) - $ DWORK(3) = RCONDU -C - RETURN -C -C *** End of IB01QD *** - END diff --git a/slycot/src/IB01RD.f b/slycot/src/IB01RD.f deleted file mode 100644 index b5eaf612..00000000 --- a/slycot/src/IB01RD.f +++ /dev/null @@ -1,762 +0,0 @@ - SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D, - $ LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the initial state of a linear time-invariant (LTI) -C discrete-time system, given the system matrices (A,B,C,D) and -C the input and output trajectories of the system. The model -C structure is : -C -C x(k+1) = Ax(k) + Bu(k), k >= 0, -C y(k) = Cx(k) + Du(k), -C -C where x(k) is the n-dimensional state vector (at time k), -C u(k) is the m-dimensional input vector, -C y(k) is the l-dimensional output vector, -C and A, B, C, and D are real matrices of appropriate dimensions. -C Matrix A is assumed to be in a real Schur form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies whether or not the matrix D is zero, as follows: -C = 'Z': the matrix D is zero; -C = 'N': the matrix D is not zero. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L > 0. -C -C NSMP (input) INTEGER -C The number of rows of matrices U and Y (number of -C samples used, t). NSMP >= N. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A in a real Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B (corresponding to the real Schur -C form of A). -C If N = 0 or M = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= N, if N > 0 and M > 0; -C LDB >= 1, if N = 0 or M = 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array must contain the -C system output matrix C (corresponding to the real Schur -C form of A). -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= L. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading L-by-M part of this array must contain the -C system input-output matrix. -C If M = 0 or JOB = 'Z', this array is not referenced. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= L, if M > 0 and JOB = 'N'; -C LDD >= 1, if M = 0 or JOB = 'Z'. -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C If M > 0, the leading NSMP-by-M part of this array must -C contain the t-by-m input-data sequence matrix U, -C U = [u_1 u_2 ... u_m]. Column j of U contains the -C NSMP values of the j-th input component for consecutive -C time increments. -C If M = 0, this array is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,NSMP), if M > 0; -C LDU >= 1, if M = 0. -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,L) -C The leading NSMP-by-L part of this array must contain the -C t-by-l output-data sequence matrix Y, -C Y = [y_1 y_2 ... y_l]. Column j of Y contains the -C NSMP values of the j-th output component for consecutive -C time increments. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C The estimated initial state of the system, x(0). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for estimating the rank of -C matrices. If the user sets TOL > 0, then the given value -C of TOL is used as a lower bound for the reciprocal -C condition number; a matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then EPS is used -C instead, where EPS is the relative machine precision -C (see LAPACK Library routine DLAMCH). TOL <= 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains the reciprocal condition -C number of the triangular factor of the QR factorization of -C the matrix Gamma (see METHOD). -C On exit, if INFO = -22, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 2, min( LDW1, LDW2 ) ), where -C LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), -C LDW2 = N*(N + 1) + 2*N + -C max( q*(N + 1) + 2*N*N + L*N, 4*N ), -C q = N*L. -C For good performance, LDWORK should be larger. -C If LDWORK >= LDW1, then standard QR factorization of -C the matrix Gamma (see METHOD) is used. Otherwise, the -C QR factorization is computed sequentially by performing -C NCYCLE cycles, each cycle (except possibly the last one) -C processing s samples, where s is chosen by equating -C LDWORK to LDW2, for q replaced by s*L. -C The computational effort may increase and the accuracy may -C decrease with the decrease of s. Recommended value is -C LDRWRK = LDW1, assuming a large enough cache size, to -C also accommodate A, B, C, D, U, and Y. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 4: the least squares problem to be solved has a -C rank-deficient coefficient matrix. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: the singular value decomposition (SVD) algorithm did -C not converge. -C -C METHOD -C -C An extension and refinement of the method in [1] is used. -C Specifically, the output y0(k) of the system for zero initial -C state is computed for k = 0, 1, ..., t-1 using the given model. -C Then the following least squares problem is solved for x(0) -C -C ( C ) ( y(0) - y0(0) ) -C ( C*A ) ( y(1) - y0(1) ) -C Gamma * x(0) = ( : ) * x(0) = ( : ). -C ( : ) ( : ) -C ( C*A^(t-1) ) ( y(t-1) - y0(t-1) ) -C -C The coefficient matrix Gamma is evaluated using powers of A with -C exponents 2^k. The QR decomposition of this matrix is computed. -C If its triangular factor R is too ill conditioned, then singular -C value decomposition of R is used. -C -C If the coefficient matrix cannot be stored in the workspace (i.e., -C LDWORK < LDW1), the QR decomposition is computed sequentially. -C -C REFERENCES -C -C [1] Verhaegen M., and Varga, A. -C Some Experience with the MOESP Class of Subspace Model -C Identification Methods in Identifying the BO105 Helicopter. -C Report TR R165-94, DLR Oberpfaffenhofen, 1994. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Identification methods; least squares solutions; multivariable -C systems; QR decomposition; singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C IBLOCK is a threshold value for switching to a block algorithm -C for U (to avoid row by row passing through U). - INTEGER IBLOCK - PARAMETER ( IBLOCK = 16384 ) -C .. Scalar Arguments .. - DOUBLE PRECISION TOL - INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, - $ LDWORK, LDY, M, N, NSMP - CHARACTER JOB -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), - $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION RCOND, TOLL - INTEGER I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, - $ IG, INIGAM, INIH, INIR, INIT, IQ, IREM, IRHS, - $ ISIZE, ISV, ITAU, IU, IUPNT, IUT, IUTRAN, IX, - $ IXINIT, IY, IYPNT, J, JWORK, K, LDDW, LDR, - $ LDW1, LDW2, MAXWRK, MINSMP, MINWLS, MINWRK, NC, - $ NCP1, NCYCLE, NN, NOBS, NRBL, NROW, NSMPL, RANK - LOGICAL BLOCK, FIRST, NCYC, POWER2, SWITCH, WITHD -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, - $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSV, - $ MA02AD, MB01TD, MB04OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD -C .. Executable Statements .. -C -C Check the input parameters. -C - WITHD = LSAME( JOB, 'N' ) - IWARN = 0 - INFO = 0 - NN = N*N - MINSMP = N -C - IF( .NOT.( LSAME( JOB, 'Z' ) .OR. WITHD ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LE.0 ) THEN - INFO = -4 - ELSE IF( NSMP.LT.MINSMP ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.L ) THEN - INFO = -11 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) - $ THEN - INFO = -13 - ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN - INFO = -15 - ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -17 - ELSE IF( TOL.GT.ONE ) THEN - INFO = -19 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - NSMPL = NSMP*L - IQ = MINSMP*L - NCP1 = N + 1 - ISIZE = NSMPL*NCP1 - IC = 2*NN - MINWLS = MINSMP*NCP1 - ITAU = IC + L*N - LDW1 = ISIZE + 2*N + MAX( IC, 4*N ) - LDW2 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) - MINWRK = MAX( MIN( LDW1, LDW2 ), 2 ) - IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN - MAXWRK = ISIZE + 2*N + MAX( N*ILAENV( 1, 'DGEQRF', ' ', NSMPL, - $ N, -1, -1 ), - $ ILAENV( 1, 'DORMQR', 'LT', NSMPL, - $ 1, N, -1 ) ) - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF -C - IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN - INFO = -22 - DWORK(1) = MINWRK - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C Set up the least squares problem, either directly, if enough -C workspace, or sequentially, otherwise. -C - IYPNT = 1 - IUPNT = 1 - INIR = 1 - IF ( LDWORK.GE.LDW1 ) THEN -C -C Enough workspace for solving the problem directly. -C - NCYCLE = 1 - NOBS = NSMP - LDDW = NSMPL - INIGAM = 1 - ELSE -C -C NCYCLE > 1 cycles are needed for solving the problem -C sequentially, taking NOBS samples in each cycle (or the -C remaining samples in the last cycle). -C - JWORK = LDWORK - MINWLS - 2*N - ITAU - LDDW = JWORK/NCP1 - NOBS = LDDW/L - LDDW = L*NOBS - NCYCLE = NSMP/NOBS - IF ( MOD( NSMP, NOBS ).NE.0 ) - $ NCYCLE = NCYCLE + 1 - INIH = INIR + NN - INIGAM = INIH + N - END IF -C - NCYC = NCYCLE.GT.1 - IRHS = INIGAM + LDDW*N - IXINIT = IRHS + LDDW - IC = IXINIT + N - IF( NCYC ) THEN - IA = IC + L*N - LDR = N - IE = INIGAM - ELSE - INIH = IRHS - IA = IC - LDR = LDDW - IE = IXINIT - END IF - IUTRAN = IA - IAS = IA + NN - ITAU = IA - DUM(1) = ZERO -C -C Set block parameters for passing through the array U. -C - BLOCK = M.GT.1 .AND. NSMP*M.GE.IBLOCK - IF ( BLOCK ) THEN - NRBL = ( LDWORK - IUTRAN + 1 )/M - NC = NOBS/NRBL - IF ( MOD( NOBS, NRBL ).NE.0 ) - $ NC = NC + 1 - INIT = ( NC - 1 )*NRBL - BLOCK = BLOCK .AND. NRBL.GT.1 - END IF -C -C Perform direct of sequential compression of the matrix Gamma. -C - DO 150 ICYCLE = 1, NCYCLE - FIRST = ICYCLE.EQ.1 - IF ( .NOT.FIRST ) THEN - IF ( ICYCLE.EQ.NCYCLE ) THEN - NOBS = NSMP - ( NCYCLE - 1 )*NOBS - LDDW = L*NOBS - IF ( BLOCK ) THEN - NC = NOBS/NRBL - IF ( MOD( NOBS, NRBL ).NE.0 ) - $ NC = NC + 1 - INIT = ( NC - 1 )*NRBL - END IF - END IF - END IF -C -C Compute the extended observability matrix Gamma. -C Workspace: need s*L*(N + 1) + 2*N*N + 2*N + a + w, -C where s = NOBS, -C a = 0, w = 0, if NCYCLE = 1, -C a = L*N, w = N*(N + 1), if NCYCLE > 1; -C prefer as above, with s = t, a = w = 0. -C - JWORK = IAS + NN - IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) - IREM = L*( NOBS - 2**IEXPON ) - POWER2 = IREM.EQ.0 - IF ( .NOT.POWER2 ) - $ IEXPON = IEXPON + 1 -C - IF ( FIRST ) THEN - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(INIGAM), LDDW ) - ELSE - CALL DLACPY( 'Full', L, N, DWORK(IC), L, DWORK(INIGAM), - $ LDDW ) - END IF -C p -C Use powers of the matrix A: A , p = 2**(J-1). -C - CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) - IF ( N.GT.1 ) - $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) - I2 = L - NROW = 0 -C - DO 20 J = 1, IEXPON - IG = INIGAM - IF ( J.LT.IEXPON .OR. POWER2 ) THEN - NROW = I2 - ELSE - NROW = IREM - END IF -C - CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2), - $ LDDW ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', - $ NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2), - $ LDDW ) -C p -C Compute the contribution of the subdiagonal of A to the -C product. -C - DO 10 IX = 1, N - 1 - CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW), - $ 1, DWORK(IG+I2), 1 ) - IG = IG + LDDW - 10 CONTINUE -C - IF ( J.LT.IEXPON ) THEN - CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), N ) - CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), N+1 ) - CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, - $ DWORK(JWORK), IERR ) - I2 = I2*2 - END IF - 20 CONTINUE -C - IF ( NCYC ) THEN - IG = INIGAM + I2 + NROW - L - CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L, - $ N, ONE, A, LDA, DWORK(IC), L ) -C -C Compute the contribution of the subdiagonal of A to the -C product. -C - DO 30 IX = 1, N - 1 - CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1, - $ DWORK(IC+(IX-1)*L), 1 ) - IG = IG + LDDW - 30 CONTINUE -C - END IF -C -C Setup (part of) the right hand side of the least squares -C problem starting from DWORK(IRHS); use the estimated output -C trajectory for zero initial state, or for the saved final state -C value of the previous cycle. -C A specialization of SLICOT Library routine TF01ND is used. -C For large input sets (NSMP*M >= IBLOCK), chunks of U are -C transposed, to reduce the number of row-wise passes. -C Workspace: need s*L*(N + 1) + N + w; -C prefer as above, with s = t, w = 0. -C - IF ( FIRST ) - $ CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 ) - CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 ) - IY = IRHS -C - DO 40 J = 1, L - CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L ) - IY = IY + 1 - 40 CONTINUE -C - IY = IRHS - IU = IUPNT - IF ( M.GT.0 ) THEN - IF ( WITHD ) THEN -C - IF ( BLOCK ) THEN - SWITCH = .TRUE. - NROW = NRBL -C - DO 60 K = 1, NOBS - IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN - IUT = IUTRAN - IF ( K.GT.INIT ) THEN - NROW = NOBS - INIT - SWITCH = .FALSE. - END IF - CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, - $ DWORK(IUT), M ) - IU = IU + NROW - END IF - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, - $ DWORK(IUT), 1, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 50 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 50 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ DWORK(IUT), 1, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IUT = IUT + M - 60 CONTINUE -C - ELSE -C - DO 80 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, - $ U(IU,1), LDU, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 70 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 70 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IU,1), LDU, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IU = IU + 1 - 80 CONTINUE -C - END IF -C - ELSE -C - IF ( BLOCK ) THEN - SWITCH = .TRUE. - NROW = NRBL -C - DO 100 K = 1, NOBS - IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN - IUT = IUTRAN - IF ( K.GT.INIT ) THEN - NROW = NOBS - INIT - SWITCH = .FALSE. - END IF - CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, - $ DWORK(IUT), M ) - IU = IU + NROW - END IF - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 90 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 90 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ DWORK(IUT), 1, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IUT = IUT + M - 100 CONTINUE -C - ELSE -C - DO 120 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, - $ 1, ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, - $ A, LDA, X0, 1 ) -C - DO 110 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 110 CONTINUE -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IU,1), LDU, ONE, X0, 1 ) - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - IU = IU + 1 - 120 CONTINUE -C - END IF -C - END IF -C - ELSE -C - DO 140 K = 1, NOBS - CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1, - $ ONE, DWORK(IY), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A, - $ LDA, X0, 1 ) -C - DO 130 IX = 2, N - X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) - 130 CONTINUE -C - CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) - IY = IY + L - 140 CONTINUE -C - END IF -C -C Compress the data using (sequential) QR factorization. -C Workspace: need v + 2*N; -C where v = s*L*(N + 1) + N + a + w. -C - JWORK = ITAU + N - IF ( FIRST ) THEN -C -C Compress the first data segment of Gamma. -C Workspace: need v + 2*N, -C prefer v + N + N*NB. -C - CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C -C Apply the transformation to the right hand side part. -C Workspace: need v + N + 1, -C prefer v + N + NB. -C - CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM), - $ LDDW, DWORK(ITAU), DWORK(IRHS), LDDW, - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) -C - IF ( NCYC ) THEN -C -C Save the triangular factor of Gamma and the -C corresponding right hand side. -C - CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW, - $ DWORK(INIR), LDR ) - END IF - ELSE -C -C Compress the current (but not the first) data segment of -C Gamma. -C Workspace: need v + N - 1. -C - CALL MB04OD( 'Full', N, 1, LDDW, DWORK(INIR), LDR, - $ DWORK(INIGAM), LDDW, DWORK(INIH), LDR, - $ DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) ) - END IF -C - IUPNT = IUPNT + NOBS - IYPNT = IYPNT + NOBS - 150 CONTINUE -C -C Estimate the reciprocal condition number of the triangular factor -C of the QR decomposition. -C Workspace: need u + 3*N, where -C u = t*L*(N + 1), if NCYCLE = 1; -C u = w, if NCYCLE > 1. -C - CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR), - $ LDR, RCOND, DWORK(IE), IWORK, IERR ) -C - TOLL = TOL - IF ( TOLL.LE.ZERO ) - $ TOLL = DLAMCH( 'Precision' ) - IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN - IWARN = 4 -C -C The least squares problem is ill-conditioned. -C Use SVD to solve it. -C Workspace: need u + 6*N; -C prefer larger. -C - CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1), - $ LDR ) - ISV = IE - JWORK = ISV + N - CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, - $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( IERR.GT.0 ) THEN -C -C Return if SVD algorithm did not converge. -C - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) - ELSE -C -C Find the least squares solution using QR decomposition only. -C - CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N, - $ DWORK(INIR), LDR, DWORK(INIH), 1 ) - END IF -C -C Return the estimated initial state of the system x0. -C - CALL DCOPY( N, DWORK(INIH), 1, X0, 1 ) -C - DWORK(1) = MAXWRK - DWORK(2) = RCOND -C - RETURN -C -C *** End of IB01RD *** - END diff --git a/slycot/src/IB03AD.f b/slycot/src/IB03AD.f deleted file mode 100644 index 9ba63187..00000000 --- a/slycot/src/IB03AD.f +++ /dev/null @@ -1,1076 +0,0 @@ - SUBROUTINE IB03AD( INIT, ALG, STOR, NOBR, M, L, NSMP, N, NN, - $ ITMAX1, ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, - $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a set of parameters for approximating a Wiener system -C in a least-squares sense, using a neural network approach and a -C Levenberg-Marquardt algorithm. Conjugate gradients (CG) or -C Cholesky algorithms are used to solve linear systems of equations. -C The Wiener system is represented as -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t) = f(z(t),wb(1:L)), -C -C where t = 1, 2, ..., NSMP, and f is a nonlinear function, -C evaluated by the SLICOT Library routine NF01AY. The parameter -C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), -C where wb(i), i = 1 : L, correspond to the nonlinear part, and -C theta corresponds to the linear part. See SLICOT Library routine -C NF01AD for further details. -C -C The sum of squares of the error functions, defined by -C -C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, -C -C is minimized, where Y(t) is the measured output vector. The -C functions and their Jacobian matrices are evaluated by SLICOT -C Library routine NF01BB (the FCN routine in the call of MD03AD). -C -C ARGUMENTS -C -C Mode Parameters -C -C INIT CHARACTER*1 -C Specifies which parts have to be initialized, as follows: -C = 'L' : initialize the linear part only, X already -C contains an initial approximation of the -C nonlinearity; -C = 'S' : initialize the static nonlinearity only, X -C already contains an initial approximation of the -C linear part; -C = 'B' : initialize both linear and nonlinear parts; -C = 'N' : do not initialize anything, X already contains -C an initial approximation. -C If INIT = 'S' or 'B', the error functions for the -C nonlinear part, and their Jacobian matrices, are evaluated -C by SLICOT Library routine NF01BA (used as a second FCN -C routine in the MD03AD call for the initialization step, -C see METHOD). -C -C ALG CHARACTER*1 -C Specifies the algorithm used for solving the linear -C systems involving a Jacobian matrix J, as follows: -C = 'D' : a direct algorithm, which computes the Cholesky -C factor of the matrix J'*J + par*I is used, where -C par is the Levenberg factor; -C = 'I' : an iterative Conjugate Gradients algorithm, which -C only needs the matrix J, is used. -C In both cases, matrix J is stored in a compressed form. -C -C STOR CHARACTER*1 -C If ALG = 'D', specifies the storage scheme for the -C symmetric matrix J'*J, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C The option STOR = 'F' usually ensures a faster execution. -C This parameter is not relevant if ALG = 'I'. -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C If INIT = 'L' or 'B', NOBR is the number of block rows, s, -C in the input and output block Hankel matrices to be -C processed for estimating the linear part. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C This parameter is ignored if INIT is 'S' or 'N'. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0, and L > 0, if -C INIT = 'L' or 'B'. -C -C NSMP (input) INTEGER -C The number of input and output samples, t. NSMP >= 0, and -C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. -C -C N (input/output) INTEGER -C The order of the linear part. -C If INIT = 'L' or 'B', and N < 0 on entry, the order is -C assumed unknown and it will be found by the routine. -C Otherwise, the input value will be used. If INIT = 'S' -C or 'N', N must be non-negative. The values N >= NOBR, -C or N = 0, are not acceptable if INIT = 'L' or 'B'. -C -C NN (input) INTEGER -C The number of neurons which shall be used to approximate -C the nonlinear part. NN >= 0. -C -C ITMAX1 (input) INTEGER -C The maximum number of iterations for the initialization of -C the static nonlinearity. -C This parameter is ignored if INIT is 'N' or 'L'. -C Otherwise, ITMAX1 >= 0. -C -C ITMAX2 (input) INTEGER -C The maximum number of iterations. ITMAX2 >= 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C and the current error norm is printed. Other intermediate -C results could be printed by modifying the corresponding -C FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no -C special calls of FCN with IFLAG = 0 are made. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NSMP). -C -C Y (input) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array must contain the -C set of output samples, -C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NSMP). -C -C X (input/output) DOUBLE PRECISION array dimension (LX) -C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part -C of this array must contain the initial parameters for -C the nonlinear part of the system. -C On entry, if INIT = 'S', the elements lin1 : lin2 of this -C array must contain the initial parameters for the linear -C part of the system, corresponding to the output normal -C form, computed by SLICOT Library routine TB01VD, where -C lin1 = (NN*(L+2) + 1)*L + 1; -C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. -C On entry, if INIT = 'N', the elements 1 : lin2 of this -C array must contain the initial parameters for the -C nonlinear part followed by the initial parameters for the -C linear part of the system, as specified above. -C This array need not be set on entry if INIT = 'B'. -C On exit, the elements 1 : lin2 of this array contain the -C optimal parameters for the nonlinear part followed by the -C optimal parameters for the linear part of the system, as -C specified above. -C -C LX (input/output) INTEGER -C On entry, this parameter must contain the intended length -C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). -C If N is unknown (N < 0 on entry), a large enough estimate -C of N should be used in the formula of lin2. -C On exit, if N < 0 on entry, but LX is not large enough, -C then this parameter contains the actual length of X, -C corresponding to the computed N. Otherwise, its value -C is unchanged. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance -C which measures the relative error desired in the sum of -C squares, for the initialization step of nonlinear part. -C Termination occurs when the actual relative reduction in -C the sum of squares is at most TOL1. In addition, if -C ALG = 'I', TOL1 also measures the relative residual of -C the solutions computed by the CG algorithm (for the -C initialization step). Termination of a CG process occurs -C when the relative residual is at most TOL1. -C If the user sets TOL1 < 0, then SQRT(EPS) is used -C instead TOL1, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C This parameter is ignored if INIT is 'N' or 'L'. -C -C TOL2 DOUBLE PRECISION -C If TOL2 >= 0, TOL2 is the tolerance which measures the -C relative error desired in the sum of squares, for the -C whole optimization process. Termination occurs when the -C actual relative reduction in the sum of squares is at -C most TOL2. -C If ALG = 'I', TOL2 also measures the relative residual of -C the solutions computed by the CG algorithm (for the whole -C optimization). Termination of a CG process occurs when the -C relative residual is at most TOL2. -C If the user sets TOL2 < 0, then SQRT(EPS) is used -C instead TOL2. This default value could require many -C iterations, especially if TOL1 is larger. If INIT = 'S' -C or 'B', it is advisable that TOL2 be larger than TOL1, -C and spend more time with cheaper iterations. -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where -C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, -C LIW1 = M+L; -C LIW2 = MAX(M*NOBR+N,M*(N+L)). -C On output, if INFO = 0, IWORK(1) and IWORK(2) return the -C (total) number of function and Jacobian evaluations, -C respectively (including the initialization step, if it was -C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) -C specifies how many locations of DWORK contain reciprocal -C condition number estimates (see below); otherwise, -C IWORK(3) = 0. -C -C DWORK DOUBLE PRECISION array dimesion (LDWORK) -C On entry, if desired, and if INIT = 'S' or 'B', the -C entries DWORK(1:4) are set to initialize the random -C numbers generator for the nonlinear part parameters (see -C the description of the argument XINIT of SLICOT Library -C routine MD03AD); this enables to obtain reproducible -C results. The same seed is used for all outputs. -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, DWORK(4) returns the number of conjugate -C gradients iterations performed, and DWORK(5) returns the -C final Levenberg factor, for optimizing the parameters of -C both the linear part and the static nonlinearity part. -C If INIT = 'S' or INIT = 'B' and INFO = 0, then the -C elements DWORK(6) to DWORK(10) contain the corresponding -C five values for the initialization step (see METHOD). -C (If L > 1, DWORK(10) contains the maximum of the Levenberg -C factors for all outputs.) If INIT = 'L' or INIT = 'B', and -C INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain -C reciprocal condition number estimates set by SLICOT -C Library routines IB01AD, IB01BD, and IB01CD. -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C In the formulas below, N should be taken not larger than -C NOBR - 1, if N < 0 on entry. -C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where -C LW1 = 0, if INIT = 'S' or 'N'; otherwise, -C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, -C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C MAX( LDW1, LDW2 ), -C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + -C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), -C where, -C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + -C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), -C LDW4 = N*(N+1) + 2*N + -C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); -C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; -C LDW6 = NSMP*L + (N+L)*(N+M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), -C N*M)); -C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, -C LW2 = NSMP*L + -C MAX( 5, NSMP + 2*BSN + NSMP*BSN + -C MAX( 2*NN + BSN, LDW7 ) ); -C LDW7 = BSN*BSN, if ALG = 'D' and STOR = 'F'; -C LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P'; -C LDW7 = 3*BSN + NSMP, if ALG = 'I'; -C LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N ); -C LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; -C LDW8 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; -C LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) + -C MAX( L1 + NX, NSMP*L + L1, L2 ) ), -C L0 = MAX( N*(N+L), N+M+L ), if M > 0; -C L0 = MAX( N*(N+L), L ), if M = 0; -C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); -C L2 = NX*NX, if ALG = 'D' and STOR = 'F'; -C L2 = NX*(NX+1)/2, if ALG = 'D' and STOR = 'P'; -C L2 = 3*NX + NSMP*L, if ALG = 'I', -C with BSN = NN*( L + 2 ) + 1, -C LTHS = N*( L + M + 1 ) + L*M. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C < 0: the user set IFLAG = IWARN in (one of) the -C subroutine(s) FCN, i.e., NF01BA, if INIT = 'S' -C or 'B', and/or NF01BB; this value cannot be returned -C without changing the FCN routine(s); -C otherwise, IWARN has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning (where TOL* denotes TOL1 or TOL2, -C and similarly for ITMAX*): -C = 1: the number of iterations has reached ITMAX* without -C satisfying the convergence condition; -C = 2: if alg = 'I' and in an iteration of the Levenberg- -C Marquardt algorithm, the CG algorithm finished -C after 3*NX iterations (or 3*(lin1-1) iterations, for -C the initialization phase), without achieving the -C precision required in the call; -C = 3: the cosine of the angle between the vector of error -C function values and any column of the Jacobian is at -C most FACTOR*EPS in absolute value (FACTOR = 100); -C = 4: TOL* is too small: no further reduction in the sum -C of squares is possible. -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 6 (see IB01AD, IB01BD -C and IB01CD). In all these cases, the entries DWORK(1:5), -C DWORK(6:10) (if INIT = 'S' or 'B'), and -C DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as -C described above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C otherwise, INFO has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning: -C = 1: the routine FCN returned with INFO <> 0 for -C IFLAG = 1; -C = 2: the routine FCN returned with INFO <> 0 for -C IFLAG = 2; -C = 3: ALG = 'D' and SLICOT Library routines MB02XD or -C NF01BU (or NF01BV, if INIT = 'S' or 'B') or -C ALG = 'I' and SLICOT Library routines MB02WD or -C NF01BW (or NF01BX, if INIT = 'S' or 'B') returned -C with INFO <> 0. -C In addition, if INIT = 'L' or 'B', i could also be -C = 4: if a Lyapunov equation could not be solved; -C = 5: if the identified linear system is unstable; -C = 6: if the QR algorithm failed on the state matrix -C of the identified linear system. -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 10 (see IB01AD/IB01BD). -C -C METHOD -C -C If INIT = 'L' or 'B', the linear part of the system is -C approximated using the combined MOESP and N4SID algorithm. If -C necessary, this algorithm can also choose the order, but it is -C advantageous if the order is already known. -C -C If INIT = 'S' or 'B', the output of the approximated linear part -C is computed and used to calculate an approximation of the static -C nonlinearity using the Levenberg-Marquardt algorithm [1]. -C This step is referred to as the (nonlinear) initialization step. -C -C As last step, the Levenberg-Marquardt algorithm is used again to -C optimize the parameters of the linear part and the static -C nonlinearity as a whole. Therefore, it is necessary to parametrise -C the matrices of the linear part. The output normal form [2] -C parameterisation is used. -C -C The Jacobian is computed analytically, for the nonlinear part, and -C numerically, for the linear part. -C -C REFERENCES -C -C [1] Kelley, C.T. -C Iterative Methods for Optimization. -C Society for Industrial and Applied Mathematics (SIAM), -C Philadelphia (Pa.), 1999. -C -C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. -C Balanced realizations of discrete-time stable all-pass -C systems and the tangential Schur algorithm. -C Proceedings of the European Control Conference, -C 31 August - 3 September 1999, Karlsruhe, Germany. -C Session CP-6, Discrete-time Systems, 1999. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Mar. 2002, Apr. 2002, Feb. 2004, March 2005, Nov. 2005. -C -C KEYWORDS -C -C Conjugate gradients, least-squares approximation, -C Levenberg-Marquardt algorithm, matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C The upper triangular part is used in MD03AD; - CHARACTER UPLO - PARAMETER ( UPLO = 'U' ) -C For INIT = 'L' or 'B', additional parameters are set: -C The following six parameters are used in the call of IB01AD; - CHARACTER IALG, BATCH, CONCT, CTRL, JOBD, METH - PARAMETER ( IALG = 'Fast QR', BATCH = 'One batch', - $ CONCT = 'Not connect', CTRL = 'Not confirm', - $ JOBD = 'Not MOESP', METH = 'MOESP' ) -C The following three parameters are used in the call of IB01BD; - CHARACTER JOB, JOBCK, METHB - PARAMETER ( JOB = 'All matrices', - $ JOBCK = 'No Kalman gain', - $ METHB = 'Combined MOESP+N4SID' ) -C The following two parameters are used in the call of IB01CD; - CHARACTER COMUSE, JOBXD - PARAMETER ( COMUSE = 'Use B, D', - $ JOBXD = 'D also' ) -C TOLN controls the estimated order in IB01AD (default value); - DOUBLE PRECISION TOLN - PARAMETER ( TOLN = -1.0D0 ) -C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD -C (default); - DOUBLE PRECISION RCOND - PARAMETER ( RCOND = -1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ALG, INIT, STOR - INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, - $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - INTEGER AC, BD, BSN, I, IA, IB, IK, INFOL, IQ, IR, - $ IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, IW2, - $ IWARNL, IX, IX0, J, JWORK, LDAC, LDR, LIPAR, - $ LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, NSML, - $ NTHS, NX, WRKOPT, Z - LOGICAL CHOL, FULL, INIT1, INIT2 -C .. Local Arrays .. - LOGICAL BWORK(1) - INTEGER IPAR(7) - DOUBLE PRECISION RCND(16), SEED(4), WORK(5) -C .. External Functions .. - EXTERNAL LSAME - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03AD, NF01BA, - $ NF01BB, NF01BU, NF01BV, NF01BW, NF01BX, TB01VD, - $ TB01VY, TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. -C .. Executable Statements .. -C - CHOL = LSAME( ALG, 'D' ) - FULL = LSAME( STOR, 'F' ) - INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) - INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) -C - ML = M + L - INFO = 0 - IWARN = 0 - IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN - INFO = -2 - ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -3 - ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN - INFO = -4 - ELSEIF ( M.LT.0 ) THEN - INFO = -5 - ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN - INFO = -6 - ELSEIF ( NSMP.LT.0 .OR. - $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN - INFO = -7 - ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. - $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN - INFO = -8 - ELSEIF ( NN.LT.0 ) THEN - INFO = -9 - ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN - INFO = -10 - ELSEIF ( ITMAX2.LT.0 ) THEN - INFO = -11 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -14 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -16 - ELSE - LNOL = L*NOBR - L - MNO = M*NOBR - BSN = NN*( L + 2 ) + 1 - NTHS = BSN*L - NSML = NSMP*L - IF ( N.GT.0 ) THEN - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - END IF -C -C Check the workspace size. -C - JWORK = 0 - IF ( INIT1 ) THEN -C Workspace for IB01AD. - JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR - IF ( N.GT.0 ) THEN -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + - $ 1, MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = MAX( JWORK, - $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + - $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) - END IF - END IF -C - IF ( INIT2 ) THEN -C Workspace for MD03AD (initialization of the nonlinear part). - IF ( CHOL ) THEN - IF ( FULL ) THEN - IW1 = BSN**2 - ELSE - IW1 = ( BSN*( BSN + 1 ) )/2 - END IF - ELSE - IW1 = 3*BSN + NSMP - END IF - JWORK = MAX( JWORK, NSML + - $ MAX( 5, NSMP + 2*BSN + NSMP*BSN + - $ MAX( 2*NN + BSN, IW1 ) ) ) - IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN -C Workspace for TB01VY. - JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) -C Workspace for TF01MX. - IF ( M.GT.0 ) THEN - IW1 = N + M - ELSE - IW1 = 0 - END IF - JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) - END IF - END IF -C - IF ( N.GE.0 ) THEN -C -C Find the number of parameters. -C - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - INFO = -18 - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF -C -C Workspace for MD03AD (whole optimization). -C - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( CHOL ) THEN - IF ( FULL ) THEN - IW2 = NX**2 - ELSE - IW2 = ( NX*( NX + 1 ) )/2 - END IF - ELSE - IW2 = 3*NX + NSML - END IF - JWORK = MAX( JWORK, - $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + - $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) - END IF -C - IF ( LDWORK.LT.JWORK ) THEN - INFO = -23 - DWORK(1) = JWORK - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - ENDIF -C -C Initialize the pointers to system matrices and save the possible -C seed for random numbers generation. -C - Z = 1 - AC = Z + NSML - CALL DCOPY( 4, DWORK, 1, SEED, 1 ) -C - WRKOPT = 1 -C - IF ( INIT1 ) THEN -C -C Initialize the linear part. -C If N < 0, the order of the system is determined by IB01AD; -C otherwise, the given order will be used. -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; -C prefer: larger. -C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) -C - NS = N - IR = 1 - ISV = 2*ML*NOBR - LDR = ISV - IF ( LSAME( JOBD, 'M' ) ) - $ LDR = MAX( LDR, 3*MNO ) - ISV = IR + LDR*ISV - JWORK = ISV + L*NOBR -C - CALL IB01AD( METH, IALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, - $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, - $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = 0 - IF ( LSAME( METH, 'N' ) ) THEN - IRCND = 2 - CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) - END IF -C - IF ( NS.GE.0 ) THEN - N = NS - ELSE -C -C Find the number of parameters. -C - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - LX = NX - INFO = -18 - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, - $ MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = ISV + ISAD + MAX( IW1, IW2 ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, - $ 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) -C Workspace for MD03AD (whole optimization). - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( CHOL ) THEN - IF ( FULL ) THEN - IW2 = NX**2 - ELSE - IW2 = ( NX*( NX + 1 ) )/2 - END IF - ELSE - IW2 = 3*NX + NSML - END IF - JWORK = MAX( JWORK, - $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + - $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) - IF ( LDWORK.LT.JWORK ) THEN - INFO = -23 - DWORK(1) = JWORK - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF - END IF -C - BD = AC + LDAC*N - IX = BD + LDAC*M - IA = ISV - IB = IA + LDAC*N - IQ = IB + LDAC*M - IF ( LSAME( JOBCK, 'N' ) ) THEN - IRY = IQ - IS = IQ - IK = IQ - JWORK = IQ - ELSE - IRY = IQ + N2 - IS = IRY + L*L - IK = IS + N*L - JWORK = IK + N*L - END IF -C -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C max( LDW1,LDW2 ), where, -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C prefer: larger. -C Integer workspace: MAX(M*NOBR+N,M*(N+L)). -C - CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), - $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, - $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, - $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, - $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, - $ IWARNL, INFOL ) -C - IF( INFOL.EQ.-30 ) THEN - INFO = -23 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCNDB = 4 - IF ( LSAME( JOBCK, 'K' ) ) - $ IRCNDB = IRCNDB + 8 - CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) - IRCND = IRCND + IRCNDB -C -C Copy the system matrices to the beginning of DWORK, to save -C space, and redefine the pointers. -C - CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) - IA = 1 - IB = IA + LDAC*N - IX0 = IB + LDAC*M - IV = IX0 + N -C -C Compute the initial condition of the system. On normal exit, -C DWORK(i), i = JWORK+2:JWORK+1+N*N, -C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and -C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, -C contain the transformed system matrices At, Ct, and Bt, -C respectively, corresponding to the real Schur form of the -C estimated system state matrix A. The transformation matrix is -C stored in DWORK(IV:IV+N*N-1). -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + -C max( 5*N, 2, min( LDW1, LDW2 ) ), where, -C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), -C LDW2 = N*(N + 1) + 2*N + -C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); -C prefer: larger. -C Integer workspace: N. -C - JWORK = IV + N2 - CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, - $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), - $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, - $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.EQ.-26 ) THEN - INFO = -23 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03AD', -INFO ) - RETURN - END IF - IF( INFOL.EQ.1 ) - $ INFOL = 10 - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = IRCND + 1 - RCND(IRCND) = DWORK(JWORK+1) -C -C Now, save the system matrices and x0 in the final location. -C - IF ( IV.LT.AC ) THEN - CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) - ELSE - DO 5 J = AC + ISAD + N - 1, AC, -1 - DWORK(J) = DWORK(IA+J-AC) - 5 CONTINUE - END IF -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - JWORK = IX + N - CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), - $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) -C -C Convert the state-space representation to output normal form. -C Workspace: -C need: NSMP*L + (N + L)*(N + M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); -C prefer: larger. -C - CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), - $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, - $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), - $ LDWORK-JWORK+1, INFOL ) -C - IF( INFOL.GT.0 ) THEN - INFO = INFOL + 3 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - END IF -C - LIPAR = 7 - IW1 = 0 - IW2 = 0 -C - IF ( INIT2 ) THEN -C -C Initialize the nonlinear part. -C - IF ( .NOT.INIT1 ) THEN - BD = AC + LDAC*N - IX = BD + LDAC*M -C -C Convert the output normal form to state-space model. -C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. -C (NSMP*L locations are reserved for the output of the linear -C part.) -C - JWORK = IX + N - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), - $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, - $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, - $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - END IF -C -C Optimize the parameters of the nonlinear part. -C Workspace: -C need NSMP*L + -C MAX( 5, NSMP + 2*BSN + NSMP*BSN + -C MAX( 2*NN + BSN, DW( sol ) ) ), -C where, if ALG = 'D', -C DW( sol ) = BSN*BSN, if STOR = 'F'; -C DW( sol ) = BSN*(BSN+1)/2, if STOR = 'P'; -C and DW( sol ) = 3*BSN + NSMP, if ALG = 'I'; -C prefer larger. -C - JWORK = AC - WORK(1) = ZERO - CALL DCOPY( 4, WORK(1), 0, WORK(2), 1 ) -C -C Set the integer parameters needed, including the number of -C neurons. -C - IPAR(1) = NSMP - IPAR(2) = L - IPAR(3) = NN -C - DO 10 I = 0, L - 1 - CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) - IF ( CHOL ) THEN - CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, - $ NF01BA, NF01BV, NSMP, BSN, ITMAX1, NPRINT, - $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, - $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, - $ INFOL ) - ELSE - CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, - $ NF01BA, NF01BX, NSMP, BSN, ITMAX1, NPRINT, - $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, - $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, - $ INFOL ) - END IF -C - IF( INFOL.NE.0 ) THEN - INFO = 10*INFOL - RETURN - END IF - IF ( IWARNL.LT.0 ) THEN - INFO = INFOL - IWARN = IWARNL - GO TO 20 - ELSEIF ( IWARNL.GT.0 ) THEN - IF ( IWARN.GT.100 ) THEN - IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) - ELSE - IWARN = MAX( IWARN, 10*IWARNL ) - END IF - END IF - WORK(1) = MAX( WORK(1), DWORK(JWORK) ) - WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) - WORK(5) = MAX( WORK(5), DWORK(JWORK+4) ) - WORK(3) = WORK(3) + DWORK(JWORK+2) - WORK(4) = WORK(4) + DWORK(JWORK+3) - IW1 = NFEV + IW1 - IW2 = NJEV + IW2 - 10 CONTINUE -C - ENDIF -C -C Main iteration. -C Workspace: need MAX( 5, NFUN + 2*NX + NFUN*( BSN + LTHS ) + -C MAX( LDW1 + NX, NFUN + LDW1, DW( sol ) ) ), -C where NFUN = NSMP*L, and -C LDW1 = NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L )), -C if M > 0, -C LDW1 = NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), -C if M = 0; -C if ALG = 'D', -C DW( sol ) = NX*NX, if STOR = 'F'; -C DW( sol ) = NX*(NX+1)/2, if STOR = 'P'; -C and DW( sol ) = 3*NX + NFUN, if ALG = 'I', -C and DW( f ) is the workspace needed by the -C subroutine f; -C prefer larger. -C -C Set the integer parameters describing the Jacobian structure -C and the number of neurons. -C - IPAR(1) = LTHS - IPAR(2) = L - IPAR(3) = NSMP - IPAR(4) = BSN - IPAR(5) = M - IPAR(6) = N - IPAR(7) = NN -C - IF ( CHOL ) THEN - CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, - $ NF01BU, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, - $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, - $ DWORK, LDWORK, IWARNL, INFO ) - ELSE - CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, - $ NF01BW, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, - $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, - $ DWORK, LDWORK, IWARNL, INFO ) - END IF -C - IF( INFO.NE.0 ) - $ RETURN -C - 20 CONTINUE - IWORK(1) = IW1 + NFEV - IWORK(2) = IW2 + NJEV - IF ( IWARNL.LT.0 ) THEN - IWARN = IWARNL - ELSE - IWARN = IWARN + IWARNL - END IF - IF ( INIT2 ) - $ CALL DCOPY( 5, WORK, 1, DWORK(6), 1 ) - IF ( INIT1 ) THEN - IWORK(3) = IRCND - CALL DCOPY( IRCND, RCND, 1, DWORK(11), 1 ) - ELSE - IWORK(3) = 0 - END IF - RETURN -C -C *** Last line of IB03AD *** - END diff --git a/slycot/src/IB03BD.f b/slycot/src/IB03BD.f deleted file mode 100644 index a1e0e86d..00000000 --- a/slycot/src/IB03BD.f +++ /dev/null @@ -1,1087 +0,0 @@ - SUBROUTINE IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, - $ NPRINT, U, LDU, Y, LDY, X, LX, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a set of parameters for approximating a Wiener system -C in a least-squares sense, using a neural network approach and a -C MINPACK-like Levenberg-Marquardt algorithm. The Wiener system -C consists of a linear part and a static nonlinearity, and it is -C represented as -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t) = f(z(t),wb(1:L)), -C -C where t = 1, 2, ..., NSMP, and f is a nonlinear function, -C evaluated by the SLICOT Library routine NF01AY. The parameter -C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), -C where theta corresponds to the linear part, and wb(i), i = 1 : L, -C correspond to the nonlinear part. See SLICOT Library routine -C NF01AD for further details. -C -C The sum of squares of the error functions, defined by -C -C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, -C -C is minimized, where Y(t) is the measured output vector. The -C functions and their Jacobian matrices are evaluated by SLICOT -C Library routine NF01BF (the FCN routine in the call of MD03BD). -C -C ARGUMENTS -C -C Mode Parameters -C -C INIT CHARACTER*1 -C Specifies which parts have to be initialized, as follows: -C = 'L' : initialize the linear part only, X already -C contains an initial approximation of the -C nonlinearity; -C = 'S' : initialize the static nonlinearity only, X -C already contains an initial approximation of the -C linear part; -C = 'B' : initialize both linear and nonlinear parts; -C = 'N' : do not initialize anything, X already contains -C an initial approximation. -C If INIT = 'S' or 'B', the error functions for the -C nonlinear part, and their Jacobian matrices, are evaluated -C by SLICOT Library routine NF01BE (used as a second FCN -C routine in the MD03BD call for the initialization step, -C see METHOD). -C -C Input/Output Parameters -C -C NOBR (input) INTEGER -C If INIT = 'L' or 'B', NOBR is the number of block rows, s, -C in the input and output block Hankel matrices to be -C processed for estimating the linear part. NOBR > 0. -C (In the MOESP theory, NOBR should be larger than n, -C the estimated dimension of state vector.) -C This parameter is ignored if INIT is 'S' or 'N'. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0, and L > 0, if -C INIT = 'L' or 'B'. -C -C NSMP (input) INTEGER -C The number of input and output samples, t. NSMP >= 0, and -C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. -C -C N (input/output) INTEGER -C The order of the linear part. -C If INIT = 'L' or 'B', and N < 0 on entry, the order is -C assumed unknown and it will be found by the routine. -C Otherwise, the input value will be used. If INIT = 'S' -C or 'N', N must be non-negative. The values N >= NOBR, -C or N = 0, are not acceptable if INIT = 'L' or 'B'. -C -C NN (input) INTEGER -C The number of neurons which shall be used to approximate -C the nonlinear part. NN >= 0. -C -C ITMAX1 (input) INTEGER -C The maximum number of iterations for the initialization of -C the static nonlinearity. -C This parameter is ignored if INIT is 'N' or 'L'. -C Otherwise, ITMAX1 >= 0. -C -C ITMAX2 (input) INTEGER -C The maximum number of iterations. ITMAX2 >= 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C and the current error norm is printed. Other intermediate -C results could be printed by modifying the corresponding -C FCN routine (NF01BE and/or NF01BF). If NPRINT <= 0, no -C special calls of FCN with IFLAG = 0 are made. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NSMP). -C -C Y (input) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array must contain the -C set of output samples, -C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NSMP). -C -C X (input/output) DOUBLE PRECISION array dimension (LX) -C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part -C of this array must contain the initial parameters for -C the nonlinear part of the system. -C On entry, if INIT = 'S', the elements lin1 : lin2 of this -C array must contain the initial parameters for the linear -C part of the system, corresponding to the output normal -C form, computed by SLICOT Library routine TB01VD, where -C lin1 = (NN*(L+2) + 1)*L + 1; -C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. -C On entry, if INIT = 'N', the elements 1 : lin2 of this -C array must contain the initial parameters for the -C nonlinear part followed by the initial parameters for the -C linear part of the system, as specified above. -C This array need not be set on entry if INIT = 'B'. -C On exit, the elements 1 : lin2 of this array contain the -C optimal parameters for the nonlinear part followed by the -C optimal parameters for the linear part of the system, as -C specified above. -C -C LX (input/output) INTEGER -C On entry, this parameter must contain the intended length -C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). -C If N is unknown (N < 0 on entry), a large enough estimate -C of N should be used in the formula of lin2. -C On exit, if N < 0 on entry, but LX is not large enough, -C then this parameter contains the actual length of X, -C corresponding to the computed N. Otherwise, its value -C is unchanged. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance -C which measures the relative error desired in the sum of -C squares, as well as the relative error desired in the -C approximate solution, for the initialization step of -C nonlinear part. Termination occurs when either both the -C actual and predicted relative reductions in the sum of -C squares, or the relative error between two consecutive -C iterates are at most TOL1. If the user sets TOL1 < 0, -C then SQRT(EPS) is used instead TOL1, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C This parameter is ignored if INIT is 'N' or 'L'. -C -C TOL2 DOUBLE PRECISION -C If TOL2 >= 0, TOL2 is the tolerance which measures the -C relative error desired in the sum of squares, as well as -C the relative error desired in the approximate solution, -C for the whole optimization process. Termination occurs -C when either both the actual and predicted relative -C reductions in the sum of squares, or the relative error -C between two consecutive iterates are at most TOL2. If the -C user sets TOL2 < 0, then SQRT(EPS) is used instead TOL2. -C This default value could require many iterations, -C especially if TOL1 is larger. If INIT = 'S' or 'B', it is -C advisable that TOL2 be larger than TOL1, and spend more -C time with cheaper iterations. -C -C Workspace -C -C IWORK INTEGER array, dimension (MAX( LIW1, LIW2, LIW3 )), where -C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, -C LIW1 = M+L; -C LIW2 = MAX(M*NOBR+N,M*(N+L)); -C LIW3 = 3+MAX(NN*(L+2)+2,NX+L), if INIT = 'S' or 'B'; -C LIW3 = 3+NX+L, if INIT = 'L' or 'N'. -C On output, if INFO = 0, IWORK(1) and IWORK(2) return the -C (total) number of function and Jacobian evaluations, -C respectively (including the initialization step, if it was -C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) -C specifies how many locations of DWORK contain reciprocal -C condition number estimates (see below); otherwise, -C IWORK(3) = 0. If INFO = 0, the entries 4 to 3+NX of IWORK -C define a permutation matrix P such that J*P = Q*R, where -C J is the final calculated Jacobian, Q is an orthogonal -C matrix (not stored), and R is upper triangular with -C diagonal elements of nonincreasing magnitude (possibly -C for each block column of J). Column j of P is column -C IWORK(3+j) of the identity matrix. Moreover, the entries -C 4+NX:3+NX+L of this array contain the ranks of the final -C submatrices S_k (see description of LMPARM in MD03BD). -C -C DWORK DOUBLE PRECISION array dimesion (LDWORK) -C On entry, if desired, and if INIT = 'S' or 'B', the -C entries DWORK(1:4) are set to initialize the random -C numbers generator for the nonlinear part parameters (see -C the description of the argument XINIT of SLICOT Library -C routine MD03BD); this enables to obtain reproducible -C results. The same seed is used for all outputs. -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, and DWORK(4) returns the final Levenberg -C factor, for optimizing the parameters of both the linear -C part and the static nonlinearity part. If INIT = 'S' or -C INIT = 'B' and INFO = 0, then the elements DWORK(5) to -C DWORK(8) contain the corresponding four values for the -C initialization step (see METHOD). (If L > 1, DWORK(8) -C contains the maximum of the Levenberg factors for all -C outputs.) If INIT = 'L' or INIT = 'B', and INFO = 0, -C DWORK(9) to DWORK(8+IWORK(3)) contain reciprocal condition -C number estimates set by SLICOT Library routines IB01AD, -C IB01BD, and IB01CD. -C On exit, if INFO = -21, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C In the formulas below, N should be taken not larger than -C NOBR - 1, if N < 0 on entry. -C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where -C LW1 = 0, if INIT = 'S' or 'N'; otherwise, -C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, -C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C MAX( LDW1, LDW2 ), -C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + -C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), -C where, -C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + -C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), -C LDW4 = N*(N+1) + 2*N + -C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); -C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; -C LDW6 = NSMP*L + (N+L)*(N+M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), -C N*M)); -C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, -C LW2 = NSMP*L + BSN + -C MAX( 4, NSMP + -C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), -C BSN**2 + BSN + -C MAX( NSMP + 2*NN, 5*BSN ) ) ); -C LW3 = MAX( LDW7, NSMP*L + (N+L)*(2*N+M) + 2*N ); -C LDW7 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; -C LDW7 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; -C LW4 = NSMP*L + NX + -C MAX( 4, NSMP*L + -C MAX( NSMP*L*( BSN + LTHS ) + -C MAX( NSMP*L + L1, L2 + NX ), -C NX*( BSN + LTHS ) + NX + -C MAX( NSMP*L + L1, NX + L3 ) ) ), -C L0 = MAX( N*(N+L), N+M+L ), if M > 0; -C L0 = MAX( N*(N+L), L ), if M = 0; -C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); -C L2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, -C L2 = BSN + MAX(3*BSN+1,LTHS); -C L2 = MAX(L2,4*LTHS+1), if NSMP > BSN; -C L2 = MAX(L2,(NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; -C L3 = 4*NX, if L <= 1 or BSN = 0; -C L3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), -C if L > 1 and BSN > 0, -C with BSN = NN*( L + 2 ) + 1, -C LTHS = N*( L + M + 1 ) + L*M. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C < 0: the user set IFLAG = IWARN in (one of) the -C subroutine(s) FCN, i.e., NF01BE, if INIT = 'S' -C or 'B', and/or NF01BF; this value cannot be returned -C without changing the FCN routine(s); -C otherwise, IWARN has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning (where TOL* denotes TOL1 or TOL2, -C and similarly for ITMAX*): -C = 1: both actual and predicted relative reductions in -C the sum of squares are at most TOL*; -C = 2: relative error between two consecutive iterates is -C at most TOL*; -C = 3: conditions for i or j = 1 and i or j = 2 both hold; -C = 4: the cosine of the angle between the vector of error -C function values and any column of the Jacobian is at -C most EPS in absolute value; -C = 5: the number of iterations has reached ITMAX* without -C satisfying any convergence condition; -C = 6: TOL* is too small: no further reduction in the sum -C of squares is possible; -C = 7: TOL* is too small: no further improvement in the -C approximate solution X is possible; -C = 8: the vector of function values e is orthogonal to the -C columns of the Jacobian to machine precision. -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 6 (see IB01AD, IB01BD -C and IB01CD). In all these cases, the entries DWORK(1:4), -C DWORK(5:8) (if INIT = 'S' or 'B'), and DWORK(9:8+IWORK(3)) -C (if INIT = 'L' or 'B'), are set as described above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C otherwise, INFO has the value k*100 + j*10 + i, -C where k is defined below, i refers to the whole -C optimization process, and j refers to the -C initialization step (j = 0, if INIT = 'L' or 'N'), -C and the possible values for i and j have the -C following meaning: -C = 1: the routine FCN returned with INFO <> 0 for -C IFLAG = 1; -C = 2: the routine FCN returned with INFO <> 0 for -C IFLAG = 2; -C = 3: the routine QRFACT returned with INFO <> 0; -C = 4: the routine LMPARM returned with INFO <> 0. -C In addition, if INIT = 'L' or 'B', i could also be -C = 5: if a Lyapunov equation could not be solved; -C = 6: if the identified linear system is unstable; -C = 7: if the QR algorithm failed on the state matrix -C of the identified linear system. -C QRFACT and LMPARM are generic names for SLICOT Library -C routines NF01BS and NF01BP, respectively, for the whole -C optimization process, and MD03BA and MD03BB, respectively, -C for the initialization step (if INIT = 'S' or 'B'). -C The digit k is normally 0, but if INIT = 'L' or 'B', it -C can have a value in the range 1 to 10 (see IB01AD/IB01BD). -C -C METHOD -C -C If INIT = 'L' or 'B', the linear part of the system is -C approximated using the combined MOESP and N4SID algorithm. If -C necessary, this algorithm can also choose the order, but it is -C advantageous if the order is already known. -C -C If INIT = 'S' or 'B', the output of the approximated linear part -C is computed and used to calculate an approximation of the static -C nonlinearity using the Levenberg-Marquardt algorithm [1,3]. -C This step is referred to as the (nonlinear) initialization step. -C -C As last step, the Levenberg-Marquardt algorithm is used again to -C optimize the parameters of the linear part and the static -C nonlinearity as a whole. Therefore, it is necessary to parametrise -C the matrices of the linear part. The output normal form [2] -C parameterisation is used. -C -C The Jacobian is computed analytically, for the nonlinear part, and -C numerically, for the linear part. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. -C Balanced realizations of discrete-time stable all-pass -C systems and the tangential Schur algorithm. -C Proceedings of the European Control Conference, -C 31 August - 3 September 1999, Karlsruhe, Germany. -C Session CP-6, Discrete-time Systems, 1999. -C -C [3] More, J.J. -C The Levenberg-Marquardt algorithm: implementation and theory. -C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in -C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg -C and New York, pp. 105-116, 1978. -C -C NUMERICAL ASPECTS -C -C The Levenberg-Marquardt algorithm described in [3] is scaling -C invariant and globally convergent to (maybe local) minima. -C The convergence rate near a local minimum is quadratic, if the -C Jacobian is computed analytically, and linear, if the Jacobian -C is computed numerically. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, March, 2002, Apr. 2002, Feb. 2004, March 2005. -C -C KEYWORDS -C -C Least-squares approximation, Levenberg-Marquardt algorithm, -C matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C FACTOR is a scaling factor for variables (see MD03BD). - DOUBLE PRECISION FACTOR - PARAMETER ( FACTOR = 100.0D0 ) -C Condition estimation and internal scaling of variables are used -C (see MD03BD). - CHARACTER COND, SCALE - PARAMETER ( COND = 'E', SCALE = 'I' ) -C Default tolerances are used in MD03BD for measuring the -C orthogonality between the vector of function values and columns -C of the Jacobian (GTOL), and for the rank estimations (TOL). - DOUBLE PRECISION GTOL, TOL - PARAMETER ( GTOL = 0.0D0, TOL = 0.0D0 ) -C For INIT = 'L' or 'B', additional parameters are set: -C The following six parameters are used in the call of IB01AD; - CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH - PARAMETER ( ALG = 'Fast QR', BATCH = 'One batch', - $ CONCT = 'Not connect', CTRL = 'Not confirm', - $ JOBD = 'Not MOESP', METH = 'MOESP' ) -C The following three parameters are used in the call of IB01BD; - CHARACTER JOB, JOBCK, METHB - PARAMETER ( JOB = 'All matrices', - $ JOBCK = 'No Kalman gain', - $ METHB = 'Combined MOESP+N4SID' ) -C The following two parameters are used in the call of IB01CD; - CHARACTER COMUSE, JOBXD - PARAMETER ( COMUSE = 'Use B, D', - $ JOBXD = 'D also' ) -C TOLN controls the estimated order in IB01AD (default value); - DOUBLE PRECISION TOLN - PARAMETER ( TOLN = -1.0D0 ) -C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD -C (default); - DOUBLE PRECISION RCOND - PARAMETER ( RCOND = -1.0D0 ) -C .. Scalar Arguments .. - CHARACTER INIT - INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, - $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) - INTEGER IWORK(*) -C .. Local Scalars .. - INTEGER AC, BD, BSN, I, IA, IB, IDIAG, IK, INFOL, IQ, - $ IR, IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, - $ IW2, IW3, IWARNL, IX, IX0, J, JWORK, LDAC, LDR, - $ LIPAR, LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, - $ NSML, NTHS, NX, WRKOPT, Z - LOGICAL INIT1, INIT2 -C .. Local Arrays .. - LOGICAL BWORK(1) - INTEGER IPAR(7) - DOUBLE PRECISION RCND(16), SEED(4), WORK(4) -C .. External Functions .. - EXTERNAL LSAME - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03BA, MD03BB, - $ MD03BD, NF01BE, NF01BF, NF01BP, NF01BS, TB01VD, - $ TB01VY, TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) - INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) -C - ML = M + L - INFO = 0 - IWARN = 0 - IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN - INFO = -4 - ELSEIF ( NSMP.LT.0 .OR. - $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN - INFO = -5 - ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. - $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN - INFO = -6 - ELSEIF ( NN.LT.0 ) THEN - INFO = -7 - ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN - INFO = -8 - ELSEIF ( ITMAX2.LT.0 ) THEN - INFO = -9 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -12 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -14 - ELSE - LNOL = L*NOBR - L - MNO = M*NOBR - BSN = NN*( L + 2 ) + 1 - NTHS = BSN*L - NSML = NSMP*L - IF ( N.GT.0 ) THEN - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - END IF -C -C Check the workspace size. -C - JWORK = 0 - IF ( INIT1 ) THEN -C Workspace for IB01AD. - JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR - IF ( N.GT.0 ) THEN -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + - $ 1, MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = MAX( JWORK, - $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + - $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) - END IF - END IF -C - IF ( INIT2 ) THEN -C Workspace for MD03BD (initialization of the nonlinear part). - JWORK = MAX( JWORK, NSML + BSN + - $ MAX( 4, NSMP + - $ MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), - $ BSN**2 + BSN + - $ MAX( NSMP + 2*NN, 5*BSN ) ) ) ) - IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN -C Workspace for TB01VY. - JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) -C Workspace for TF01MX. - IF ( M.GT.0 ) THEN - IW1 = N + M - ELSE - IW1 = 0 - END IF - JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) - END IF - END IF -C - IF ( N.GE.0 ) THEN -C -C Find the number of parameters. -C - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - INFO = -16 - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF -C -C Workspace for MD03BD (whole optimization). -C - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN - IW3 = 4*NX - IW2 = IW3 + 1 - ELSE - IW2 = BSN + MAX( 3*BSN + 1, LTHS ) - IF ( NSMP.GT.BSN ) THEN - IW2 = MAX( IW2, 4*LTHS + 1 ) - IF ( NSMP.LT.2*BSN ) - $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) - END IF - IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) - END IF - JWORK = MAX( JWORK, NSML + NX + - $ MAX( 4, NSML + - $ MAX( NSML*( BSN + LTHS ) + - $ MAX( NSML + IW1, IW2 + NX ), - $ NX*( BSN + LTHS ) + NX + - $ MAX( NSML + IW1, NX + IW3 ) ) - $ ) ) - END IF -C - IF ( LDWORK.LT.JWORK ) THEN - INFO = -21 - DWORK(1) = JWORK - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF -C -C Initialize the pointers to system matrices and save the possible -C seed for random numbers generation. -C - Z = 1 - AC = Z + NSML - CALL DCOPY( 4, DWORK, 1, SEED, 1 ) -C - WRKOPT = 1 -C - IF ( INIT1 ) THEN -C -C Initialize the linear part. -C If N < 0, the order of the system is determined by IB01AD; -C otherwise, the given order will be used. -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; -C prefer: larger. -C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) -C - NS = N - IR = 1 - ISV = 2*ML*NOBR - LDR = ISV - IF ( LSAME( JOBD, 'M' ) ) - $ LDR = MAX( LDR, 3*MNO ) - ISV = IR + LDR*ISV - JWORK = ISV + L*NOBR -C - CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, - $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, - $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = 0 - IF ( LSAME( METH, 'N' ) ) THEN - IRCND = 2 - CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) - END IF -C - IF ( NS.GE.0 ) THEN - N = NS - ELSE -C -C Find the number of parameters. -C - LDAC = N + L - ISAD = LDAC*( N + M ) - N2 = N*N - LTHS = N*( ML + 1 ) + L*M - NX = NTHS + LTHS -C - IF ( LX.LT.NX ) THEN - LX = NX - INFO = -16 - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF -C Workspace for IB01BD. - IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + - $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, - $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, - $ MNO + 3*N + L ) ) - IF ( M.GT.0 ) THEN - IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + - $ MAX( LDAC**2, 4*M*LDAC + 1 ) - ELSE - IW2 = 0 - END IF - JWORK = ISV + ISAD + MAX( IW1, IW2 ) -C Workspace for IB01CD. - IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) - IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, - $ 4*N ) - JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + - $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) -C Workspace for TF01MX. - JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) -C Workspace for TB01VD. - JWORK = MAX( JWORK, NSML + ISAD + N + - $ MAX( 1, N2*L + N*L + N, - $ N2 + MAX( N2 + N*MAX( N, L ) + - $ 6*N + MIN( N, L ), N*M ) ) ) -C Workspace for MD03BD (whole optimization). - IF ( M.GT.0 ) THEN - IW1 = LDAC + M - ELSE - IW1 = L - END IF - IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) - IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN - IW3 = 4*NX - IW2 = IW3 + 1 - ELSE - IW2 = BSN + MAX( 3*BSN + 1, LTHS ) - IF ( NSMP.GT.BSN ) THEN - IW2 = MAX( IW2, 4*LTHS + 1 ) - IF ( NSMP.LT.2*BSN ) - $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) - END IF - IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) - END IF - JWORK = MAX( JWORK, NSML + NX + - $ MAX( 4, NSML + - $ MAX( NSML*( BSN + LTHS ) + - $ MAX( NSML + IW1, IW2 + NX ), - $ NX*( BSN + LTHS ) + NX + - $ MAX( NSML + IW1, NX + IW3 ) ) - $ ) ) - IF ( LDWORK.LT.JWORK ) THEN - INFO = -21 - DWORK(1) = JWORK - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF - END IF -C - BD = AC + LDAC*N - IX = BD + LDAC*M - IA = ISV - IB = IA + LDAC*N - IQ = IB + LDAC*M - IF ( LSAME( JOBCK, 'N' ) ) THEN - IRY = IQ - IS = IQ - IK = IQ - JWORK = IQ - ELSE - IRY = IQ + N2 - IS = IRY + L*L - IK = IS + N*L - JWORK = IK + N*L - END IF -C -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + -C max( LDW1,LDW2 ), where, -C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, -C L*NOBR*N + -C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, -C 2*(L*NOBR-L)*N+N*N+8*N, -C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) -C LDW2 >= 0, if M = 0; -C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ -C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; -C prefer: larger. -C Integer workspace: MAX(M*NOBR+N,M*(N+L)). -C - CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), - $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, - $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, - $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, - $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, - $ IWARNL, INFOL ) -C - IF( INFOL.EQ.-30 ) THEN - INFO = -21 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCNDB = 4 - IF ( LSAME( JOBCK, 'K' ) ) - $ IRCNDB = IRCNDB + 8 - CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) - IRCND = IRCND + IRCNDB -C -C Copy the system matrices to the beginning of DWORK, to save -C space, and redefine the pointers. -C - CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) - IA = 1 - IB = IA + LDAC*N - IX0 = IB + LDAC*M - IV = IX0 + N -C -C Compute the initial condition of the system. On normal exit, -C DWORK(i), i = JWORK+2:JWORK+1+N*N, -C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and -C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, -C contain the transformed system matrices At, Ct, and Bt, -C respectively, corresponding to the real Schur form of the -C estimated system state matrix A. The transformation matrix is -C stored in DWORK(IV:IV+N*N-1). -C The workspace needed is defined for the options set above -C in the PARAMETER statements. -C Workspace: -C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + -C max( 5*N, 2, min( LDW1, LDW2 ) ), where, -C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), -C LDW2 = N*(N + 1) + 2*N + -C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); -C prefer: larger. -C Integer workspace: N. -C - JWORK = IV + N2 - CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, - $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), - $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, - $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) -C - IF( INFOL.EQ.-26 ) THEN - INFO = -21 - DWORK(1) = DWORK(JWORK) - CALL XERBLA( 'IB03BD', -INFO ) - RETURN - END IF - IF( INFOL.EQ.1 ) - $ INFOL = 10 - IF( INFOL.NE.0 ) THEN - INFO = 100*INFOL - RETURN - END IF - IF( IWARNL.NE.0 ) - $ IWARN = 100*IWARNL - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IRCND = IRCND + 1 - RCND(IRCND) = DWORK(JWORK+1) -C -C Now, save the system matrices and x0 in the final location. -C - IF ( IV.LT.AC ) THEN - CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) - ELSE - DO 10 J = AC + ISAD + N - 1, AC, -1 - DWORK(J) = DWORK(IA+J-AC) - 10 CONTINUE - END IF -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - JWORK = IX + N - CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), - $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) -C -C Convert the state-space representation to output normal form. -C Workspace: -C need: NSMP*L + (N + L)*(N + M) + N + -C MAX(1, N*N*L + N*L + N, N*N + -C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); -C prefer: larger. -C - CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), - $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, - $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), - $ LDWORK-JWORK+1, INFOL ) -C - IF( INFOL.GT.0 ) THEN - INFO = INFOL + 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - END IF -C - LIPAR = 7 - IW1 = 0 - IW2 = 0 - IDIAG = AC -C - IF ( INIT2 ) THEN -C -C Initialize the nonlinear part. -C - IF ( .NOT.INIT1 ) THEN - BD = AC + LDAC*N - IX = BD + LDAC*M -C -C Convert the output normal form to state-space model. -C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. -C (NSMP*L locations are reserved for the output of the linear -C part.) -C - JWORK = IX + N - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), - $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, - $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, - $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - END IF -C -C Optimize the parameters of the nonlinear part. -C Workspace: -C need NSMP*L + BSN + -C MAX( 4, NSMP + -C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), -C BSN**2 + BSN + MAX( NSMP + 2*NN, 5*BSN ) )); -C prefer larger. -C Integer workspace: NN*(L + 2) + 2. -C - WORK(1) = ZERO - CALL DCOPY( 3, WORK(1), 0, WORK(2), 1 ) -C -C Set the integer parameters needed, including the number of -C neurons. -C - IPAR(1) = NSMP - IPAR(2) = L - IPAR(3) = NN - JWORK = IDIAG + BSN -C - DO 30 I = 0, L - 1 - CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) - CALL MD03BD( 'Random initialization', SCALE, COND, NF01BE, - $ MD03BA, MD03BB, NSMP, BSN, ITMAX1, FACTOR, - $ NPRINT, IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), - $ LDY, X(I*BSN+1), DWORK(IDIAG), NFEV, NJEV, - $ TOL1, TOL1, GTOL, TOL, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFOL ) - IF( INFOL.NE.0 ) THEN - INFO = 10*INFOL - RETURN - END IF - IF ( IWARNL.LT.0 ) THEN - INFO = INFOL - IWARN = IWARNL - GO TO 50 - ELSEIF ( IWARNL.GT.0 ) THEN - IF ( IWARN.GT.100 ) THEN - IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) - ELSE - IWARN = MAX( IWARN, 10*IWARNL ) - END IF - END IF - WORK(1) = MAX( WORK(1), DWORK(JWORK) ) - WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) - WORK(4) = MAX( WORK(4), DWORK(JWORK+3) ) - WORK(3) = WORK(3) + DWORK(JWORK+2) - IW1 = NFEV + IW1 - IW2 = NJEV + IW2 - 30 CONTINUE -C - END IF -C -C Main iteration. -C Workspace: -C need NSMP*L + NX + -C MAX( 4, NSMP*L + -C MAX( NSMP*L*( BSN + LTHS ) + -C MAX( NSMP*L + LDW1, LDW2 + NX ), -C NX*( BSN + LTHS ) + NX + -C MAX( NSMP*L + LDW1, NX + LDW3 ) ) ), -C LDW0 = MAX( N*(N+L), N+M+L ), if M > 0; -C LDW0 = MAX( N*(N+L), L ), if M = 0; -C LDW1 = NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + LDW0); -C LDW2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, -C LDW2 = BSN + MAX(3*BSN+1,LTHS); -C LDW2 = MAX(LDW2, 4*LTHS+1), if NSMP > BSN; -C LDW2 = MAX(LDW2, (NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; -C LDW3 = 4*NX, if L <= 1 or BSN = 0; -C LDW3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), -C if L > 1 and BSN > 0; -C prefer larger. -C Integer workspace: NX+L. -C -C Set the integer parameters describing the Jacobian structure -C and the number of neurons. -C - IPAR(1) = LTHS - IPAR(2) = L - IPAR(3) = NSMP - IPAR(4) = BSN - IPAR(5) = M - IPAR(6) = N - IPAR(7) = NN - JWORK = IDIAG + NX -C - CALL MD03BD( 'Given initialization', SCALE, COND, NF01BF, - $ NF01BS, NF01BP, NSML, NX, ITMAX2, FACTOR, NPRINT, - $ IPAR, LIPAR, U, LDU, Y, LDY, X, DWORK(IDIAG), NFEV, - $ NJEV, TOL2, TOL2, GTOL, TOL, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARNL, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - DO 40 I = 1, NX + L - IWORK(I+3) = IWORK(I) - 40 CONTINUE -C - 50 CONTINUE - IWORK(1) = IW1 + NFEV - IWORK(2) = IW2 + NJEV - IF ( IWARNL.LT.0 ) THEN - IWARN = IWARNL - ELSE - IWARN = IWARN + IWARNL - END IF - CALL DCOPY( 4, DWORK(JWORK), 1, DWORK, 1 ) - IF ( INIT2 ) - $ CALL DCOPY( 4, WORK, 1, DWORK(5), 1 ) - IF ( INIT1 ) THEN - IWORK(3) = IRCND - CALL DCOPY( IRCND, RCND, 1, DWORK(9), 1 ) - ELSE - IWORK(3) = 0 - END IF -C - RETURN -C -C *** Last line of IB03BD *** - END diff --git a/slycot/src/MA01AD.f b/slycot/src/MA01AD.f deleted file mode 100644 index eab214d0..00000000 --- a/slycot/src/MA01AD.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE MA01AD( XR, XI, YR, YI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the complex square root YR + i*YI of a complex number -C XR + i*XI in real arithmetic. The returned result is so that -C YR >= 0.0 and SIGN(YI) = SIGN(XI). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C XR (input) DOUBLE PRECISION -C XI (input) DOUBLE PRECISION -C These scalars define the real and imaginary part of the -C complex number of which the square root is sought. -C -C YR (output) DOUBLE PRECISION -C YI (output) DOUBLE PRECISION -C These scalars define the real and imaginary part of the -C complex square root. -C -C METHOD -C -C The complex square root YR + i*YI of the complex number XR + i*XI -C is computed in real arithmetic, taking care to avoid overflow. -C -C REFERENCES -C -C Adapted from EISPACK subroutine CSROOT. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, and -C R. Byers, University of Kansas, Lawrence, USA, -C Aug. 1998, routine DCROOT. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF - PARAMETER ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 ) -C .. -C .. Scalar Arguments .. - DOUBLE PRECISION XR, XI, YR, YI -C .. -C .. Local Scalars .. - DOUBLE PRECISION S -C .. -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C -C .. Intrinsic functions .. - INTRINSIC ABS, SQRT -C .. -C .. Executable Statements .. -C - S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) ) - IF ( XR.GE.ZERO ) YR = S - IF ( XI.LT.ZERO ) S = -S - IF ( XR.LE.ZERO ) THEN - YI = S - IF ( XR.LT.ZERO ) YR = HALF*( XI/S ) - ELSE - YI = HALF*( XI/YR ) - END IF -C - RETURN -C *** Last line of MA01AD *** - END diff --git a/slycot/src/MA02AD.f b/slycot/src/MA02AD.f deleted file mode 100644 index a3cec4e4..00000000 --- a/slycot/src/MA02AD.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To transpose all or part of a two-dimensional matrix A into -C another matrix B. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the part of the matrix A to be transposed into B -C as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part; -C Otherwise: All of the matrix A. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The m-by-n matrix A. If JOB = 'U', only the upper -C triangle or trapezoid is accessed; if JOB = 'L', only the -C lower triangle or trapezoid is accessed. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C B = A' in the locations specified by JOB. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine DMTRA. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER LDA, LDB, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*) -C .. Local Scalars .. - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. Intrinsic Functions .. - INTRINSIC MIN -C -C .. Executable Statements .. -C - IF( LSAME( JOB, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B(J,I) = A(I,J) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( JOB, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B(J,I) = A(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B(J,I) = A(I,J) - 50 CONTINUE - 60 CONTINUE - END IF -C - RETURN -C *** Last line of MA02AD *** - END diff --git a/slycot/src/MA02BD.f b/slycot/src/MA02BD.f deleted file mode 100644 index 38e71373..00000000 --- a/slycot/src/MA02BD.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE MA02BD( SIDE, M, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reverse the order of rows and/or columns of a given matrix A -C by pre-multiplying and/or post-multiplying it, respectively, with -C a permutation matrix P, where P is a square matrix of appropriate -C order, with ones down the secondary diagonal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies the operation to be performed, as follows: -C = 'L': the order of rows of A is to be reversed by -C pre-multiplying A with P; -C = 'R': the order of columns of A is to be reversed by -C post-multiplying A with P; -C = 'B': both the order of rows and the order of columns -C of A is to be reversed by pre-multiplying and -C post-multiplying A with P. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the given matrix whose rows and/or columns are to -C be permuted. -C On exit, the leading M-by-N part of this array contains -C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or -C P*A*P if SIDE = 'B'. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine PAP. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - LOGICAL BSIDES - INTEGER I, J, K, M2, N2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DSWAP -C .. Executable Statements .. -C - BSIDES = LSAME( SIDE, 'B' ) -C - IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN -C -C Compute P*A. -C - M2 = M/2 - K = M - M2 + 1 - DO 10 J = 1, N - CALL DSWAP( M2, A(1,J), -1, A(K,J), 1 ) - 10 CONTINUE - END IF - IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN -C -C Compute A*P. -C - N2 = N/2 - K = N - N2 + 1 - DO 20 I = 1, M - CALL DSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) - 20 CONTINUE - END IF -C - RETURN -C *** Last line of MA02BD *** - END diff --git a/slycot/src/MA02BZ.f b/slycot/src/MA02BZ.f deleted file mode 100644 index b2a699bf..00000000 --- a/slycot/src/MA02BZ.f +++ /dev/null @@ -1,114 +0,0 @@ - SUBROUTINE MA02BZ( SIDE, M, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reverse the order of rows and/or columns of a given matrix A -C by pre-multiplying and/or post-multiplying it, respectively, with -C a permutation matrix P, where P is a square matrix of appropriate -C order, with ones down the secondary diagonal. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies the operation to be performed, as follows: -C = 'L': the order of rows of A is to be reversed by -C pre-multiplying A with P; -C = 'R': the order of columns of A is to be reversed by -C post-multiplying A with P; -C = 'B': both the order of rows and the order of columns -C of A is to be reversed by pre-multiplying and -C post-multiplying A with P. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the given matrix whose rows and/or columns are to -C be permuted. -C On exit, the leading M-by-N part of this array contains -C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or -C P*A*P if SIDE = 'B'. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDA, M, N -C .. Array Arguments .. - COMPLEX*16 A(LDA,*) -C .. Local Scalars .. - LOGICAL BSIDES - INTEGER I, J, K, M2, N2 -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL ZSWAP -C .. Executable Statements .. -C - BSIDES = LSAME( SIDE, 'B' ) -C - IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN -C -C Compute P*A. -C - M2 = M/2 - K = M - M2 + 1 - DO 10 J = 1, N - CALL ZSWAP( M2, A(1,J), -1, A(K,J), 1 ) - 10 CONTINUE - END IF - IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN -C -C Compute A*P. -C - N2 = N/2 - K = N - N2 + 1 - DO 20 I = 1, M - CALL ZSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) - 20 CONTINUE - END IF -C - RETURN -C *** Last line of MA02BZ *** - END diff --git a/slycot/src/MA02CD.f b/slycot/src/MA02CD.f deleted file mode 100644 index e4948b89..00000000 --- a/slycot/src/MA02CD.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE MA02CD( N, KL, KU, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the pertranspose of a central band of a square matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrix A. N >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be pertransposed. -C 0 <= KL <= N-1. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be pertransposed. -C 0 <= KU <= N-1. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain a square matrix whose central band formed from -C the KL subdiagonals, the main diagonal and the KU -C superdiagonals will be pertransposed. -C On exit, the leading N-by-N part of this array contains -C the matrix A with its central band (the KL subdiagonals, -C the main diagonal and the KU superdiagonals) pertransposed -C (that is the elements of each antidiagonal appear in -C reversed order). This is equivalent to forming P*B'*P, -C where B is the matrix formed from the central band of A -C and P is a permutation matrix with ones down the secondary -C diagonal. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine DMPTR. -C -C REVISIONS -C -C A. Varga, December 2001. -C V. Sima, March 2004. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER KL, KU, LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, I1, LDA1 -C .. External Subroutines .. - EXTERNAL DSWAP -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( N.LE.1 ) - $ RETURN -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 10 I = 1, MIN( KL, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL DSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) - 10 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 20 I = 1, MIN( KU, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL DSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the diagonal. -C - I1 = N / 2 - IF( I1.GT.0 ) - $ CALL DSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) -C - RETURN -C *** Last line of MA02CD *** - END diff --git a/slycot/src/MA02CZ.f b/slycot/src/MA02CZ.f deleted file mode 100644 index 5bb85b5e..00000000 --- a/slycot/src/MA02CZ.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE MA02CZ( N, KL, KU, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the pertranspose of a central band of a square matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrix A. N >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be pertransposed. -C 0 <= KL <= N-1. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be pertransposed. -C 0 <= KU <= N-1. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain a square matrix whose central band formed from -C the KL subdiagonals, the main diagonal and the KU -C superdiagonals will be pertransposed. -C On exit, the leading N-by-N part of this array contains -C the matrix A with its central band (the KL subdiagonals, -C the main diagonal and the KU superdiagonals) pertransposed -C (that is the elements of each antidiagonal appear in -C reversed order). This is equivalent to forming P*B'*P, -C where B is the matrix formed from the central band of A -C and P is a permutation matrix with ones down the secondary -C diagonal. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER KL, KU, LDA, N -C .. Array Arguments .. - COMPLEX*16 A(LDA,*) -C .. Local Scalars .. - INTEGER I, I1, LDA1 -C .. External Subroutines .. - EXTERNAL ZSWAP -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( N.LE.1 ) - $ RETURN -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 10 I = 1, MIN( KL, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL ZSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) - 10 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 20 I = 1, MIN( KU, N-2 ) - I1 = (N-I) / 2 - IF( I1.GT.0 ) - $ CALL ZSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the diagonal. -C - I1 = N / 2 - IF( I1.GT.0 ) - $ CALL ZSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) -C - RETURN -C *** Last line of MA02CZ *** - END diff --git a/slycot/src/MA02DD.f b/slycot/src/MA02DD.f deleted file mode 100644 index ef7967e7..00000000 --- a/slycot/src/MA02DD.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To pack/unpack the upper or lower triangle of a symmetric matrix. -C The packed matrix is stored column-wise in the one-dimensional -C array AP. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies whether the matrix should be packed or unpacked, -C as follows: -C = 'P': The matrix should be packed; -C = 'U': The matrix should be unpacked. -C -C UPLO CHARACTER*1 -C Specifies the part of the matrix to be packed/unpacked, -C as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input or output) DOUBLE PRECISION array, dimension -C (LDA,N) -C This array is an input parameter if JOB = 'P', and an -C output parameter if JOB = 'U'. -C On entry, if JOB = 'P', the leading N-by-N upper -C triangular part (if UPLO = 'U'), or lower triangular part -C (if UPLO = 'L'), of this array must contain the -C corresponding upper or lower triangle of the symmetric -C matrix A, and the other strictly triangular part is not -C referenced. -C On exit, if JOB = 'U', the leading N-by-N upper triangular -C part (if UPLO = 'U'), or lower triangular part (if -C UPLO = 'L'), of this array contains the corresponding -C upper or lower triangle of the symmetric matrix A; the -C other strictly triangular part is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C AP (output or input) DOUBLE PRECISION array, dimension -C (N*(N+1)/2) -C This array is an output parameter if JOB = 'P', and an -C input parameter if JOB = 'U'. -C On entry, if JOB = 'U', the leading N*(N+1)/2 elements of -C this array must contain the upper (if UPLO = 'U') or lower -C (if UPLO = 'L') triangle of the symmetric matrix A, packed -C column-wise. That is, the elements are stored in the order -C 11, 12, 22, ..., 1n, 2n, 3n, ..., nn, if UPLO = 'U'; -C 11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'. -C On exit, if JOB = 'P', the leading N*(N+1)/2 elements of -C this array contain the upper (if UPLO = 'U') or lower -C (if UPLO = 'L') triangle of the symmetric matrix A, packed -C column-wise, as described above. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOB, UPLO - INTEGER LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), AP(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER IJ, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked for errors. -C - LUPLO = LSAME( UPLO, 'L' ) - IJ = 1 - IF( LSAME( JOB, 'P' ) ) THEN - IF( LUPLO ) THEN -C -C Pack the lower triangle of A. -C - DO 20 J = 1, N - CALL DCOPY( N-J+1, A(J,J), 1, AP(IJ), 1 ) - IJ = IJ + N - J + 1 - 20 CONTINUE -C - ELSE -C -C Pack the upper triangle of A. -C - DO 40 J = 1, N - CALL DCOPY( J, A(1,J), 1, AP(IJ), 1 ) - IJ = IJ + J - 40 CONTINUE -C - END IF - ELSE - IF( LUPLO ) THEN -C -C Unpack the lower triangle of A. -C - DO 60 J = 1, N - CALL DCOPY( N-J+1, AP(IJ), 1, A(J,J), 1 ) - IJ = IJ + N - J + 1 - 60 CONTINUE -C - ELSE -C -C Unpack the upper triangle of A. -C - DO 80 J = 1, N - CALL DCOPY( J, AP(IJ), 1, A(1,J), 1 ) - IJ = IJ + J - 80 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of MA02DD *** - END diff --git a/slycot/src/MA02ED.f b/slycot/src/MA02ED.f deleted file mode 100644 index 79ce82f7..00000000 --- a/slycot/src/MA02ED.f +++ /dev/null @@ -1,99 +0,0 @@ - SUBROUTINE MA02ED( UPLO, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To store by symmetry the upper or lower triangle of a symmetric -C matrix, given the other triangle. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix is given as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C For all other values, the array A is not referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part -C (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'), -C of this array must contain the corresponding upper or -C lower triangle of the symmetric matrix A. -C On exit, the leading N-by-N part of this array contains -C the symmetric matrix A with all elements stored. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked for errors. -C - IF( LSAME( UPLO, 'L' ) ) THEN -C -C Construct the upper triangle of A. -C - DO 20 J = 2, N - CALL DCOPY( J-1, A(J,1), LDA, A(1,J), 1 ) - 20 CONTINUE -C - ELSE IF( LSAME( UPLO, 'U' ) ) THEN -C -C Construct the lower triangle of A. -C - DO 40 J = 2, N - CALL DCOPY( J-1, A(1,J), 1, A(J,1), LDA ) - 40 CONTINUE -C - END IF - RETURN -C *** Last line of MA02ED *** - END diff --git a/slycot/src/MA02FD.f b/slycot/src/MA02FD.f deleted file mode 100644 index f2ec4350..00000000 --- a/slycot/src/MA02FD.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE MA02FD( X1, X2, C, S, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients c and s (c^2 + s^2 = 1) for a modified -C hyperbolic plane rotation, such that, -C -C y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2), -C y2 := -s * y1 + c * x2 = 0, -C -C given two real numbers x1 and x2, satisfying either x1 = x2 = 0, -C or abs(x2) < abs(x1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C X1 (input/output) DOUBLE PRECISION -C On entry, the real number x1. -C On exit, the real number y1. -C -C X2 (input) DOUBLE PRECISION -C The real number x2. -C The values x1 and x2 should satisfy either x1 = x2 = 0, or -C abs(x2) < abs(x1). -C -C C (output) DOUBLE PRECISION -C The cosines c of the modified hyperbolic plane rotation. -C -C S (output) DOUBLE PRECISION -C The sines s of the modified hyperbolic plane rotation. -C -C Error Indicator -C -C INFO INTEGER -C = 0: succesful exit; -C = 1: if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. -C -C KEYWORDS -C -C Orthogonal transformation, plane rotation. -C -C ***************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION X1, X2, C, S - INTEGER INFO -C .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -C .. Executable Statements .. -C - IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND. - $ ABS( X2 ).GE.ABS( X1 ) ) THEN - INFO = 1 - ELSE - INFO = 0 - IF ( X1.EQ.ZERO ) THEN - S = ZERO - C = ONE - ELSE - S = X2 / X1 -C -C No overflows could appear in the next statement; underflows -C are possible if X2 is tiny and X1 is huge, but then -C abs(C) = ONE - delta, -C where delta is much less than machine precision. -C - C = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 ) - X1 = C * X1 - END IF - END IF -C - RETURN -C *** Last line of MA02FD *** - END diff --git a/slycot/src/MA02GD.f b/slycot/src/MA02GD.f deleted file mode 100644 index 90cda2ed..00000000 --- a/slycot/src/MA02GD.f +++ /dev/null @@ -1,158 +0,0 @@ - SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform a series of column interchanges on the matrix A. -C One column interchange is initiated for each of columns K1 through -C K2 of A. This is useful for solving linear systems X*A = B, when -C the matrix A has already been factored by LAPACK Library routine -C DGETRF. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,*) -C On entry, the leading N-by-M part of this array must -C contain the matrix A to which the column interchanges will -C be applied, where M is the largest element of IPIV(K), for -C K = K1, ..., K2. -C On exit, the leading N-by-M part of this array contains -C the permuted matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C K1 (input) INTEGER -C The first element of IPIV for which a column interchange -C will be done. -C -C K2 (input) INTEGER -C The last element of IPIV for which a column interchange -C will be done. -C -C IPIV (input) INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) -C The vector of interchanging (pivot) indices. Only the -C elements in positions K1 through K2 of IPIV are accessed. -C IPIV(K) = L implies columns K and L are to be -C interchanged. -C -C INCX (input) INTEGER -C The increment between successive values of IPIV. -C If INCX is negative, the interchanges are applied in -C reverse order. -C -C METHOD -C -C The columns IPIV(K) and K are swapped for K = K1, ..., K2, for -C INCX = 1 (and similarly, for INCX <> 1). -C -C FURTHER COMMENTS -C -C This routine is the column-oriented counterpart of the LAPACK -C Library routine DLASWP. The LAPACK Library routine DLAPMT cannot -C be used in this context. To solve the system X*A = B, where A and -C B are N-by-N and M-by-N, respectively, the following statements -C can be used: -C -C CALL DGETRF( N, N, A, LDA, IPIV, INFO ) -C CALL DTRSM( 'R', 'U', 'N', 'N', M, N, ONE, A, LDA, B, LDB ) -C CALL DTRSM( 'R', 'L', 'N', 'U', M, N, ONE, A, LDA, B, LDB ) -C CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2008. -C -C KEYWORDS -C -C Elementary matrix operations, linear algebra. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - INTEGER J, JP, JX -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( INCX.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C -C Interchange column J with column IPIV(J) for each of columns K1 -C through K2. -C - IF( INCX.GT.0 ) THEN - JX = K1 - ELSE - JX = 1 + ( 1-K2 )*INCX - END IF -C - IF( INCX.EQ.1 ) THEN -C - DO 10 J = K1, K2 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 10 CONTINUE -C - ELSE IF( INCX.GT.1 ) THEN -C - DO 20 J = K1, K2 - JP = IPIV( JX ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - JX = JX + INCX - 20 CONTINUE -C - ELSE IF( INCX.LT.0 ) THEN -C - DO 30 J = K2, K1, -1 - JP = IPIV( JX ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - JX = JX + INCX - 30 CONTINUE -C - END IF -C - RETURN -C -C *** Last line of MA02GD *** - END diff --git a/slycot/src/MA02HD.f b/slycot/src/MA02HD.f deleted file mode 100644 index 2017da86..00000000 --- a/slycot/src/MA02HD.f +++ /dev/null @@ -1,180 +0,0 @@ - LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To check if A = DIAG*I, where I is an M-by-N matrix with ones on -C the diagonal and zeros elsewhere. -C -C FUNCTION VALUE -C -C MA02HD LOGICAL -C The function value is set to .TRUE. if A = DIAG*I, and to -C .FALSE., otherwise. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the part of the matrix A to be checked out, -C as follows: -C = 'U': Upper triangular/trapezoidal part; -C = 'L': Lower triangular/trapezoidal part. -C Otherwise: All of the matrix A. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C DIAG (input) DOUBLE PRECISION -C The scalar DIAG. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A. If JOB = 'U', only the upper triangle or -C trapezoid is accessed; if JOB = 'L', only the lower -C triangle or trapezoid is accessed. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C METHOD -C -C The routine returns immediately after detecting a diagonal element -C which differs from DIAG, or a nonzero off-diagonal element in the -C searched part of A. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. -C -C KEYWORDS -C -C Elementary operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER LDA, M, N - DOUBLE PRECISION DIAG -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, J -C .. External Functions - LOGICAL LSAME - EXTERNAL LSAME -C .. Intrinsic Functions .. - INTRINSIC MIN -C -C .. Executable Statements .. -C -C Do not check parameters, for efficiency. -C - IF( LSAME( JOB, 'U' ) ) THEN -C - DO 20 J = 1, N -C - DO 10 I = 1, MIN( J-1, M ) - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 10 CONTINUE -C - IF( J.LE.M ) THEN - IF( A(J,J).NE.DIAG ) THEN - MA02HD = .FALSE. - RETURN - END IF - END IF - 20 CONTINUE -C - ELSE IF( LSAME( JOB, 'L' ) ) THEN -C - DO 40 J = 1, MIN( M, N ) - IF( A(J,J).NE.DIAG ) THEN - MA02HD = .FALSE. - RETURN - END IF -C - IF ( J.NE.M ) THEN -C - DO 30 I = MIN( J+1, M ), M - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 30 CONTINUE -C - END IF - 40 CONTINUE -C - ELSE -C - DO 70 J = 1, N -C - DO 50 I = 1, MIN( J-1, M ) - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 50 CONTINUE -C - IF( J.LE.M ) THEN - IF( A(J,J).NE.DIAG ) THEN - MA02HD = .FALSE. - RETURN - END IF - END IF -C - IF ( J.LT.M ) THEN -C - DO 60 I = MIN( J+1, M ), M - IF( A(I,J).NE.ZERO ) THEN - MA02HD = .FALSE. - RETURN - END IF - 60 CONTINUE -C - END IF - 70 CONTINUE -C - END IF -C - MA02HD = .TRUE. -C - RETURN -C *** Last line of MA02HD *** - END diff --git a/slycot/src/MA02ID.f b/slycot/src/MA02ID.f deleted file mode 100644 index 8b822bb5..00000000 --- a/slycot/src/MA02ID.f +++ /dev/null @@ -1,293 +0,0 @@ - DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG, - $ LDQG, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the value of the one norm, or the Frobenius norm, or -C the infinity norm, or the element of largest absolute value -C of a real skew-Hamiltonian matrix -C -C [ A G ] T T -C X = [ T ], G = -G, Q = -Q, -C [ Q A ] -C -C or of a real Hamiltonian matrix -C -C [ A G ] T T -C X = [ T ], G = G, Q = Q, -C [ Q -A ] -C -C where A, G and Q are real n-by-n matrices. -C -C Note that for this kind of matrices the infinity norm is equal -C to the one norm. -C -C FUNCTION VALUE -C -C MA02ID DOUBLE PRECISION -C The computed norm. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYP CHARACTER*1 -C Specifies the type of the input matrix X: -C = 'S': X is skew-Hamiltonian; -C = 'H': X is Hamiltonian. -C -C NORM CHARACTER*1 -C Specifies the value to be returned in MA02ID: -C = '1' or 'O': one norm of X; -C = 'F' or 'E': Frobenius norm of X; -C = 'I': infinity norm of X; -C = 'M': max(abs(X(i,j)). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain in columns 1:N the lower triangular part of the -C matrix Q and in columns 2:N+1 the upper triangular part -C of the matrix G. If TYP = 'S', the parts containing the -C diagonal and the first supdiagonal of this array are not -C referenced. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C Workspace -C -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C where LDWORK >= 2*N when NORM = '1', NORM = 'I' or -C NORM = 'O'; otherwise, DWORK is not referenced. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER NORM, TYP - INTEGER LDA, LDQG, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*) -C .. Local Scalars .. - LOGICAL LSH - INTEGER I, J - DOUBLE PRECISION DSCL, DSUM, SCALE, SUM, TEMP, VALUE -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANGE, DLAPY2 - EXTERNAL DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DLASSQ -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C -C .. Executable Statements .. -C - LSH = LSAME( TYP, 'S' ) -C - IF ( N.EQ.0 ) THEN - VALUE = ZERO -C - ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN -C -C Find max(abs(A(i,j))). -C - VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK ) - IF ( N.GT.1 ) THEN - DO 30 J = 1, N+1 - DO 10 I = 1, J-2 - VALUE = MAX( VALUE, ABS( QG(I,J) ) ) - 10 CONTINUE - DO 20 I = J+1, N - VALUE = MAX( VALUE, ABS( QG(I,J) ) ) - 20 CONTINUE - 30 CONTINUE - END IF -C - ELSE IF ( LSAME( NORM, 'M' ) ) THEN -C -C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). -C - VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ), - $ DLANGE( 'MaxElement', N, N+1, QG, LDQG, - $ DWORK ) ) -C - ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. - $ LSAME( NORM, 'I' ) ) .AND. LSH ) THEN -C -C Find the column and row sums of A (in one pass). -C - VALUE = ZERO - DO 40 I = 1, N - DWORK(I) = ZERO - 40 CONTINUE -C - DO 60 J = 1, N - SUM = ZERO - DO 50 I = 1, N - TEMP = ABS( A(I,J) ) - SUM = SUM + TEMP - DWORK(I) = DWORK(I) + TEMP - 50 CONTINUE - DWORK(N+J) = SUM - 60 CONTINUE -C -C Compute the maximal absolute column sum. -C - DO 90 J = 1, N+1 - DO 70 I = 1, J-2 - TEMP = ABS( QG(I,J) ) - DWORK(I) = DWORK(I) + TEMP - DWORK(J-1) = DWORK(J-1) + TEMP - 70 CONTINUE - IF ( J.LT.N+1 ) THEN - SUM = DWORK(N+J) - DO 80 I = J+1, N - TEMP = ABS( QG(I,J) ) - SUM = SUM + TEMP - DWORK(N+I) = DWORK(N+I) + TEMP - 80 CONTINUE - VALUE = MAX( VALUE, SUM ) - END IF - 90 CONTINUE - DO 100 I = 1, N - VALUE = MAX( VALUE, DWORK(I) ) - 100 CONTINUE -C - ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. - $ LSAME( NORM, 'I' ) ) THEN -C -C Find the column and row sums of A (in one pass). -C - VALUE = ZERO - DO 110 I = 1, N - DWORK(I) = ZERO - 110 CONTINUE -C - DO 130 J = 1, N - SUM = ZERO - DO 120 I = 1, N - TEMP = ABS( A(I,J) ) - SUM = SUM + TEMP - DWORK(I) = DWORK(I) + TEMP - 120 CONTINUE - DWORK(N+J) = SUM - 130 CONTINUE -C -C Compute the maximal absolute column sum. -C - DO 160 J = 1, N+1 - DO 140 I = 1, J-2 - TEMP = ABS( QG(I,J) ) - DWORK(I) = DWORK(I) + TEMP - DWORK(J-1) = DWORK(J-1) + TEMP - 140 CONTINUE - IF ( J.GT.1 ) - $ DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) ) - IF ( J.LT.N+1 ) THEN - SUM = DWORK(N+J) + ABS( QG(J,J) ) - DO 150 I = J+1, N - TEMP = ABS( QG(I,J) ) - SUM = SUM + TEMP - DWORK(N+I) = DWORK(N+I) + TEMP - 150 CONTINUE - VALUE = MAX( VALUE, SUM ) - END IF - 160 CONTINUE - DO 170 I = 1, N - VALUE = MAX( VALUE, DWORK(I) ) - 170 CONTINUE -C - ELSE IF ( ( LSAME( NORM, 'F' ) .OR. - $ LSAME( NORM, 'E' ) ) .AND. LSH ) THEN -C -C Find normF(A). -C - SCALE = ZERO - SUM = ONE - DO 180 J = 1, N - CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) - 180 CONTINUE -C -C Add normF(G) and normF(Q). -C - DO 190 J = 1, N+1 - IF ( J.GT.2 ) - $ CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) - IF ( J.LT.N ) - $ CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) - 190 CONTINUE - VALUE = SQRT( TWO )*SCALE*SQRT( SUM ) - ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN - SCALE = ZERO - SUM = ONE - DO 200 J = 1, N - CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) - 200 CONTINUE - DSCL = ZERO - DSUM = ONE - DO 210 J = 1, N+1 - IF ( J.GT.1 ) THEN - CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) - CALL DLASSQ( 1, QG(J-1,J), 1, DSCL, DSUM ) - END IF - IF ( J.LT.N+1 ) THEN - CALL DLASSQ( 1, QG(J,J), 1, DSCL, DSUM ) - CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) - END IF - 210 CONTINUE - VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), - $ DSCL*SQRT( DSUM ) ) - END IF -C - MA02ID = VALUE - RETURN -C *** Last line of MA02ID *** - END diff --git a/slycot/src/MA02JD.f b/slycot/src/MA02JD.f deleted file mode 100644 index ebf75d0a..00000000 --- a/slycot/src/MA02JD.f +++ /dev/null @@ -1,164 +0,0 @@ - DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, - $ LDQ2, RES, LDRES ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute || Q^T Q - I ||_F for a matrix of the form -C -C [ op( Q1 ) op( Q2 ) ] -C Q = [ ], -C [ -op( Q2 ) op( Q1 ) ] -C -C where Q1 and Q2 are N-by-N matrices. This residual can be used to -C test wether Q is numerically an orthogonal symplectic matrix. -C -C FUNCTION VALUE -C -C MA02JD DOUBLE PRECISION -C The computed residual. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRAN1 LOGICAL -C Specifies the form of op( Q1 ) as follows: -C = .FALSE.: op( Q1 ) = Q1; -C = .TRUE. : op( Q1 ) = Q1'. -C -C LTRAN2 LOGICAL -C Specifies the form of op( Q2 ) as follows: -C = .FALSE.: op( Q2 ) = Q2; -C = .TRUE. : op( Q2 ) = Q2'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices Q1 and Q2. N >= 0. -C -C Q1 (input) DOUBLE PRECISION array, dimension (LDQ1,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix op( Q1 ). -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). -C -C Q2 (input) DOUBLE PRECISION array, dimension (LDQ2,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix op( Q2 ). -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). -C -C Workspace -C -C RES DOUBLE PRECISION array, dimension (LDRES,N) -C -C LDRES INTEGER -C The leading dimension of the array RES. LDRES >= MAX(1,N). -C -C METHOD -C -C The routine computes the residual by simple elementary operations. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS). -C -C KEYWORDS -C -C Elementary operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - LOGICAL LTRAN1, LTRAN2 - INTEGER LDQ1, LDQ2, LDRES, N -C .. Array Arguments .. - DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Subroutines .. - EXTERNAL DGEMM -C .. External Functions .. - DOUBLE PRECISION DLANGE, DLAPY2 - EXTERNAL DLANGE, DLAPY2 -C .. Intrinsic Functions .. - INTRINSIC SQRT -C -C .. Executable Statements .. -C - IF ( LTRAN1 ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) - END IF - IF ( LTRAN2 ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) - END IF - DO 10 I = 1, N - RES(I,I) = RES(I,I) - ONE - 10 CONTINUE - TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY ) - IF ( LTRAN1 .AND. LTRAN2 ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - ELSE IF ( LTRAN1 ) THEN - CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - ELSE IF ( LTRAN2 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - ELSE - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, - $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, - $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) - END IF - TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES, - $ DUMMY ) ) - MA02JD = SQRT( TWO )*TEMP - RETURN -C *** Last line of MA02JD *** - END diff --git a/slycot/src/MB01MD.f b/slycot/src/MB01MD.f deleted file mode 100644 index 94f99f57..00000000 --- a/slycot/src/MB01MD.f +++ /dev/null @@ -1,279 +0,0 @@ - SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the matrix-vector operation -C -C y := alpha*A*x + beta*y, -C -C where alpha and beta are scalars, x and y are vectors of length -C n and A is an n-by-n skew-symmetric matrix. -C -C This is a modified version of the vanilla implemented BLAS -C routine DSYMV written by Jack Dongarra, Jeremy Du Croz, -C Sven Hammarling, and Richard Hanson. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies whether the upper or lower triangular part of -C the array A is to be referenced as follows: -C = 'U': only the strictly upper triangular part of A is to -C be referenced; -C = 'L': only the strictly lower triangular part of A is to -C be referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. If alpha is zero the array A is not -C referenced. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C On entry with UPLO = 'U', the leading N-by-N part of this -C array must contain the strictly upper triangular part of -C the matrix A. The lower triangular part of this array is -C not referenced. -C On entry with UPLO = 'L', the leading N-by-N part of this -C array must contain the strictly lower triangular part of -C the matrix A. The upper triangular part of this array is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N) -C -C X (input) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCX ) ). -C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of -C this array must contain the elements of the vector X. -C -C INCX (input) INTEGER -C The increment for the elements of X. IF INCX < 0 then the -C elements of X are accessed in reversed order. INCX <> 0. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. If beta is zero then Y need not be set on -C input. -C -C Y (input/output) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCY ) ). -C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of -C this array must contain the elements of the vector Y. -C On exit, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of -C this array contain the updated elements of the vector Y. -C -C INCY (input) INTEGER -C The increment for the elements of Y. IF INCY < 0 then the -C elements of Y are accessed in reversed order. INCY <> 0. -C -C NUMERICAL ASPECTS -C -C Though being almost identical with the vanilla implementation -C of the BLAS routine DSYMV the performance of this routine could -C be significantly lower in the case of vendor supplied, highly -C optimized BLAS. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKMV). -C -C KEYWORDS -C -C Elementary matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER UPLO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), X(*), Y(*) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF ( N.LT.0 )THEN - INFO = 2 - ELSE IF ( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF ( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF ( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF ( INFO.NE.0 )THEN - CALL XERBLA( 'MB01MD', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C -C Set up the start points in X and Y. -C - IF ( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF ( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C -C First form y := beta*y. -C - IF ( BETA.NE.ONE )THEN - IF ( INCY.EQ.1 )THEN - IF ( BETA.EQ.ZERO )THEN - DO 10 I = 1, N - Y(I) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ELSE - IY = KY - IF ( BETA.EQ.ZERO )THEN - DO 30 I = 1, N - Y(IY) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y(IY) = BETA*Y(IY) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF -C -C Quick return if possible. -C - IF ( ALPHA.EQ.ZERO ) - $ RETURN - IF ( LSAME( UPLO, 'U' ) )THEN -C -C Form y when A is stored in upper triangle. -C - IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60 J = 2, N - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 50 CONTINUE - Y(J) = Y(J) - ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX + INCX - JY = KY + INCY - DO 80 J = 2, N - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1, J - 1 - Y(IY) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y(JY) = Y(JY) - ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -C -C Form y when A is stored in lower triangle. -C - IF ( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) )THEN - DO 100 J = 1, N - 1 - TEMP1 = ALPHA*X(J) - TEMP2 = ZERO - DO 90 I = J + 1, N - Y(I) = Y(I) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(I) - 90 CONTINUE - Y(J) = Y(J) - ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - 1 - TEMP1 = ALPHA*X(JX) - TEMP2 = ZERO - IX = JX - IY = JY - DO 110 I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y(IY ) = Y(IY) + TEMP1*A(I,J) - TEMP2 = TEMP2 + A(I,J)*X(IX) - 110 CONTINUE - Y(JY) = Y(JY) - ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -C *** Last line of MB01MD *** - END diff --git a/slycot/src/MB01ND.f b/slycot/src/MB01ND.f deleted file mode 100644 index 036facf7..00000000 --- a/slycot/src/MB01ND.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the skew-symmetric rank 2 operation -C -C A := alpha*x*y' - alpha*y*x' + A, -C -C where alpha is a scalar, x and y are vectors of length n and A is -C an n-by-n skew-symmetric matrix. -C -C This is a modified version of the vanilla implemented BLAS -C routine DSYR2 written by Jack Dongarra, Jeremy Du Croz, -C Sven Hammarling, and Richard Hanson. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies whether the upper or lower triangular part of -C the array A is to be referenced as follows: -C = 'U': only the strictly upper triangular part of A is to -C be referenced; -C = 'L': only the strictly lower triangular part of A is to -C be referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. If alpha is zero X and Y are not -C referenced. -C -C X (input) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCX ) ). -C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of -C this array must contain the elements of the vector X. -C -C INCX (input) INTEGER -C The increment for the elements of X. IF INCX < 0 then the -C elements of X are accessed in reversed order. INCX <> 0. -C -C Y (input) DOUBLE PRECISION array, dimension -C ( 1 + ( N - 1 )*abs( INCY ) ). -C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of -C this array must contain the elements of the vector Y. -C -C INCY (input) INTEGER -C The increment for the elements of Y. IF INCY < 0 then the -C elements of Y are accessed in reversed order. INCY <> 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry with UPLO = 'U', the leading N-by-N part of this -C array must contain the strictly upper triangular part of -C the matrix A. The lower triangular part of this array is -C not referenced. -C On entry with UPLO = 'L', the leading N-by-N part of this -C array must contain the strictly lower triangular part of -C the matrix A. The upper triangular part of this array is -C not referenced. -C On exit with UPLO = 'U', the leading N-by-N part of this -C array contains the strictly upper triangular part of the -C updated matrix A. -C On exit with UPLO = 'L', the leading N-by-N part of this -C array contains the strictly lower triangular part of the -C updated matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N) -C -C NUMERICAL ASPECTS -C -C Though being almost identical with the vanilla implementation -C of the BLAS routine DSYR2 the performance of this routine could -C be significantly lower in the case of vendor supplied, highly -C optimized BLAS. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKR2). -C -C KEYWORDS -C -C Elementary matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER UPLO -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF ( N.LT.0 )THEN - INFO = 2 - ELSE IF ( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF ( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF ( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF -C - IF ( INFO.NE.0 )THEN - CALL XERBLA( 'MB01ND', INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -C -C Set up the start points in X and Y if the increments are not both -C unity. -C - IF ( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF ( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF ( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -C -C Start the operations. In this version the elements of A are -C accessed sequentially with one pass through the triangular part -C of A. -C - IF ( LSAME( UPLO, 'U' ) )THEN -C -C Form A when A is stored in the upper triangle. -C - IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20 J = 2, N - IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 10 I = 1, J-1 - A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40 J = 2, N - IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = KX - IY = KY - DO 30 I = 1, J-1 - A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -C -C Form A when A is stored in the lower triangle. -C - IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60 J = 1, N-1 - IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(J) - TEMP2 = ALPHA*X(J) - DO 50 I = J+1, N - A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80 J = 1, N-1 - IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y(JY) - TEMP2 = ALPHA*X(JX) - IX = JX - IY = JY - DO 70 I = J+1, N - A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF - RETURN -C *** Last line of MB01ND *** - END diff --git a/slycot/src/MB01PD.f b/slycot/src/MB01PD.f deleted file mode 100644 index 1845ab8a..00000000 --- a/slycot/src/MB01PD.f +++ /dev/null @@ -1,271 +0,0 @@ - SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A, - $ LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To scale a matrix or undo scaling. Scaling is performed, if -C necessary, so that the matrix norm will be in a safe range of -C representable numbers. -C -C ARGUMENTS -C -C Mode Parameters -C -C SCUN CHARACTER*1 -C SCUN indicates the operation to be performed. -C = 'S': scale the matrix. -C = 'U': undo scaling of the matrix. -C -C TYPE CHARACTER*1 -C TYPE indicates the storage type of the input matrix. -C = 'G': A is a full matrix. -C = 'L': A is a (block) lower triangular matrix. -C = 'U': A is an (block) upper triangular matrix. -C = 'H': A is an (block) upper Hessenberg matrix. -C = 'B': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C lower half stored. -C = 'Q': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C upper half stored. -C = 'Z': A is a band matrix with lower bandwidth KL and -C upper bandwidth KU. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C KL (input) INTEGER -C The lower bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C KU (input) INTEGER -C The upper bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C ANRM (input) DOUBLE PRECISION -C The norm of the initial matrix A. ANRM >= 0. -C When ANRM = 0 then an immediate return is effected. -C ANRM should be preserved between the call of the routine -C with SCUN = 'S' and the corresponding one with SCUN = 'U'. -C -C NBL (input) INTEGER -C The number of diagonal blocks of the matrix A, if it has a -C block structure. To specify that matrix A has no block -C structure, set NBL = 0. NBL >= 0. -C -C NROWS (input) INTEGER array, dimension max(1,NBL) -C NROWS(i) contains the number of rows and columns of the -C i-th diagonal block of matrix A. The sum of the values -C NROWS(i), for i = 1: NBL, should be equal to min(M,N). -C The elements of the array NROWS are not referenced if -C NBL = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M by N part of this array must -C contain the matrix to be scaled/unscaled. -C On exit, the leading M by N part of A will contain -C the modified matrix. -C The storage mode of A is specified by TYPE. -C -C LDA (input) INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Denote by ANRM the norm of the matrix, and by SMLNUM and BIGNUM, -C two positive numbers near the smallest and largest safely -C representable numbers, respectively. The matrix is scaled, if -C needed, such that the norm of the result is in the range -C [SMLNUM, BIGNUM]. The scaling factor is represented as a ratio -C of two numbers, one of them being ANRM, and the other one either -C SMLNUM or BIGNUM, depending on ANRM being less than SMLNUM or -C larger than BIGNUM, respectively. For undoing the scaling, the -C norm is again compared with SMLNUM or BIGNUM, and the reciprocal -C of the previous scaling factor is used. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C REVISIONS -C -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SCUN, TYPE - INTEGER INFO, KL, KU, LDA, M, MN, N, NBL - DOUBLE PRECISION ANRM -C .. Array Arguments .. - INTEGER NROWS ( * ) - DOUBLE PRECISION A( LDA, * ) -C .. Local Scalars .. - LOGICAL FIRST, LSCALE - INTEGER I, ISUM, ITYPE - DOUBLE PRECISION BIGNUM, SMLNUM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, MB01QD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Save statement .. - SAVE BIGNUM, FIRST, SMLNUM -C .. Data statements .. - DATA FIRST/.TRUE./ -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSCALE = LSAME( SCUN, 'S' ) - 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 -C - MN = MIN( M, N ) -C - ISUM = 0 - IF( NBL.GT.0 ) THEN - DO 10 I = 1, NBL - ISUM = ISUM + NROWS(I) - 10 CONTINUE - END IF -C - IF( .NOT.LSCALE .AND. .NOT.LSAME( SCUN, 'U' ) ) THEN - INFO = -1 - ELSE IF( ITYPE.EQ.-1 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. N.NE.M ) ) THEN - INFO = -4 - ELSE IF( ANRM.LT.ZERO ) THEN - INFO = -7 - ELSE IF( NBL.LT.0 ) THEN - INFO = -8 - ELSE IF( NBL.GT.0 .AND. ISUM.NE.MN ) THEN - INFO = -9 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -5 - 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 = -6 - 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 = -11 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MN.EQ.0 .OR. ANRM.EQ.ZERO ) - $ RETURN -C - IF ( FIRST ) THEN -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - FIRST = .FALSE. - END IF -C - IF ( LSCALE ) THEN -C -C Scale A, if its norm is outside range [SMLNUM,BIGNUM]. -C - IF( ANRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL MB01QD( TYPE, M, N, KL, KU, ANRM, SMLNUM, NBL, NROWS, - $ A, LDA, INFO ) - ELSE IF( ANRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL MB01QD( TYPE, M, N, KL, KU, ANRM, BIGNUM, NBL, NROWS, - $ A, LDA, INFO ) - END IF -C - ELSE -C -C Undo scaling. -C - IF( ANRM.LT.SMLNUM ) THEN - CALL MB01QD( TYPE, M, N, KL, KU, SMLNUM, ANRM, NBL, NROWS, - $ A, LDA, INFO ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - CALL MB01QD( TYPE, M, N, KL, KU, BIGNUM, ANRM, NBL, NROWS, - $ A, LDA, INFO ) - END IF - END IF -C - RETURN -C *** Last line of MB01PD *** - END diff --git a/slycot/src/MB01QD.f b/slycot/src/MB01QD.f deleted file mode 100644 index 61befc51..00000000 --- a/slycot/src/MB01QD.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A, - $ LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To multiply the M by N real matrix A by the real scalar CTO/CFROM. -C This is done without over/underflow as long as the final result -C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -C A may be full, (block) upper triangular, (block) lower triangular, -C (block) upper Hessenberg, or banded. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C TYPE indices the storage type of the input matrix. -C = 'G': A is a full matrix. -C = 'L': A is a (block) lower triangular matrix. -C = 'U': A is a (block) upper triangular matrix. -C = 'H': A is a (block) upper Hessenberg matrix. -C = 'B': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C lower half stored. -C = 'Q': A is a symmetric band matrix with lower bandwidth -C KL and upper bandwidth KU and with the only the -C upper half stored. -C = 'Z': A is a band matrix with lower bandwidth KL and -C upper bandwidth KU. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C KL (input) INTEGER -C The lower bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C KU (input) INTEGER -C The upper bandwidth of A. Referenced only if TYPE = 'B', -C 'Q' or 'Z'. -C -C CFROM (input) DOUBLE PRECISION -C CTO (input) DOUBLE PRECISION -C The matrix A is multiplied by CTO/CFROM. A(I,J) is -C computed without over/underflow if the final result -C CTO*A(I,J)/CFROM can be represented without over/ -C underflow. CFROM must be nonzero. -C -C NBL (input) INTEGER -C The number of diagonal blocks of the matrix A, if it has a -C block structure. To specify that matrix A has no block -C structure, set NBL = 0. NBL >= 0. -C -C NROWS (input) INTEGER array, dimension max(1,NBL) -C NROWS(i) contains the number of rows and columns of the -C i-th diagonal block of matrix A. The sum of the values -C NROWS(i), for i = 1: NBL, should be equal to min(M,N). -C The array NROWS is not referenced if NBL = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C The matrix to be multiplied by CTO/CFROM. See TYPE for -C the storage type. -C -C LDA (input) INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C Not used in this implementation. -C -C METHOD -C -C Matrix A is multiplied by the real scalar CTO/CFROM, taking into -C account the specified storage mode of the matrix. -C MB01QD is a version of the LAPACK routine DLASCL, modified for -C dealing with block triangular, or block Hessenberg matrices. -C For efficiency, no tests of the input scalar parameters are -C performed. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N, NBL - DOUBLE PRECISION CFROM, CTO -C .. -C .. Array Arguments .. - INTEGER NROWS ( * ) - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - LOGICAL DONE, NOBLC - INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3, - $ K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C - 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 - ITYPE = 6 - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) - $ RETURN -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -C - CFROMC = CFROM - CTOC = CTO -C - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - CTO1 = CTOC / BIGNUM - 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 -C - NOBLC = NBL.EQ.0 -C - IF( ITYPE.EQ.0 ) THEN -C -C Full matrix -C - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -C - ELSE IF( ITYPE.EQ.1 ) THEN -C - IF ( NOBLC ) THEN -C -C Lower triangular matrix -C - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -C - ELSE -C -C Block lower triangular matrix -C - JFIN = 0 - DO 80 K = 1, NBL - JINI = JFIN + 1 - JFIN = JFIN + NROWS( K ) - DO 70 J = JINI, JFIN - DO 60 I = JINI, M - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - END IF -C - ELSE IF( ITYPE.EQ.2 ) THEN -C - IF ( NOBLC ) THEN -C -C Upper triangular matrix -C - DO 100 J = 1, N - DO 90 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 90 CONTINUE - 100 CONTINUE -C - ELSE -C -C Block upper triangular matrix -C - JFIN = 0 - DO 130 K = 1, NBL - JINI = JFIN + 1 - JFIN = JFIN + NROWS( K ) - IF ( K.EQ.NBL ) JFIN = N - DO 120 J = JINI, JFIN - DO 110 I = 1, MIN( JFIN, M ) - A( I, J ) = A( I, J )*MUL - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - END IF -C - ELSE IF( ITYPE.EQ.3 ) THEN -C - IF ( NOBLC ) THEN -C -C Upper Hessenberg matrix -C - DO 150 J = 1, N - DO 140 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -C - ELSE -C -C Block upper Hessenberg matrix -C - JFIN = 0 - DO 180 K = 1, NBL - JINI = JFIN + 1 - JFIN = JFIN + NROWS( K ) -C - IF ( K.EQ.NBL ) THEN - JFIN = N - IFIN = N - ELSE - IFIN = JFIN + NROWS( K+1 ) - END IF -C - DO 170 J = JINI, JFIN - DO 160 I = 1, MIN( IFIN, M ) - A( I, J ) = A( I, J )*MUL - 160 CONTINUE - 170 CONTINUE - 180 CONTINUE - END IF -C - ELSE IF( ITYPE.EQ.4 ) THEN -C -C Lower half of a symmetric band matrix -C - K3 = KL + 1 - K4 = N + 1 - DO 200 J = 1, N - DO 190 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 190 CONTINUE - 200 CONTINUE -C - ELSE IF( ITYPE.EQ.5 ) THEN -C -C Upper half of a symmetric band matrix -C - K1 = KU + 2 - K3 = KU + 1 - DO 220 J = 1, N - DO 210 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 210 CONTINUE - 220 CONTINUE -C - ELSE IF( ITYPE.EQ.6 ) THEN -C -C Band matrix -C - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 240 J = 1, N - DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 230 CONTINUE - 240 CONTINUE -C - END IF -C - IF( .NOT.DONE ) - $ GO TO 10 -C - RETURN -C *** Last line of MB01QD *** - END diff --git a/slycot/src/MB01RD.f b/slycot/src/MB01RD.f deleted file mode 100644 index 2c53070d..00000000 --- a/slycot/src/MB01RD.f +++ /dev/null @@ -1,345 +0,0 @@ - SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, - $ X, LDX, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C _ -C where alpha and beta are scalars, R, X, and R are symmetric -C matrices, A is a general matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the symmetric matrices R, R, -C and X are given as follows: -C = 'U': the upper triangular part is given; -C = 'L': the lower triangular part is given. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R and the number of rows -C of the matrix op( A ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix X and the number of columns of the -C the matrix op( A ). N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry, except when R is identified with X in -C the call (which is possible only in this case). -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and X are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R; the strictly -C lower triangular part of the array is used as workspace. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R; the strictly -C upper triangular part of the array is used as workspace. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. If beta <> 0, the remaining -C strictly triangular part of this array contains the -C corresponding part of the matrix expression -C beta*op( A )*T*op( A )', where T is the triangular matrix -C defined in the Method section. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k) -C where k is N when TRANS = 'N' and is M when TRANS = 'T' or -C TRANS = 'C'. -C On entry with TRANS = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,l), -C where l is M when TRANS = 'N' and is N when TRANS = 'T' or -C TRANS = 'C'. -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix X and the strictly -C lower triangular part of the array is not referenced. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix X and the strictly -C upper triangular part of the array is not referenced. -C On exit, each diagonal element of this array has half its -C input value, but the other elements are not modified. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, the leading M-by-N part of this -C array (with the leading dimension MAX(1,M)) returns the -C matrix product beta*op( A )*T, where T is the triangular -C matrix defined in the Method section. -C This array is not referenced when beta = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,M*N), if beta <> 0; -C LDWORK >= 1, if beta = 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the symmetry -C into account. Specifically, let X = T + T', with T an upper or -C lower triangular matrix, defined by -C -C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', -C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', -C -C where triu, tril, and diag denote the upper triangular part, lower -C triangular part, and diagonal part of X, respectively. Then, -C -C op( A )*X*op( A )' = B + B', -C -C where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it -C can be written as tri( B ) + stri( B ), where tri denotes the -C triangular part specified by UPLO, and stri denotes the remaining -C strictly triangular part. Let R = V + V', with V defined as T -C above. Then, the required triangular part of the result can be -C written as -C -C alpha*V + beta*tri( B ) + beta*(stri( B ))' + -C alpha*diag( V ) + beta*diag( tri( B ) ). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 2 2 -C 3/2 x M x N + 1/2 x M -C -C operations. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, -C Apr. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - CHARACTER*12 NTRAN - LOGICAL LTRANS, LUPLO - INTEGER J, JWORK, LDW, NROWA -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASCL, DLASET, - $ DSCAL, DTRMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF ( LTRANS ) THEN - NROWA = N - NTRAN = 'No transpose' - ELSE - NROWA = M - NTRAN = 'Transpose' - END IF -C - LDW = MAX( 1, M ) -C - IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.LDW ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.MAX( 1, M*N ) ) - $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.1 ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - CALL DSCAL( N, HALF, X, LDX+1 ) - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. Efficiently compute -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C -C as described in the Method section. -C -C Compute W = beta*op( A )*T in DWORK. -C Workspace: need M*N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code.) -C - IF( LTRANS ) THEN - JWORK = 1 -C - DO 10 J = 1, N - CALL DCOPY( M, A(J,1), LDA, DWORK(JWORK), 1 ) - JWORK = JWORK + LDW - 10 CONTINUE -C - ELSE - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, LDW ) - END IF -C - CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA, - $ X, LDX, DWORK, LDW ) -C -C Compute Y = alpha*V + W*op( A )' in R. First, set to zero the -C strictly triangular part of R not specified by UPLO. That part -C will then contain beta*stri( B ). -C - IF ( ALPHA.NE.ZERO ) THEN - IF ( M.GT.1 ) THEN - IF ( LUPLO ) THEN - CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR ) - ELSE - CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR ) - END IF - END IF - CALL DSCAL( M, HALF, R, LDR+1 ) - END IF -C - CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A, - $ LDA, ALPHA, R, LDR ) -C -C Add the term corresponding to B', with B = op( A )*T*op( A )'. -C - IF( LUPLO ) THEN -C - DO 20 J = 1, M - CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 ) - 20 CONTINUE -C - ELSE -C - DO 30 J = 1, M - CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR ) - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB01RD *** - END diff --git a/slycot/src/MB01RU.f b/slycot/src/MB01RU.f deleted file mode 100644 index c22549cc..00000000 --- a/slycot/src/MB01RU.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, - $ X, LDX, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C _ -C where alpha and beta are scalars, R, X, and R are symmetric -C matrices, A is a general matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangles of the symmetric matrices R -C and X are given as follows: -C = 'U': the upper triangular part is given; -C = 'L': the lower triangular part is given. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R and the number of rows -C of the matrix op( A ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix X and the number of columns of the -C the matrix op( A ). N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry, except when R is identified with X in -C the call. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and X are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k) -C where k is N when TRANS = 'N' and is M when TRANS = 'T' or -C TRANS = 'C'. -C On entry with TRANS = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,k), -C where k is M when TRANS = 'N' and is N when TRANS = 'T' or -C TRANS = 'C'. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix X and the strictly -C lower triangular part of the array is not referenced. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix X and the strictly -C upper triangular part of the array is not referenced. -C The diagonal elements of this array are modified -C internally, but are restored on exit. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This array is not referenced when beta = 0, or M*N = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= M*N, if beta <> 0; -C LDWORK >= 0, if beta = 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the symmetry -C into account. Specifically, let X = T + T', with T an upper or -C lower triangular matrix, defined by -C -C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', -C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', -C -C where triu, tril, and diag denote the upper triangular part, lower -C triangular part, and diagonal part of X, respectively. Then, -C -C A*X*A' = ( A*T )*A' + A*( A*T )', for TRANS = 'N', -C A'*X*A = A'*( T*A ) + ( T*A )'*A, for TRANS = 'T', or 'C', -C -C which involve BLAS 3 operations (DTRMM and DSYR2K). -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 2 2 -C 3/2 x M x N + 1/2 x M -C -C operations. -C -C FURTHER COMMENTS -C -C This is a simpler version for MB01RD. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1999. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2004. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LTRANS, LUPLO -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DLASET, DSCAL, DSYR2K, DTRMM, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.1 .OR. ( LTRANS .AND. LDA.LT.N ) .OR. - $ ( .NOT.LTRANS .AND. LDA.LT.M ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.M*N ) - $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute W = op( A )*T or W = T*op( A ) in DWORK, and apply the -C updating formula (see METHOD section). -C Workspace: need M*N. -C - CALL DSCAL( N, HALF, X, LDX+1 ) -C - IF( LTRANS ) THEN -C - CALL DLACPY( 'Full', N, M, A, LDA, DWORK, N ) - CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N, M, - $ ONE, X, LDX, DWORK, N ) - CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, N, A, LDA, ALPHA, - $ R, LDR ) -C - ELSE -C - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) - CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, N, - $ ONE, X, LDX, DWORK, M ) - CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA, - $ R, LDR ) -C - END IF -C - CALL DSCAL( N, TWO, X, LDX+1 ) -C - RETURN -C *** Last line of MB01RU *** - END diff --git a/slycot/src/MB01RW.f b/slycot/src/MB01RW.f deleted file mode 100644 index 1305d3ed..00000000 --- a/slycot/src/MB01RW.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the transformation of the symmetric matrix A by the -C matrix Z in the form -C -C A := op(Z)*A*op(Z)', -C -C where op(Z) is either Z or its transpose, Z'. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies whether the upper or lower triangle of A -C is stored: -C = 'U': Upper triangle of A is stored; -C = 'L': Lower triangle of A is stored. -C -C TRANS CHARACTER*1 -C Specifies whether op(Z) is Z or its transpose Z': -C = 'N': op(Z) = Z; -C = 'T': op(Z) = Z'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the resulting symmetric matrix op(Z)*A*op(Z)' -C and the number of rows of the matrix Z, if TRANS = 'N', -C or the number of columns of the matrix Z, if TRANS = 'T'. -C M >= 0. -C -C N (input) INTEGER -C The order of the symmetric matrix A and the number of -C columns of the matrix Z, if TRANS = 'N', or the number of -C rows of the matrix Z, if TRANS = 'T'. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,MAX(M,N)) -C On entry, the leading N-by-N upper or lower triangular -C part of this array must contain the upper (UPLO = 'U') -C or lower (UPLO = 'L') triangular part of the symmetric -C matrix A. -C On exit, the leading M-by-M upper or lower triangular -C part of this array contains the upper (UPLO = 'U') or -C lower (UPLO = 'L') triangular part of the symmetric -C matrix op(Z)*A*op(Z)'. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,M,N). -C -C Z (input) DOUBLE PRECISION array, dimension (LDQ,K) -C where K = N if TRANS = 'N' and K = M if TRANS = 'T'. -C The leading M-by-N part, if TRANS = 'N', or N-by-M part, -C if TRANS = 'T', of this array contains the matrix Z. -C -C LDZ INTEGER -C The leading dimension of the array Z. -C LDZ >= MAX(1,M) if TRANS = 'N' and -C LDZ >= MAX(1,N) if TRANS = 'T'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C FURTHER COMMENTS -C -C This is a simpler, BLAS 2 version for MB01RD. -C -C CONTRIBUTOR -C -C A. Varga, DLR, Feb. 1995. -C -C REVISIONS -C -C April 1998 (T. Penzl). -C Sep. 1998 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDZ, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL NOTTRA, UPPER - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements -C - NOTTRA = LSAME( TRANS, 'N' ) - UPPER = LSAME( UPLO, 'U' ) -C - INFO = 0 - IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L') ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOTTRA .OR. LSAME( TRANS, 'T') ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M, N ) ) THEN - INFO = -6 - ELSE IF( ( NOTTRA .AND. LDZ.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.NOTTRA .AND. LDZ.LT.MAX( 1, N ) ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB01RW', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( NOTTRA ) THEN -C -C Compute Z*A*Z'. -C - IF ( UPPER ) THEN -C -C Compute Z*A in A (M-by-N). -C - DO 10 J = 1, N - CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) - CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) - CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(1,J), 1 ) - 10 CONTINUE -C -C Compute A*Z' in the upper triangular part of A. -C - DO 20 I = 1, M - CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) - CALL DGEMV( TRANS, M-I+1, N, ONE, Z(I,1), LDZ, DWORK, 1, - $ ZERO, A(I,I), LDA ) - 20 CONTINUE -C - ELSE -C -C Compute A*Z' in A (N-by-M). -C - DO 30 I = 1, N - CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) - CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) - CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(I,1), LDA ) - 30 CONTINUE -C -C Compute Z*A in the lower triangular part of A. -C - DO 40 J = 1, M - CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) - CALL DGEMV( TRANS, M-J+1, N, ONE, Z(J,1), LDZ, DWORK, 1, - $ ZERO, A(J,J), 1 ) - 40 CONTINUE -C - END IF - ELSE -C -C Compute Z'*A*Z. -C - IF ( UPPER ) THEN -C -C Compute Z'*A in A (M-by-N). -C - DO 50 J = 1, N - CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) - CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) - CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(1,J), 1 ) - 50 CONTINUE -C -C Compute A*Z in the upper triangular part of A. -C - DO 60 I = 1, M - CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) - CALL DGEMV( TRANS, N, M-I+1, ONE, Z(1,I), LDZ, DWORK, 1, - $ ZERO, A(I,I), LDA ) - 60 CONTINUE -C - ELSE -C -C Compute A*Z in A (N-by-M). -C - DO 70 I = 1, N - CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) - CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) - CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, - $ A(I,1), LDA ) - 70 CONTINUE -C -C Compute Z'*A in the lower triangular part of A. -C - DO 80 J = 1, M - CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) - CALL DGEMV( TRANS, N, M-J+1, ONE, Z(1,J), LDZ, DWORK, 1, - $ ZERO, A(J,J), 1 ) - 80 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of MB01RW *** - END diff --git a/slycot/src/MB01RX.f b/slycot/src/MB01RX.f deleted file mode 100644 index 64abe390..00000000 --- a/slycot/src/MB01RX.f +++ /dev/null @@ -1,315 +0,0 @@ - SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, - $ A, LDA, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute either the upper or lower triangular part of one of the -C matrix formulas -C _ -C R = alpha*R + beta*op( A )*B, (1) -C _ -C R = alpha*R + beta*B*op( A ), (2) -C _ -C where alpha and beta are scalars, R and R are m-by-m matrices, -C op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m -C and m-by-n matrices for (2), respectively, and op( A ) is one of -C -C op( A ) = A or op( A ) = A', the transpose of A. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the matrix A appears on the left or -C right in the matrix product as follows: -C _ -C = 'L': R = alpha*R + beta*op( A )*B; -C _ -C = 'R': R = alpha*R + beta*B*op( A ). -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the matrices R and R are -C computed and given, respectively, as follows: -C = 'U': the upper triangular part; -C = 'L': the lower triangular part. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R, the number of rows of -C the matrix op( A ) and the number of columns of the -C matrix B, for SIDE = 'L', or the number of rows of the -C matrix B and the number of columns of the matrix op( A ), -C for SIDE = 'R'. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix B and the number of -C columns of the matrix op( A ), for SIDE = 'L', or the -C number of rows of the matrix op( A ) and the number of -C columns of the matrix B, for SIDE = 'R'. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and B are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the matrix R; the strictly lower -C triangular part of the array is not referenced. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the matrix R; the strictly upper -C triangular part of the array is not referenced. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k), where -C k = N when SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T'; -C k = M when SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T'. -C On entry, if SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T', -C the leading M-by-N part of this array must contain the -C matrix A. -C On entry, if SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T', -C the leading N-by-M part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,l), where -C l = M when SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T'; -C l = N when SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,p), where -C p = M when SIDE = 'L'; -C p = N when SIDE = 'R'. -C On entry, the leading N-by-M part, if SIDE = 'L', or -C M-by-N part, if SIDE = 'R', of this array must contain the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N), if SIDE = 'L'; -C LDB >= MAX(1,M), if SIDE = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is evaluated taking the triangular -C structure into account. BLAS 2 operations are used. A block -C algorithm can be easily constructed; it can use BLAS 3 GEMM -C operations for most computations, and calls of this BLAS 2 -C algorithm for computing the triangles. -C -C FURTHER COMMENTS -C -C The main application of this routine is when the result should -C be a symmetric matrix, e.g., when B = X*op( A )', for (1), or -C B = op( A )'*X, for (2), where B is already available and X = X'. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDB, LDR, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS, LUPLO - INTEGER J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMV, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.1 .OR. - $ ( ( ( LSIDE .AND. .NOT.LTRANS ) .OR. - $ ( .NOT.LSIDE .AND. LTRANS ) ) .AND. LDA.LT.M ) .OR. - $ ( ( ( LSIDE .AND. LTRANS ) .OR. - $ ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. - $ ( LSIDE .AND. LDB.LT.N ) .OR. - $ ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute the required triangle of (1) or (2) using BLAS 2 -C operations. -C - IF( LSIDE ) THEN - IF( LUPLO ) THEN - IF ( LTRANS ) THEN - DO 10 J = 1, M - CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1, - $ ALPHA, R(1,J), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, M - CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1, - $ ALPHA, R(1,J), 1 ) - 20 CONTINUE - END IF - ELSE - IF ( LTRANS ) THEN - DO 30 J = 1, M - CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA, - $ B(1,J), 1, ALPHA, R(J,J), 1 ) - 30 CONTINUE - ELSE - DO 40 J = 1, M - CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA, - $ B(1,J), 1, ALPHA, R(J,J), 1 ) - 40 CONTINUE - END IF - END IF -C - ELSE - IF( LUPLO ) THEN - IF( LTRANS ) THEN - DO 50 J = 1, M - CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1), - $ LDA, ALPHA, R(1,J), 1 ) - 50 CONTINUE - ELSE - DO 60 J = 1, M - CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J), - $ 1, ALPHA, R(1,J), 1 ) - 60 CONTINUE - END IF - ELSE - IF( LTRANS ) THEN - DO 70 J = 1, M - CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), - $ LDB, A(J,1), LDA, ALPHA, R(J,J), 1 ) - 70 CONTINUE - ELSE - DO 80 J = 1, M - CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), - $ LDB, A(1,J), 1, ALPHA, R(J,J), 1 ) - 80 CONTINUE - END IF - END IF - END IF -C - RETURN -C *** Last line of MB01RX *** - END diff --git a/slycot/src/MB01RY.f b/slycot/src/MB01RY.f deleted file mode 100644 index af32cfe6..00000000 --- a/slycot/src/MB01RY.f +++ /dev/null @@ -1,429 +0,0 @@ - SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, - $ LDH, B, LDB, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute either the upper or lower triangular part of one of the -C matrix formulas -C _ -C R = alpha*R + beta*op( H )*B, (1) -C _ -C R = alpha*R + beta*B*op( H ), (2) -C _ -C where alpha and beta are scalars, H, B, R, and R are m-by-m -C matrices, H is an upper Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C _ -C = 'L': R = alpha*R + beta*op( H )*B; -C _ -C = 'R': R = alpha*R + beta*B*op( H ). -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the matrices R and R are -C computed and given, respectively, as follows: -C = 'U': the upper triangular part; -C = 'L': the lower triangular part. -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R, R, H and B. M >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then H and B are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the matrix R; the strictly lower -C triangular part of the array is not referenced. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the matrix R; the strictly upper -C triangular part of the array is not referenced. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,M) -C On entry, the leading M-by-M upper Hessenberg part of -C this array must contain the upper Hessenberg part of the -C matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= M, if beta <> 0 and SIDE = 'L'; -C LDWORK >= 0, if beta = 0 or SIDE = 'R'. -C This array is not referenced when beta = 0 or SIDE = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the -C Hessenberg/triangular structure into account. BLAS 2 operations -C are used. A block algorithm can be constructed; it can use BLAS 3 -C GEMM operations for most computations, and calls of this BLAS 2 -C algorithm for computing the triangles. -C -C FURTHER COMMENTS -C -C The main application of this routine is when the result should -C be a symmetric matrix, e.g., when B = X*op( H )', for (1), or -C B = op( H )'*X, for (2), where B is already available and X = X'. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDB, LDH, LDR, M - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS, LUPLO - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP, - $ DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDH.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute the required triangle of (1) or (2) using BLAS 2 -C operations. -C - IF( LSIDE ) THEN -C -C To avoid repeated references to the subdiagonal elements of H, -C these are swapped with the corresponding elements of H in the -C first column, and are finally restored. -C - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - IF( LUPLO ) THEN - IF ( LTRANS ) THEN -C - DO 20 J = 1, M -C -C Multiply the transposed upper triangle of the leading -C j-by-j submatrix of H by the leading part of the j-th -C column of B. -C - CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, - $ DWORK, 1 ) -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 10 I = 1, MIN( J, M - 1 ) - R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + - $ H( I+1, 1 )*B( I+1, J ) ) - 10 CONTINUE -C - 20 CONTINUE -C - R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M ) -C - ELSE -C - DO 40 J = 1, M -C -C Multiply the upper triangle of the leading j-by-j -C submatrix of H by the leading part of the j-th column -C of B. -C - CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, - $ DWORK, 1 ) - IF( J.LT.M ) THEN -C -C Multiply the remaining right part of the leading -C j-by-M submatrix of H by the trailing part of the -C j-th column of B. -C - CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH, - $ B( J+1, J ), 1, ALPHA, R( 1, J ), 1 ) - ELSE - CALL DSCAL( M, ALPHA, R( 1, M ), 1 ) - END IF -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 ) -C - DO 30 I = 2, J - R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + - $ H( I, 1 )*B( I-1, J ) ) - 30 CONTINUE -C - 40 CONTINUE -C - END IF -C - ELSE -C - IF ( LTRANS ) THEN -C - DO 60 J = M, 1, -1 -C -C Multiply the transposed upper triangle of the trailing -C (M-j+1)-by-(M-j+1) submatrix of H by the trailing part -C of the j-th column of B. -C - CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, - $ H( J, J ), LDH, DWORK( J ), 1 ) - IF( J.GT.1 ) THEN -C -C Multiply the remaining left part of the trailing -C (M-j+1)-by-(j-1) submatrix of H' by the leading -C part of the j-th column of B. -C - CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ), - $ LDH, B( 1, J ), 1, ALPHA, R( J, J ), - $ 1 ) - ELSE - CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 ) - END IF -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 50 I = J, M - 1 - R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + - $ H( I+1, 1 )*B( I+1, J ) ) - 50 CONTINUE -C - R( M, J ) = R( M, J ) + BETA*DWORK( M ) - 60 CONTINUE -C - ELSE -C - DO 80 J = M, 1, -1 -C -C Multiply the upper triangle of the trailing -C (M-j+1)-by-(M-j+1) submatrix of H by the trailing -C part of the j-th column of B. -C - CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, - $ H( J, J ), LDH, DWORK( J ), 1 ) -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 70 I = MAX( J, 2 ), M - R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) - $ + H( I, 1 )*B( I-1, J ) ) - 70 CONTINUE -C - 80 CONTINUE -C - R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 ) -C - END IF - END IF -C - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C -C Row-wise calculations are used for H, if SIDE = 'R' and -C TRANS = 'T'. -C - IF( LUPLO ) THEN - IF( LTRANS ) THEN - R( 1, 1 ) = ALPHA*R( 1, 1 ) + - $ BETA*DDOT( M, B, LDB, H, LDH ) -C - DO 90 J = 2, M - CALL DGEMV( 'NoTranspose', J, M-J+2, BETA, - $ B( 1, J-1 ), LDB, H( J, J-1 ), LDH, - $ ALPHA, R( 1, J ), 1 ) - 90 CONTINUE -C - ELSE -C - DO 100 J = 1, M - 1 - CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB, - $ H( 1, J ), 1, ALPHA, R( 1, J ), 1 ) - 100 CONTINUE -C - CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, - $ H( 1, M ), 1, ALPHA, R( 1, M ), 1 ) -C - END IF -C - ELSE -C - IF( LTRANS ) THEN -C - CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH, - $ ALPHA, R( 1, 1 ), 1 ) -C - DO 110 J = 2, M - CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA, - $ B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA, - $ R( J, J ), 1 ) - 110 CONTINUE -C - ELSE -C - DO 120 J = 1, M - 1 - CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA, - $ B( J, 1 ), LDB, H( 1, J ), 1, ALPHA, - $ R( J, J ), 1 ) - 120 CONTINUE -C - R( M, M ) = ALPHA*R( M, M ) + - $ BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 ) -C - END IF - END IF - END IF -C - RETURN -C *** Last line of MB01RY *** - END diff --git a/slycot/src/MB01SD.f b/slycot/src/MB01SD.f deleted file mode 100644 index b2943737..00000000 --- a/slycot/src/MB01SD.f +++ /dev/null @@ -1,123 +0,0 @@ - SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To scale a general M-by-N matrix A using the row and column -C scaling factors in the vectors R and C. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBS CHARACTER*1 -C Specifies the scaling operation to be done, as follows: -C = 'R': row scaling, i.e., A will be premultiplied -C by diag(R); -C = 'C': column scaling, i.e., A will be postmultiplied -C by diag(C); -C = 'B': both row and column scaling, i.e., A will be -C replaced by diag(R) * A * diag(C). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the M-by-N matrix A. -C On exit, the scaled matrix. See JOBS for the form of the -C scaled matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C R (input) DOUBLE PRECISION array, dimension (M) -C The row scale factors for A. -C R is not referenced if JOBS = 'C'. -C -C C (input) DOUBLE PRECISION array, dimension (N) -C The column scale factors for A. -C C is not referenced if JOBS = 'R'. -C -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, April 1998. -C Based on the RASP routine DMSCAL. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER JOBS - INTEGER LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), C(*), R(*) -C .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION CJ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. Executable Statements .. -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C - IF( LSAME( JOBS, 'C' ) ) THEN -C -C Column scaling, no row scaling. -C - DO 20 J = 1, N - CJ = C(J) - DO 10 I = 1, M - A(I,J) = CJ*A(I,J) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( JOBS, 'R' ) ) THEN -C -C Row scaling, no column scaling. -C - DO 40 J = 1, N - DO 30 I = 1, M - A(I,J) = R(I)*A(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE IF( LSAME( JOBS, 'B' ) ) THEN -C -C Row and column scaling. -C - DO 60 J = 1, N - CJ = C(J) - DO 50 I = 1, M - A(I,J) = CJ*R(I)*A(I,J) - 50 CONTINUE - 60 CONTINUE - END IF -C - RETURN -C *** Last line of MB01SD *** - END diff --git a/slycot/src/MB01TD.f b/slycot/src/MB01TD.f deleted file mode 100644 index d4e06e62..00000000 --- a/slycot/src/MB01TD.f +++ /dev/null @@ -1,173 +0,0 @@ - SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product A * B, where A and B are upper -C quasi-triangular matrices (that is, block upper triangular with -C 1-by-1 or 2-by-2 diagonal blocks) with the same structure. -C The result is returned in the array B. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix A. The elements below the -C subdiagonal are not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix B, with the same -C structure as matrix A. -C On exit, the leading N-by-N part of this array contains -C the computed product A * B, with the same structure as -C on entry. -C The elements below the subdiagonal are not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N-1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrices A and B have not the same structure, -C and/or A and B are not upper quasi-triangular. -C -C METHOD -C -C The matrix product A * B is computed column by column, using -C BLAS 2 and BLAS 1 operations. -C -C FURTHER COMMENTS -C -C This routine can be used, for instance, for computing powers of -C a real Schur form matrix. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C V. Sima, Feb. 2000. -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) -C .. Local Scalars .. - INTEGER I, J, JMIN, JMNM -C .. External Subroutines .. - EXTERNAL DAXPY, DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01TD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( N.EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.1 ) THEN - B(1,1) = A(1,1)*B(1,1) - RETURN - END IF -C -C Test the upper quasi-triangular structure of A and B for identity. -C - DO 10 I = 1, N - 1 - IF ( A(I+1,I).EQ.ZERO ) THEN - IF ( B(I+1,I).NE.ZERO ) THEN - INFO = 1 - RETURN - END IF - ELSE IF ( I.LT.N-1 ) THEN - IF ( A(I+2,I+1).NE.ZERO ) THEN - INFO = 1 - RETURN - END IF - END IF - 10 CONTINUE -C - DO 30 J = 1, N - JMIN = MIN( J+1, N ) - JMNM = MIN( JMIN, N-1 ) -C -C Compute the contribution of the subdiagonal of A to the -C j-th column of the product. -C - DO 20 I = 1, JMNM - DWORK(I) = A(I+1,I)*B(I,J) - 20 CONTINUE -C -C Multiply the upper triangle of A by the j-th column of B, -C and add to the above result. -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA, - $ B(1,J), 1 ) - CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 ) - 30 CONTINUE -C - RETURN -C *** Last line of MB01TD *** - END diff --git a/slycot/src/MB01UD.f b/slycot/src/MB01UD.f deleted file mode 100644 index 0bdacadf..00000000 --- a/slycot/src/MB01UD.f +++ /dev/null @@ -1,238 +0,0 @@ - SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, - $ LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one of the matrix products -C -C B = alpha*op( H ) * A, or B = alpha*A * op( H ), -C -C where alpha is a scalar, A and B are m-by-n matrices, H is an -C upper Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C = 'L': B = alpha*op( H ) * A; -C = 'R': B = alpha*A * op( H ). -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices A and B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then H is not -C referenced and A need not be set before entry. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with SIDE = 'L', the leading M-by-M upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C On entry with SIDE = 'R', the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C computed product. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The required matrix product is computed in two steps. In the first -C step, the upper triangle of H is used; in the second step, the -C contribution of the subdiagonal is added. A fast BLAS 3 DTRMM -C operation is used in the first step. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, LDA, LDB, LDH, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), H(LDH,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. - $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) - $ RETURN -C - IF( ALPHA.EQ.ZERO ) THEN -C -C Set B to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) - RETURN - END IF -C -C Copy A in B and compute one of the matrix products -C B = alpha*op( triu( H ) ) * A, or -C B = alpha*A * op( triu( H ) ), -C involving the upper triangle of H. -C - CALL DLACPY( 'Full', M, N, A, LDA, B, LDB ) - CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, - $ LDH, B, LDB ) -C -C Add the contribution of the subdiagonal of H. -C If SIDE = 'L', the subdiagonal of H is swapped with the -C corresponding elements in the first column of H, and the -C calculations are organized for column operations. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 20 J = 1, N - DO 10 I = 1, M - 1 - B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 2, M - B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J ) - 30 CONTINUE - 40 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C - IF( LTRANS ) THEN - DO 50 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1, - $ B( 1, J+1 ), 1 ) - 50 CONTINUE - ELSE - DO 60 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1, - $ B( 1, J ), 1 ) - 60 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of MB01UD *** - END diff --git a/slycot/src/MB01UW.f b/slycot/src/MB01UW.f deleted file mode 100644 index ff848963..00000000 --- a/slycot/src/MB01UW.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one of the matrix products -C -C A : = alpha*op( H ) * A, or A : = alpha*A * op( H ), -C -C where alpha is a scalar, A is an m-by-n matrix, H is an upper -C Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C = 'L': A := alpha*op( H ) * A; -C = 'R': A := alpha*A * op( H ). -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then H is not -C referenced and A need not be set before entry. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with SIDE = 'L', the leading M-by-M upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C On entry with SIDE = 'R', the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix A. -C On exit, the leading M-by-N part of this array contains -C the computed product. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0, -C DWORK contains a copy of the matrix A, having the leading -C dimension M. -C This array is not referenced when alpha = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= 0, if alpha = 0 or MIN(M,N) = 0; -C LDWORK >= M-1, if SIDE = 'L'; -C LDWORK >= N-1, if SIDE = 'R'. -C For maximal efficiency LDWORK should be at least M*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The required matrix product is computed in two steps. In the first -C step, the upper triangle of H is used; in the second step, the -C contribution of the subdiagonal is added. If the workspace can -C accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in -C the first step. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, LDA, LDH, LDWORK, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), H(LDH,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS - INTEGER I, J, JW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, - $ DTRMM, DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. - $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDWORK.LT.0 .OR. - $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. - $ ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR. - $ ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UW', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) THEN - RETURN - ELSE IF ( LSIDE ) THEN - IF ( M.EQ.1 ) THEN - CALL DSCAL( N, ALPHA*H(1,1), A, LDA ) - RETURN - END IF - ELSE - IF ( N.EQ.1 ) THEN - CALL DSCAL( M, ALPHA*H(1,1), A, 1 ) - RETURN - END IF - END IF -C - IF( ALPHA.EQ.ZERO ) THEN -C -C Set A to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) - RETURN - END IF -C - IF( LDWORK.GE.M*N ) THEN -C -C Enough workspace for a fast BLAS 3 calculation. -C Save A in the workspace and compute one of the matrix products -C A : = alpha*op( triu( H ) ) * A, or -C A : = alpha*A * op( triu( H ) ), -C involving the upper triangle of H. -C - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) - CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, - $ LDH, A, LDA ) -C -C Add the contribution of the subdiagonal of H. -C If SIDE = 'L', the subdiagonal of H is swapped with the -C corresponding elements in the first column of H, and the -C calculations are organized for column operations. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - JW = 1 - DO 20 J = 1, N - JW = JW + 1 - DO 10 I = 1, M - 1 - A( I, J ) = A( I, J ) + - $ ALPHA*H( I+1, 1 )*DWORK( JW ) - JW = JW + 1 - 10 CONTINUE - 20 CONTINUE - ELSE - JW = 0 - DO 40 J = 1, N - JW = JW + 1 - DO 30 I = 2, M - A( I, J ) = A( I, J ) + - $ ALPHA*H( I, 1 )*DWORK( JW ) - JW = JW + 1 - 30 CONTINUE - 40 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C - IF( LTRANS ) THEN - JW = 1 - DO 50 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, - $ A( 1, J+1 ), 1 ) - JW = JW + M - 50 CONTINUE - ELSE - JW = M + 1 - DO 60 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, - $ A( 1, J ), 1 ) - JW = JW + M - 60 CONTINUE - END IF - END IF -C - ELSE -C -C Use a BLAS 2 calculation. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 80 J = 1, N -C -C Compute the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 70 I = 1, M - 1 - DWORK( I ) = H( I+1, 1 )*A( I+1, J ) - 70 CONTINUE -C -C Multiply the upper triangle of H by the j-th column -C of A, and add to the above result. -C - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, - $ A( 1, J ), 1 ) - CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 ) - 80 CONTINUE -C - ELSE - DO 100 J = 1, N -C -C Compute the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 90 I = 1, M - 1 - DWORK( I ) = H( I+1, 1 )*A( I, J ) - 90 CONTINUE -C -C Multiply the upper triangle of H by the j-th column -C of A, and add to the above result. -C - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, - $ A( 1, J ), 1 ) - CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 ) - 100 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C -C Below, row-wise calculations are used for A. -C - IF( N.GT.2 ) - $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 120 I = 1, M -C -C Compute the contribution of the subdiagonal of H to -C the i-th row of the product. -C - DO 110 J = 1, N - 1 - DWORK( J ) = A( I, J )*H( J+1, 1 ) - 110 CONTINUE -C -C Multiply the i-th row of A by the upper triangle of H, -C and add to the above result. -C - CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H, - $ LDH, A( I, 1 ), LDA ) - CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA ) - 120 CONTINUE -C - ELSE - DO 140 I = 1, M -C -C Compute the contribution of the subdiagonal of H to -C the i-th row of the product. -C - DO 130 J = 1, N - 1 - DWORK( J ) = A( I, J+1 )*H( J+1, 1 ) - 130 CONTINUE -C -C Multiply the i-th row of A by the upper triangle of H, -C and add to the above result. -C - CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H, - $ LDH, A( I, 1 ), LDA ) - CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA ) - 140 CONTINUE - END IF - IF( N.GT.2 ) - $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - END IF -C -C Scale the result by alpha. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, - $ INFO ) - END IF - RETURN -C *** Last line of MB01UW *** - END diff --git a/slycot/src/MB01UX.f b/slycot/src/MB01UX.f deleted file mode 100644 index 166c23c4..00000000 --- a/slycot/src/MB01UX.f +++ /dev/null @@ -1,373 +0,0 @@ - SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute one of the matrix products -C -C A : = alpha*op( T ) * A, or A : = alpha*A * op( T ), -C -C where alpha is a scalar, A is an m-by-n matrix, T is a quasi- -C triangular matrix, and op( T ) is one of -C -C op( T ) = T or op( T ) = T', the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the upper quasi-triangular matrix H -C appears on the left or right in the matrix product as -C follows: -C = 'L': A := alpha*op( T ) * A; -C = 'R': A := alpha*A * op( T ). -C -C UPLO CHARACTER*1. -C Specifies whether the matrix T is an upper or lower -C quasi-triangular matrix as follows: -C = 'U': T is an upper quasi-triangular matrix; -C = 'L': T is a lower quasi-triangular matrix. -C -C TRANS CHARACTER*1 -C Specifies the form of op( T ) to be used in the matrix -C multiplication as follows: -C = 'N': op( T ) = T; -C = 'T': op( T ) = T'; -C = 'C': op( T ) = T'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then T is not -C referenced and A need not be set before entry. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with UPLO = 'U', the leading k-by-k upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T. The elements below the -C subdiagonal are not referenced. -C On entry with UPLO = 'L', the leading k-by-k lower -C Hessenberg part of this array must contain the lower -C quasi-triangular matrix T. The elements above the -C supdiagonal are not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix A. -C On exit, the leading M-by-N part of this array contains -C the computed product. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 and ALPHA<>0, DWORK(1) returns the -C optimal value of LDWORK. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C This array is not referenced when alpha = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= 1, if alpha = 0 or MIN(M,N) = 0; -C LDWORK >= 2*(M-1), if SIDE = 'L'; -C LDWORK >= 2*(N-1), if SIDE = 'R'. -C For maximal efficiency LDWORK should be at least -C NOFF*N + M - 1, if SIDE = 'L'; -C NOFF*M + N - 1, if SIDE = 'R'; -C where NOFF is the number of nonzero elements on the -C subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L') -C of T. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The technique used in this routine is similiar to the technique -C used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima. -C The required matrix product is computed in two steps. In the first -C step, the triangle of T specified by UPLO is used; in the second -C step, the contribution of the sub-/supdiagonal is added. If the -C workspace can accommodate parts of A, a fast BLAS 3 DTRMM -C operation is used in the first step. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and -C Varga, A. -C SLICOT - A subroutine library in systems and control theory. -C In: Applied and computational control, signals, and circuits, -C Vol. 1, pp. 499-539, Birkhauser, Boston, 1999. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTRQML). -C -C KEYWORDS -C -C Elementary matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDT, LDWORK, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), T(LDT,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRAN, LUP - CHARACTER ATRAN - INTEGER I, IERR, J, K, NOFF, PDW, PSAV, WRKMIN, WRKOPT, - $ XDIF - DOUBLE PRECISION TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DTRMM, DTRMV, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode and test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUP = LSAME( UPLO, 'U' ) - LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - IF ( LSIDE ) THEN - K = M - ELSE - K = N - END IF - WRKMIN = 2*( K - 1 ) -C - IF ( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( ( .NOT.LUP ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSE IF ( ( .NOT.LTRAN ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDT.LT.MAX( 1, K ) ) THEN - INFO = -8 - ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF ( LDWORK.LT.0 .OR. - $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. - $ LDWORK.LT.WRKMIN ) ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UX', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN -C -C Set A to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) - RETURN - END IF -C -C Save and count off-diagonal entries of T. -C - IF ( LUP ) THEN - CALL DCOPY( K-1, T(2,1), LDT+1, DWORK, 1 ) - ELSE - CALL DCOPY( K-1, T(1,2), LDT+1, DWORK, 1 ) - END IF - NOFF = 0 - DO 5 I = 1, K-1 - IF ( DWORK(I).NE.ZERO ) - $ NOFF = NOFF + 1 - 5 CONTINUE -C -C Compute optimal workspace. -C - IF ( LSIDE ) THEN - WRKOPT = NOFF*N + M - 1 - ELSE - WRKOPT = NOFF*M + N - 1 - END IF - PSAV = K - IF ( .NOT.LTRAN ) THEN - XDIF = 0 - ELSE - XDIF = 1 - END IF - IF ( .NOT.LUP ) - $ XDIF = 1 - XDIF - IF ( .NOT.LSIDE ) - $ XDIF = 1 - XDIF -C - IF ( LDWORK.GE.WRKOPT ) THEN -C -C Enough workspace for a fast BLAS 3 calculation. -C Save relevant parts of A in the workspace and compute one of -C the matrix products -C A : = alpha*op( triu( T ) ) * A, or -C A : = alpha*A * op( triu( T ) ), -C involving the upper/lower triangle of T. -C - PDW = PSAV - IF ( LSIDE ) THEN - DO 20 J = 1, N - DO 10 I = 1, M-1 - IF ( DWORK(I).NE.ZERO ) THEN - DWORK(PDW) = A(I+XDIF,J) - PDW = PDW + 1 - END IF - 10 CONTINUE - 20 CONTINUE - ELSE - DO 30 J = 1, N-1 - IF ( DWORK(J).NE.ZERO ) THEN - CALL DCOPY( M, A(1,J+XDIF), 1, DWORK(PDW), 1 ) - PDW = PDW + M - END IF - 30 CONTINUE - END IF - CALL DTRMM( SIDE, UPLO, TRANS, 'Non-unit', M, N, ALPHA, T, - $ LDT, A, LDA ) -C -C Add the contribution of the offdiagonal of T. -C - PDW = PSAV - XDIF = 1 - XDIF - IF( LSIDE ) THEN - DO 50 J = 1, N - DO 40 I = 1, M-1 - TEMP = DWORK(I) - IF ( TEMP.NE.ZERO ) THEN - A(I+XDIF,J) = A(I+XDIF,J) + ALPHA * TEMP * - $ DWORK(PDW) - PDW = PDW + 1 - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 60 J = 1, N-1 - TEMP = DWORK(J)*ALPHA - IF ( TEMP.NE.ZERO ) THEN - CALL DAXPY( M, TEMP, DWORK(PDW), 1, A(1,J+XDIF), 1 ) - PDW = PDW + M - END IF - 60 CONTINUE - END IF - ELSE -C -C Use a BLAS 2 calculation. -C - IF ( LSIDE ) THEN - DO 80 J = 1, N -C -C Compute the contribution of the offdiagonal of T to -C the j-th column of the product. -C - DO 70 I = 1, M - 1 - DWORK(PSAV+I-1) = DWORK(I)*A(I+XDIF,J) - 70 CONTINUE -C -C Multiply the triangle of T by the j-th column of A, -C and add to the above result. -C - CALL DTRMV( UPLO, TRANS, 'Non-unit', M, T, LDT, A(1,J), - $ 1 ) - CALL DAXPY( M-1, ONE, DWORK(PSAV), 1, A(2-XDIF,J), 1 ) - 80 CONTINUE - ELSE - IF ( LTRAN ) THEN - ATRAN = 'N' - ELSE - ATRAN = 'T' - END IF - DO 100 I = 1, M -C -C Compute the contribution of the offdiagonal of T to -C the i-th row of the product. -C - DO 90 J = 1, N - 1 - DWORK(PSAV+J-1) = A(I,J+XDIF)*DWORK(J) - 90 CONTINUE -C -C Multiply the i-th row of A by the triangle of T, -C and add to the above result. -C - CALL DTRMV( UPLO, ATRAN, 'Non-unit', N, T, LDT, A(I,1), - $ LDA ) - CALL DAXPY( N-1, ONE, DWORK(PSAV), 1, A(I,2-XDIF), LDA ) - 100 CONTINUE - END IF -C -C Scale the result by alpha. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, - $ IERR ) - END IF - DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) - RETURN -C *** Last line of MB01UX *** - END diff --git a/slycot/src/MB01VD.f b/slycot/src/MB01VD.f deleted file mode 100644 index bcd924d6..00000000 --- a/slycot/src/MB01VD.f +++ /dev/null @@ -1,1693 +0,0 @@ - SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA, - $ A, LDA, B, LDB, C, LDC, MC, NC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the following matrix operation -C -C C = alpha*kron( op(A), op(B) ) + beta*C, -C -C where alpha and beta are real scalars, op(M) is either matrix M or -C its transpose, M', and kron( X, Y ) denotes the Kronecker product -C of the matrices X and Y. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used as follows: -C = 'N': op(A) = A; -C = 'T': op(A) = A'; -C = 'C': op(A) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op(B) to be used as follows: -C = 'N': op(B) = B; -C = 'T': op(B) = B'; -C = 'C': op(B) = B'. -C -C Input/Output Parameters -C -C MA (input) INTEGER -C The number of rows of the matrix op(A). MA >= 0. -C -C NA (input) INTEGER -C The number of columns of the matrix op(A). NA >= 0. -C -C MB (input) INTEGER -C The number of rows of the matrix op(B). MB >= 0. -C -C NB (input) INTEGER -C The number of columns of the matrix op(B). NB >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then A and B need not -C be set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then C need not be -C set before entry. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,ka), -C where ka is NA when TRANA = 'N', and is MA otherwise. -C If TRANA = 'N', the leading MA-by-NA part of this array -C must contain the matrix A; otherwise, the leading NA-by-MA -C part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,MA), if TRANA = 'N'; -C LDA >= max(1,NA), if TRANA = 'T' or 'C'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,kb) -C where kb is NB when TRANB = 'N', and is MB otherwise. -C If TRANB = 'N', the leading MB-by-NB part of this array -C must contain the matrix B; otherwise, the leading NB-by-MB -C part of this array must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= max(1,MB), if TRANB = 'N'; -C LDB >= max(1,NB), if TRANB = 'T' or 'C'. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) -C On entry, if beta is nonzero, the leading MC-by-NC part of -C this array must contain the given matric C, where -C MC = MA*MB and NC = NA*NB. -C On exit, the leading MC-by-NC part of this array contains -C the computed matrix expression -C C = alpha*kron( op(A), op(B) ) + beta*C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= max(1,MC). -C -C MC (output) INTEGER -C The number of rows of the matrix C. MC = MA*MB. -C -C NC (output) INTEGER -C The number of columns of the matrix C. NC = NA*NB. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Kronecker product of the matrices op(A) and op(B) is computed -C column by column. -C -C FURTHER COMMENTS -C -C The multiplications by zero elements in A are avoided, if the -C matrix A is considered to be sparse, i.e., if -C (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes -C NB+1 passes through the matrix A, and MA*NA passes through the -C matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or -C op(B) = B', it could be more efficient to transpose A and/or B -C before calling this routine, and use the 'N' values for TRANA -C and/or TRANB. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION SPARST - PARAMETER ( SPARST = 0.8D0 ) -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) -C .. Local Scalars .. - LOGICAL SPARSE, TRANSA, TRANSB - INTEGER I, IC, J, JC, K, L, LC, NZ - DOUBLE PRECISION AIJ -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLASET, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - MC = MA*MB - INFO = 0 - IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( MA.LT.0 ) THEN - INFO = -3 - ELSE IF( NA.LT.0 ) THEN - INFO = -4 - ELSE IF( MB.LT.0 ) THEN - INFO = -5 - ELSE IF( NB.LT.0 ) THEN - INFO = -6 - ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR. - $ ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN - INFO = -10 - ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR. - $ ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01VD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - NC = NA*NB - IF ( MC.EQ.0 .OR. NC.EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN - IF ( BETA.EQ.ZERO ) THEN - CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC ) - ELSE IF ( BETA.NE.ONE ) THEN -C - DO 10 J = 1, NC - CALL DSCAL( MC, BETA, C(1,J), 1 ) - 10 CONTINUE -C - END IF - RETURN - END IF -C - DUM(1) = ZERO - JC = 1 - NZ = 0 -C -C Compute the Kronecker product of the matrices op(A) and op(B), -C C = alpha*kron( op(A), op(B) ) + beta*C. -C First, check if A is sparse. Here, A is considered as being sparse -C if (number of zeros in A)/(MA*NA) >= SPARST. -C - DO 30 J = 1, NA -C - DO 20 I = 1, MA - IF ( TRANSA ) THEN - IF ( A(J,I).EQ.ZERO ) - $ NZ = NZ + 1 - ELSE - IF ( A(I,J).EQ.ZERO ) - $ NZ = NZ + 1 - END IF - 20 CONTINUE -C - 30 CONTINUE -C - SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST -C - IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN -C -C Case op(A) = A and op(B) = B. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 80 J = 1, NA -C - DO 70 K = 1, NB - IC = 1 -C - DO 60 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 50 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 50 CONTINUE -C - END IF - IC = IC + MB - 60 CONTINUE -C - JC = JC + 1 - 70 CONTINUE -C - 80 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 120 J = 1, NA -C - DO 110 K = 1, NB - IC = 1 -C - DO 100 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 90 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 90 CONTINUE -C - IC = IC + MB - 100 CONTINUE -C - JC = JC + 1 - 110 CONTINUE -C - 120 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 160 J = 1, NA -C - DO 150 K = 1, NB - IC = 1 -C - DO 140 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 130 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 130 CONTINUE -C - END IF - IC = IC + MB - 140 CONTINUE -C - JC = JC + 1 - 150 CONTINUE -C - 160 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 200 J = 1, NA -C - DO 190 K = 1, NB - IC = 1 -C - DO 180 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 170 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 170 CONTINUE -C - IC = IC + MB - 180 CONTINUE -C - JC = JC + 1 - 190 CONTINUE -C - 200 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 240 J = 1, NA -C - DO 230 K = 1, NB - IC = 1 -C - DO 220 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 210 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 210 CONTINUE -C - END IF - IC = IC + MB - 220 CONTINUE -C - JC = JC + 1 - 230 CONTINUE -C - 240 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 280 J = 1, NA -C - DO 270 K = 1, NB - IC = 1 -C - DO 260 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 250 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 250 CONTINUE -C - IC = IC + MB - 260 CONTINUE -C - JC = JC + 1 - 270 CONTINUE -C - 280 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 320 J = 1, NA -C - DO 310 K = 1, NB - IC = 1 -C - DO 300 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 290 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 290 CONTINUE -C - END IF - IC = IC + MB - 300 CONTINUE -C - JC = JC + 1 - 310 CONTINUE -C - 320 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 360 J = 1, NA -C - DO 350 K = 1, NB - IC = 1 -C - DO 340 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 330 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 330 CONTINUE -C - IC = IC + MB - 340 CONTINUE -C - JC = JC + 1 - 350 CONTINUE -C - 360 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 400 J = 1, NA -C - DO 390 K = 1, NB - IC = 1 -C - DO 380 I = 1, MA - AIJ = A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 370 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 370 CONTINUE -C - END IF - IC = IC + MB - 380 CONTINUE -C - JC = JC + 1 - 390 CONTINUE -C - 400 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 440 J = 1, NA -C - DO 430 K = 1, NB - IC = 1 -C - DO 420 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 410 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 410 CONTINUE -C - IC = IC + MB - 420 CONTINUE -C - JC = JC + 1 - 430 CONTINUE -C - 440 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 480 J = 1, NA -C - DO 470 K = 1, NB - IC = 1 -C - DO 460 I = 1, MA - AIJ = ALPHA*A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 450 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 450 CONTINUE -C - END IF - IC = IC + MB - 460 CONTINUE -C - JC = JC + 1 - 470 CONTINUE -C - 480 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 520 J = 1, NA -C - DO 510 K = 1, NB - IC = 1 -C - DO 500 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 490 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 490 CONTINUE -C - IC = IC + MB - 500 CONTINUE -C - JC = JC + 1 - 510 CONTINUE -C - 520 CONTINUE -C - END IF - END IF - END IF - ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN -C -C Case op(A) = A' and op(B) = B. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 560 J = 1, NA -C - DO 550 K = 1, NB - IC = 1 -C - DO 540 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 530 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 530 CONTINUE -C - END IF - IC = IC + MB - 540 CONTINUE -C - JC = JC + 1 - 550 CONTINUE -C - 560 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 600 J = 1, NA -C - DO 590 K = 1, NB - IC = 1 -C - DO 580 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 570 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 570 CONTINUE -C - IC = IC + MB - 580 CONTINUE -C - JC = JC + 1 - 590 CONTINUE -C - 600 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 640 J = 1, NA -C - DO 630 K = 1, NB - IC = 1 -C - DO 620 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 610 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 610 CONTINUE -C - END IF - IC = IC + MB - 620 CONTINUE -C - JC = JC + 1 - 630 CONTINUE -C - 640 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 680 J = 1, NA -C - DO 670 K = 1, NB - IC = 1 -C - DO 660 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 650 L = 1, MB - C(LC,JC) = AIJ*B(L,K) - LC = LC + 1 - 650 CONTINUE -C - IC = IC + MB - 660 CONTINUE -C - JC = JC + 1 - 670 CONTINUE -C - 680 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 720 J = 1, NA -C - DO 710 K = 1, NB - IC = 1 -C - DO 700 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 690 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 690 CONTINUE -C - END IF - IC = IC + MB - 700 CONTINUE -C - JC = JC + 1 - 710 CONTINUE -C - 720 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 760 J = 1, NA -C - DO 750 K = 1, NB - IC = 1 -C - DO 740 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 730 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 730 CONTINUE -C - IC = IC + MB - 740 CONTINUE -C - JC = JC + 1 - 750 CONTINUE -C - 760 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 800 J = 1, NA -C - DO 790 K = 1, NB - IC = 1 -C - DO 780 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 770 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 770 CONTINUE -C - END IF - IC = IC + MB - 780 CONTINUE -C - JC = JC + 1 - 790 CONTINUE -C - 800 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 840 J = 1, NA -C - DO 830 K = 1, NB - IC = 1 -C - DO 820 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 810 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 810 CONTINUE -C - IC = IC + MB - 820 CONTINUE -C - JC = JC + 1 - 830 CONTINUE -C - 840 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 880 J = 1, NA -C - DO 870 K = 1, NB - IC = 1 -C - DO 860 I = 1, MA - AIJ = A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 850 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 850 CONTINUE -C - END IF - IC = IC + MB - 860 CONTINUE -C - JC = JC + 1 - 870 CONTINUE -C - 880 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 920 J = 1, NA -C - DO 910 K = 1, NB - IC = 1 -C - DO 900 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 890 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 890 CONTINUE -C - IC = IC + MB - 900 CONTINUE -C - JC = JC + 1 - 910 CONTINUE -C - 920 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 960 J = 1, NA -C - DO 950 K = 1, NB - IC = 1 -C - DO 940 I = 1, MA - AIJ = ALPHA*A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 930 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 930 CONTINUE -C - END IF - IC = IC + MB - 940 CONTINUE -C - JC = JC + 1 - 950 CONTINUE -C - 960 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 1000 J = 1, NA -C - DO 990 K = 1, NB - IC = 1 -C - DO 980 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 970 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) - LC = LC + 1 - 970 CONTINUE -C - IC = IC + MB - 980 CONTINUE -C - JC = JC + 1 - 990 CONTINUE -C - 1000 CONTINUE -C - END IF - END IF - END IF - ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN -C -C Case op(A) = A and op(B) = B'. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 1080 J = 1, NA -C - DO 1070 K = 1, NB - IC = 1 -C - DO 1060 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1050 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1050 CONTINUE -C - END IF - IC = IC + MB - 1060 CONTINUE -C - JC = JC + 1 - 1070 CONTINUE -C - 1080 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 1120 J = 1, NA -C - DO 1110 K = 1, NB - IC = 1 -C - DO 1100 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 1090 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1090 CONTINUE -C - IC = IC + MB - 1100 CONTINUE -C - JC = JC + 1 - 1110 CONTINUE -C - 1120 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 1160 J = 1, NA -C - DO 1150 K = 1, NB - IC = 1 -C - DO 1140 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1130 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1130 CONTINUE -C - END IF - IC = IC + MB - 1140 CONTINUE -C - JC = JC + 1 - 1150 CONTINUE -C - 1160 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 1200 J = 1, NA -C - DO 1190 K = 1, NB - IC = 1 -C - DO 1180 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 1170 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1170 CONTINUE -C - IC = IC + MB - 1180 CONTINUE -C - JC = JC + 1 - 1190 CONTINUE -C - 1200 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 1240 J = 1, NA -C - DO 1230 K = 1, NB - IC = 1 -C - DO 1220 I = 1, MA - AIJ = A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1210 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1210 CONTINUE -C - END IF - IC = IC + MB - 1220 CONTINUE -C - JC = JC + 1 - 1230 CONTINUE -C - 1240 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 1280 J = 1, NA -C - DO 1270 K = 1, NB - IC = 1 -C - DO 1260 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 1250 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1250 CONTINUE -C - IC = IC + MB - 1260 CONTINUE -C - JC = JC + 1 - 1270 CONTINUE -C - 1280 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 1320 J = 1, NA -C - DO 1310 K = 1, NB - IC = 1 -C - DO 1300 I = 1, MA - AIJ = ALPHA*A(I,J) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1290 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1290 CONTINUE -C - END IF - IC = IC + MB - 1300 CONTINUE -C - JC = JC + 1 - 1310 CONTINUE -C - 1320 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 1360 J = 1, NA -C - DO 1350 K = 1, NB - IC = 1 -C - DO 1340 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 1330 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1330 CONTINUE -C - IC = IC + MB - 1340 CONTINUE -C - JC = JC + 1 - 1350 CONTINUE -C - 1360 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 1400 J = 1, NA -C - DO 1390 K = 1, NB - IC = 1 -C - DO 1380 I = 1, MA - AIJ = A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1370 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1370 CONTINUE -C - END IF - IC = IC + MB - 1380 CONTINUE -C - JC = JC + 1 - 1390 CONTINUE -C - 1400 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 1440 J = 1, NA -C - DO 1430 K = 1, NB - IC = 1 -C - DO 1420 I = 1, MA - AIJ = A(I,J) - LC = IC -C - DO 1410 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1410 CONTINUE -C - IC = IC + MB - 1420 CONTINUE -C - JC = JC + 1 - 1430 CONTINUE -C - 1440 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 1480 J = 1, NA -C - DO 1470 K = 1, NB - IC = 1 -C - DO 1460 I = 1, MA - AIJ = ALPHA*A(I,J) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1450 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1450 CONTINUE -C - END IF - IC = IC + MB - 1460 CONTINUE -C - JC = JC + 1 - 1470 CONTINUE -C - 1480 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 1520 J = 1, NA -C - DO 1510 K = 1, NB - IC = 1 -C - DO 1500 I = 1, MA - AIJ = ALPHA*A(I,J) - LC = IC -C - DO 1490 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1490 CONTINUE -C - IC = IC + MB - 1500 CONTINUE -C - JC = JC + 1 - 1510 CONTINUE -C - 1520 CONTINUE -C - END IF - END IF - END IF - ELSE -C -C Case op(A) = A' and op(B) = B'. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha = 1, A sparse. -C - DO 1580 J = 1, NA -C - DO 1570 K = 1, NB - IC = 1 -C - DO 1560 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE IF ( AIJ.EQ.ONE ) THEN - CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1550 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1550 CONTINUE -C - END IF - IC = IC + MB - 1560 CONTINUE -C - JC = JC + 1 - 1570 CONTINUE -C - 1580 CONTINUE -C - ELSE -C -C Case beta = 0, alpha = 1, A not sparse. -C - DO 1620 J = 1, NA -C - DO 1610 K = 1, NB - IC = 1 -C - DO 1600 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 1590 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1590 CONTINUE -C - IC = IC + MB - 1600 CONTINUE -C - JC = JC + 1 - 1610 CONTINUE -C - 1620 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 0, alpha <> 1, A sparse. -C - DO 1660 J = 1, NA -C - DO 1650 K = 1, NB - IC = 1 -C - DO 1640 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.EQ.ZERO ) THEN - CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1630 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1630 CONTINUE -C - END IF - IC = IC + MB - 1640 CONTINUE -C - JC = JC + 1 - 1650 CONTINUE -C - 1660 CONTINUE -C - ELSE -C -C Case beta = 0, alpha <> 1, A not sparse. -C - DO 1700 J = 1, NA -C - DO 1690 K = 1, NB - IC = 1 -C - DO 1680 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 1670 L = 1, MB - C(LC,JC) = AIJ*B(K,L) - LC = LC + 1 - 1670 CONTINUE -C - IC = IC + MB - 1680 CONTINUE -C - JC = JC + 1 - 1690 CONTINUE -C - 1700 CONTINUE -C - END IF - END IF - ELSE IF ( BETA.EQ.ONE ) THEN - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha = 1, A sparse. -C - DO 1740 J = 1, NA -C - DO 1730 K = 1, NB - IC = 1 -C - DO 1720 I = 1, MA - AIJ = A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1710 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1710 CONTINUE -C - END IF - IC = IC + MB - 1720 CONTINUE -C - JC = JC + 1 - 1730 CONTINUE -C - 1740 CONTINUE -C - ELSE -C -C Case beta = 1, alpha = 1, A not sparse. -C - DO 1780 J = 1, NA -C - DO 1770 K = 1, NB - IC = 1 -C - DO 1760 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 1750 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1750 CONTINUE -C - IC = IC + MB - 1760 CONTINUE -C - JC = JC + 1 - 1770 CONTINUE -C - 1780 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta = 1, alpha <> 1, A sparse. -C - DO 1820 J = 1, NA -C - DO 1810 K = 1, NB - IC = 1 -C - DO 1800 I = 1, MA - AIJ = ALPHA*A(J,I) - IF ( AIJ.NE.ZERO ) THEN - LC = IC -C - DO 1790 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1790 CONTINUE -C - END IF - IC = IC + MB - 1800 CONTINUE -C - JC = JC + 1 - 1810 CONTINUE -C - 1820 CONTINUE -C - ELSE -C -C Case beta = 1, alpha <> 1, A not sparse. -C - DO 1860 J = 1, NA -C - DO 1850 K = 1, NB - IC = 1 -C - DO 1840 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 1830 L = 1, MB - C(LC,JC) = C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1830 CONTINUE -C - IC = IC + MB - 1840 CONTINUE -C - JC = JC + 1 - 1850 CONTINUE -C - 1860 CONTINUE -C - END IF - END IF - ELSE - IF ( ALPHA.EQ.ONE ) THEN - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha = 1, A sparse. -C - DO 1900 J = 1, NA -C - DO 1890 K = 1, NB - IC = 1 -C - DO 1880 I = 1, MA - AIJ = A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1870 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1870 CONTINUE -C - END IF - IC = IC + MB - 1880 CONTINUE -C - JC = JC + 1 - 1890 CONTINUE -C - 1900 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha = 1, A not sparse. -C - DO 1940 J = 1, NA -C - DO 1930 K = 1, NB - IC = 1 -C - DO 1920 I = 1, MA - AIJ = A(J,I) - LC = IC -C - DO 1910 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1910 CONTINUE -C - IC = IC + MB - 1920 CONTINUE -C - JC = JC + 1 - 1930 CONTINUE -C - 1940 CONTINUE -C - END IF - ELSE - IF ( SPARSE ) THEN -C -C Case beta <> 0 or 1, alpha <> 1, A sparse. -C - DO 1980 J = 1, NA -C - DO 1970 K = 1, NB - IC = 1 -C - DO 1960 I = 1, MA - AIJ = ALPHA*A(J,I) -C - IF ( AIJ.EQ.ZERO ) THEN - CALL DSCAL( MB, BETA, C(IC,JC), 1 ) - ELSE - LC = IC -C - DO 1950 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1950 CONTINUE -C - END IF - IC = IC + MB - 1960 CONTINUE -C - JC = JC + 1 - 1970 CONTINUE -C - 1980 CONTINUE -C - ELSE -C -C Case beta <> 0 or 1, alpha <> 1, A not sparse. -C - DO 2020 J = 1, NA -C - DO 2010 K = 1, NB - IC = 1 -C - DO 2000 I = 1, MA - AIJ = ALPHA*A(J,I) - LC = IC -C - DO 1990 L = 1, MB - C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) - LC = LC + 1 - 1990 CONTINUE -C - IC = IC + MB - 2000 CONTINUE -C - JC = JC + 1 - 2010 CONTINUE -C - 2020 CONTINUE -C - END IF - END IF - END IF - END IF - RETURN -C *** Last line of MB01VD *** - END diff --git a/slycot/src/MB01WD.f b/slycot/src/MB01WD.f deleted file mode 100644 index 53c85f9d..00000000 --- a/slycot/src/MB01WD.f +++ /dev/null @@ -1,343 +0,0 @@ - SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R, - $ LDR, A, LDA, T, LDT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) ) -C + beta*R, (1) -C -C if DICO = 'C', or -C _ -C R = alpha*( op( A )'*op( T )'*op( T )*op( A ) - op( T )'*op( T )) -C + beta*R, (2) -C _ -C if DICO = 'D', where alpha and beta are scalars, R, and R are -C symmetric matrices, T is a triangular matrix, A is a general or -C Hessenberg matrix, and op( M ) is one of -C -C op( M ) = M or op( M ) = M'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the formula to be evaluated, as follows: -C = 'C': formula (1), "continuous-time" case; -C = 'D': formula (2), "discrete-time" case. -C -C UPLO CHARACTER*1 -C Specifies which triangles of the symmetric matrix R and -C triangular matrix T are given, as follows: -C = 'U': the upper triangular parts of R and T are given; -C = 'L': the lower triangular parts of R and T are given; -C -C TRANS CHARACTER*1 -C Specifies the form of op( M ) to be used, as follows: -C = 'N': op( M ) = M; -C = 'T': op( M ) = M'; -C = 'C': op( M ) = M'. -C -C HESS CHARACTER*1 -C Specifies the form of the matrix A, as follows: -C = 'F': matrix A is full; -C = 'H': matrix A is Hessenberg (or Schur), either upper -C (if UPLO = 'U'), or lower (if UPLO = 'L'). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices R, A, and T. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then the arrays A -C and T are not referenced. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then the array R need -C not be set before entry. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry with UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R. -C On entry with UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R. -C On exit, the leading N-by-N upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If HESS = 'H' the elements below the -C first subdiagonal, if UPLO = 'U', or above the first -C superdiagonal, if UPLO = 'L', need not be set to zero, -C and are not referenced if DICO = 'D'. -C On exit, the leading N-by-N part of this array contains -C the following matrix product -C alpha*T'*T*A, if TRANS = 'N', or -C alpha*A*T*T', otherwise, -C if DICO = 'C', or -C T*A, if TRANS = 'N', or -C A*T, otherwise, -C if DICO = 'D' (and in this case, these products have a -C Hessenberg form, if HESS = 'H'). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular matrix T and -C the strictly lower triangular part need not be set to zero -C (and it is not referenced). -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular matrix T and -C the strictly upper triangular part need not be set to zero -C (and it is not referenced). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression (1) or (2) is efficiently evaluated taking -C the structure into account. BLAS 3 operations (DTRMM, DSYRK and -C their specializations) are used throughout. -C -C NUMERICAL ASPECTS -C -C If A is a full matrix, the algorithm requires approximately -C 3 -C N operations, if DICO = 'C'; -C 3 -C 7/6 x N operations, if DICO = 'D'. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HESS, TRANS, UPLO - INTEGER INFO, LDA, LDR, LDT, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), R(LDR,*), T(LDT,*) -C .. Local Scalars .. - LOGICAL DISCR, REDUC, TRANSP, UPPER - CHARACTER NEGTRA, SIDE - INTEGER I, INFO2, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLASCL, DLASET, DSYRK, DTRMM, MB01YD, MB01ZD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - UPPER = LSAME( UPLO, 'U' ) - TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - REDUC = LSAME( HESS, 'H' ) -C - IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) )THEN - INFO = -1 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( .NOT.( REDUC .OR. LSAME( HESS, 'F' ) ) )THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN - IF ( BETA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case alpha = 0. -C - IF ( BETA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, R, LDR, INFO2 ) - END IF - RETURN - END IF -C -C General case: alpha <> 0. -C -C Compute (in A) T*A, if TRANS = 'N', or -C A*T, otherwise. -C - IF ( TRANSP ) THEN - SIDE = 'R' - NEGTRA = 'N' - ELSE - SIDE = 'L' - NEGTRA = 'T' - END IF -C - IF ( REDUC .AND. N.GT.2 ) THEN - CALL MB01ZD( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, 1, - $ ONE, T, LDT, A, LDA, INFO2 ) - ELSE - CALL DTRMM( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, ONE, - $ T, LDT, A, LDA ) - END IF -C - IF( .NOT.DISCR ) THEN -C -C Compute (in A) alpha*T'*T*A, if TRANS = 'N', or -C alpha*A*T*T', otherwise. -C - IF ( REDUC .AND. N.GT.2 ) THEN - CALL MB01ZD( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, 1, - $ ALPHA, T, LDT, A, LDA, INFO2 ) - ELSE - CALL DTRMM( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, - $ ALPHA, T, LDT, A, LDA ) - END IF -C -C Compute the required triangle of the result, using symmetry. -C - IF ( UPPER ) THEN - IF ( BETA.EQ.ZERO ) THEN -C - DO 20 J = 1, N - DO 10 I = 1, J - R( I, J ) = A( I, J ) + A( J, I ) - 10 CONTINUE - 20 CONTINUE -C - ELSE -C - DO 40 J = 1, N - DO 30 I = 1, J - R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) - 30 CONTINUE - 40 CONTINUE -C - END IF -C - ELSE -C - IF ( BETA.EQ.ZERO ) THEN -C - DO 60 J = 1, N - DO 50 I = J, N - R( I, J ) = A( I, J ) + A( J, I ) - 50 CONTINUE - 60 CONTINUE -C - ELSE -C - DO 80 J = 1, N - DO 70 I = J, N - R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) - 70 CONTINUE - 80 CONTINUE -C - END IF -C - END IF -C - ELSE -C -C Compute (in R) alpha*A'*T'*T*A + beta*R, if TRANS = 'N', or -C alpha*A*T*T'*A' + beta*R, otherwise. -C - IF ( REDUC .AND. N.GT.2 ) THEN - CALL MB01YD( UPLO, NEGTRA, N, N, 1, ALPHA, BETA, A, LDA, R, - $ LDR, INFO2 ) - ELSE - CALL DSYRK( UPLO, NEGTRA, N, N, ALPHA, A, LDA, BETA, R, - $ LDR ) - END IF -C -C Compute (in R) -alpha*T'*T + R, if TRANS = 'N', or -C -alpha*T*T' + R, otherwise. -C - CALL MB01YD( UPLO, NEGTRA, N, N, 0, -ALPHA, ONE, T, LDT, R, - $ LDR, INFO2 ) -C - END IF -C - RETURN -C *** Last line of MB01WD *** - END diff --git a/slycot/src/MB01XD.f b/slycot/src/MB01XD.f deleted file mode 100644 index 3a54a2e2..00000000 --- a/slycot/src/MB01XD.f +++ /dev/null @@ -1,207 +0,0 @@ - SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product U' * U or L * L', where U and L are -C upper and lower triangular matrices, respectively, stored in the -C corresponding upper or lower triangular part of the array A. -C -C If UPLO = 'U' then the upper triangle of the result is stored, -C overwriting the matrix U in A. -C If UPLO = 'L' then the lower triangle of the result is stored, -C overwriting the matrix L in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangle (U or L) is given in the array A, -C as follows: -C = 'U': the upper triangular part U is given; -C = 'L': the lower triangular part L is given. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the triangular matrices U or L. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular matrix U. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular matrix L. -C On exit, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array contains the upper -C triangular part of the product U' * U. The strictly lower -C triangular part is not referenced. -C On exit, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array contains the lower -C triangular part of the product L * L'. The strictly upper -C triangular part is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product U' * U or L * L' is computed using BLAS 3 -C operations as much as possible (a block algorithm). -C -C FURTHER COMMENTS -C -C This routine is a counterpart of LAPACK Library routine DLAUUM, -C which computes the matrix product U * U' or L' * L. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, II, NB -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DSYRK, DTRMM, MB01XY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01XD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Determine the block size for this environment (as for DLAUUM). -C - NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) -C - IF( NB.LE.1 .OR. NB.GE.N ) THEN -C -C Use unblocked code. -C - CALL MB01XY( UPLO, N, A, LDA, INFO ) - ELSE -C -C Use blocked code. -C - IF( UPPER ) THEN -C -C Compute the product U' * U. -C - DO 10 I = N, 1, -NB - IB = MIN( NB, I ) - II = I - IB + 1 - IF( I.LT.N ) THEN - CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ IB, N-I, ONE, A( II, II ), LDA, - $ A( II, II+IB ), LDA ) - CALL DGEMM( 'Transpose', 'No transpose', IB, N-I, - $ I-IB, ONE, A( 1, II ), LDA, A( 1, II+IB ), - $ LDA, ONE, A( II, II+IB ), LDA ) - END IF - CALL MB01XY( 'Upper', IB, A( II, II ), LDA, INFO ) - CALL DSYRK( 'Upper', 'Transpose', IB, II-1, ONE, - $ A( 1, II ), LDA, ONE, A( II, II ), LDA ) - 10 CONTINUE - ELSE -C -C Compute the product L * L'. -C - DO 20 I = N, 1, -NB - IB = MIN( NB, I ) - II = I - IB + 1 - IF( I.LT.N ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-I, IB, ONE, A( II, II ), LDA, - $ A( II+IB, II ), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I, IB, - $ I-IB, ONE, A( II+IB, 1 ), LDA, A( II, 1 ), - $ LDA, ONE, A( II+IB, II ), LDA ) - END IF - CALL MB01XY( 'Lower', IB, A( II, II ), LDA, INFO ) - CALL DSYRK( 'Lower', 'No Transpose', IB, II-1, ONE, - $ A( II, 1 ), LDA, ONE, A( II, II ), LDA ) - 20 CONTINUE - END IF - END IF -C - RETURN -C -C *** Last line of MB01XD *** - END diff --git a/slycot/src/MB01XY.f b/slycot/src/MB01XY.f deleted file mode 100644 index 6af6275c..00000000 --- a/slycot/src/MB01XY.f +++ /dev/null @@ -1,191 +0,0 @@ - SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product U' * U or L * L', where U and L are -C upper and lower triangular matrices, respectively, stored in the -C corresponding upper or lower triangular part of the array A. -C -C If UPLO = 'U' then the upper triangle of the result is stored, -C overwriting the matrix U in A. -C If UPLO = 'L' then the lower triangle of the result is stored, -C overwriting the matrix L in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangle (U or L) is given in the array A, -C as follows: -C = 'U': the upper triangular part U is given; -C = 'L': the lower triangular part L is given. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the triangular matrices U or L. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular matrix U. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular matrix L. -C On exit, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array contains the upper -C triangular part of the product U' * U. The strictly lower -C triangular part is not referenced. -C On exit, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array contains the lower -C triangular part of the product L * L'. The strictly upper -C triangular part is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product U' * U or L * L' is computed using BLAS 2 and -C BLAS 1 operations (an unblocked algorithm). -C -C FURTHER COMMENTS -C -C This routine is a counterpart of LAPACK Library routine DLAUU2, -C which computes the matrix product U * U' or L' * L. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -C .. -C .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION AII -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01XY', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - IF( UPPER ) THEN -C -C Compute the product U' * U. -C - A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 ) -C - DO 10 I = N-1, 2, -1 - AII = A( I, I ) - A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA, - $ A( 1, I ), 1, AII, A( I, I+1 ), LDA ) - 10 CONTINUE -C - IF( N.GT.1 ) THEN - AII = A( 1, 1 ) - CALL DSCAL( N, AII, A( 1, 1 ), LDA ) - END IF -C - ELSE -C -C Compute the product L * L'. -C - A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA ) -C - DO 20 I = N-1, 2, -1 - AII = A( I, I ) - A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ), - $ LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 ) - 20 CONTINUE -C - IF( N.GT.1 ) THEN - AII = A( 1, 1 ) - CALL DSCAL( N, AII, A( 1, 1 ), 1 ) - END IF - END IF -C - RETURN -C -C *** Last line of MB01XY *** - END diff --git a/slycot/src/MB01YD.f b/slycot/src/MB01YD.f deleted file mode 100644 index 6d5c2a0f..00000000 --- a/slycot/src/MB01YD.f +++ /dev/null @@ -1,352 +0,0 @@ - SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C, - $ LDC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the symmetric rank k operations -C -C C := alpha*op( A )*op( A )' + beta*C, -C -C where alpha and beta are scalars, C is an n-by-n symmetric matrix, -C op( A ) is an n-by-k matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The matrix A has l nonzero codiagonals, either upper or lower. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangle of the symmetric matrix C -C is given and computed, as follows: -C = 'U': the upper triangular part is given/computed; -C = 'L': the lower triangular part is given/computed. -C UPLO also defines the pattern of the matrix A (see below). -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used, as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix C. N >= 0. -C -C K (input) INTEGER -C The number of columns of the matrix op( A ). K >= 0. -C -C L (input) INTEGER -C If UPLO = 'U', matrix A has L nonzero subdiagonals. -C If UPLO = 'L', matrix A has L nonzero superdiagonals. -C MAX(0,NR-1) >= L >= 0, if UPLO = 'U', -C MAX(0,NC-1) >= L >= 0, if UPLO = 'L', -C where NR and NC are the numbers of rows and columns of the -C matrix A, respectively. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then the array A is -C not referenced. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then the array C need -C not be set before entry. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,NC), where -C NC is K when TRANS = 'N', and is N otherwise. -C If TRANS = 'N', the leading N-by-K part of this array must -C contain the matrix A, otherwise the leading K-by-N part of -C this array must contain the matrix A. -C If UPLO = 'U', only the upper triangular part and the -C first L subdiagonals are referenced, and the remaining -C subdiagonals are assumed to be zero. -C If UPLO = 'L', only the lower triangular part and the -C first L superdiagonals are referenced, and the remaining -C superdiagonals are assumed to be zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,NR), -C where NR = N, if TRANS = 'N', and NR = K, otherwise. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix C. -C On entry with UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix C. -C On exit, the leading N-by-N upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C the updated matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The calculations are efficiently performed taking the symmetry -C and structure into account. -C -C FURTHER COMMENTS -C -C The matrix A may have the following patterns, when n = 7, k = 5, -C and l = 2 are used for illustration: -C -C UPLO = 'U', TRANS = 'N' UPLO = 'L', TRANS = 'N' -C -C [ x x x x x ] [ x x x 0 0 ] -C [ x x x x x ] [ x x x x 0 ] -C [ x x x x x ] [ x x x x x ] -C A = [ 0 x x x x ], A = [ x x x x x ], -C [ 0 0 x x x ] [ x x x x x ] -C [ 0 0 0 x x ] [ x x x x x ] -C [ 0 0 0 0 x ] [ x x x x x ] -C -C UPLO = 'U', TRANS = 'T' UPLO = 'L', TRANS = 'T' -C -C [ x x x x x x x ] [ x x x 0 0 0 0 ] -C [ x x x x x x x ] [ x x x x 0 0 0 ] -C A = [ x x x x x x x ], A = [ x x x x x 0 0 ]. -C [ 0 x x x x x x ] [ x x x x x x 0 ] -C [ 0 0 x x x x x ] [ x x x x x x x ] -C -C If N = K, the matrix A is upper or lower triangular, for L = 0, -C and upper or lower Hessenberg, for L = 1. -C -C This routine is a specialization of the BLAS 3 routine DSYRK. -C BLAS 1 calls are used when appropriate, instead of in-line code, -C in order to increase the efficiency. If the matrix A is full, or -C its zero triangle has small order, an optimized DSYRK code could -C be faster than MB01YD. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDC, K, L, N - DOUBLE PRECISION ALPHA, BETA -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -C .. -C .. Local Scalars .. - LOGICAL TRANSP, UPPER - INTEGER I, J, M, NCOLA, NROWA - DOUBLE PRECISION TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DLASCL, DLASET, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( TRANSP )THEN - NROWA = K - NCOLA = N - ELSE - NROWA = N - NCOLA = K - END IF -C - IF( UPPER )THEN - M = NROWA - ELSE - M = NCOLA - END IF -C - IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M-1 ) ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01YD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) THEN - IF ( BETA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, N, N, ZERO, ZERO, C, LDC ) - ELSE -C -C Special case alpha = 0. -C - CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, C, LDC, INFO ) - END IF - RETURN - END IF -C -C General case: alpha <> 0. -C - IF ( .NOT.TRANSP ) THEN -C -C Form C := alpha*A*A' + beta*C. -C - IF ( UPPER ) THEN -C - DO 30 J = 1, N - IF ( BETA.EQ.ZERO ) THEN -C - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE -C - ELSE IF ( BETA.NE.ONE ) THEN - CALL DSCAL ( J, BETA, C( 1, J ), 1 ) - END IF -C - DO 20 M = MAX( 1, J-L ), K - CALL DAXPY ( MIN( J, L+M ), ALPHA*A( J, M ), - $ A( 1, M ), 1, C( 1, J ), 1 ) - 20 CONTINUE -C - 30 CONTINUE -C - ELSE -C - DO 60 J = 1, N - IF ( BETA.EQ.ZERO ) THEN -C - DO 40 I = J, N - C( I, J ) = ZERO - 40 CONTINUE -C - ELSE IF ( BETA.NE.ONE ) THEN - CALL DSCAL ( N-J+1, BETA, C( J, J ), 1 ) - END IF -C - DO 50 M = 1, MIN( J+L, K ) - CALL DAXPY ( N-J+1, ALPHA*A( J, M ), A( J, M ), 1, - $ C( J, J ), 1 ) - 50 CONTINUE -C - 60 CONTINUE -C - END IF -C - ELSE -C -C Form C := alpha*A'*A + beta*C. -C - IF ( UPPER ) THEN -C - DO 80 J = 1, N -C - DO 70 I = 1, J - TEMP = ALPHA*DDOT ( MIN( J+L, K ), A( 1, I ), 1, - $ A( 1, J ), 1 ) - IF ( BETA.EQ.ZERO ) THEN - C( I, J ) = TEMP - ELSE - C( I, J ) = TEMP + BETA*C( I, J ) - END IF - 70 CONTINUE -C - 80 CONTINUE -C - ELSE -C - DO 100 J = 1, N -C - DO 90 I = J, N - M = MAX( 1, I-L ) - TEMP = ALPHA*DDOT ( K-M+1, A( M, I ), 1, A( M, J ), - $ 1 ) - IF ( BETA.EQ.ZERO ) THEN - C( I, J ) = TEMP - ELSE - C( I, J ) = TEMP + BETA*C( I, J ) - END IF - 90 CONTINUE -C - 100 CONTINUE -C - END IF -C - END IF -C - RETURN -C -C *** Last line of MB01YD *** - END diff --git a/slycot/src/MB01ZD.f b/slycot/src/MB01ZD.f deleted file mode 100644 index abdbbf47..00000000 --- a/slycot/src/MB01ZD.f +++ /dev/null @@ -1,475 +0,0 @@ - SUBROUTINE MB01ZD( SIDE, UPLO, TRANST, DIAG, M, N, L, ALPHA, T, - $ LDT, H, LDH, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product -C -C H := alpha*op( T )*H, or H := alpha*H*op( T ), -C -C where alpha is a scalar, H is an m-by-n upper or lower -C Hessenberg-like matrix (with l nonzero subdiagonals or -C superdiagonals, respectively), T is a unit, or non-unit, -C upper or lower triangular matrix, and op( T ) is one of -C -C op( T ) = T or op( T ) = T'. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the triangular matrix T appears on the -C left or right in the matrix product, as follows: -C = 'L': the product alpha*op( T )*H is computed; -C = 'R': the product alpha*H*op( T ) is computed. -C -C UPLO CHARACTER*1 -C Specifies the form of the matrices T and H, as follows: -C = 'U': the matrix T is upper triangular and the matrix H -C is upper Hessenberg-like; -C = 'L': the matrix T is lower triangular and the matrix H -C is lower Hessenberg-like. -C -C TRANST CHARACTER*1 -C Specifies the form of op( T ) to be used, as follows: -C = 'N': op( T ) = T; -C = 'T': op( T ) = T'; -C = 'C': op( T ) = T'. -C -C DIAG CHARACTER*1. -C Specifies whether or not T is unit triangular, as follows: -C = 'U': the matrix T is assumed to be unit triangular; -C = 'N': the matrix T is not assumed to be unit triangular. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of H. M >= 0. -C -C N (input) INTEGER -C The number of columns of H. N >= 0. -C -C L (input) INTEGER -C If UPLO = 'U', matrix H has L nonzero subdiagonals. -C If UPLO = 'L', matrix H has L nonzero superdiagonals. -C MAX(0,M-1) >= L >= 0, if UPLO = 'U'; -C MAX(0,N-1) >= L >= 0, if UPLO = 'L'. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then T is not -C referenced and H need not be set before entry. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,k), where -C k is m when SIDE = 'L' and is n when SIDE = 'R'. -C If UPLO = 'U', the leading k-by-k upper triangular part -C of this array must contain the upper triangular matrix T -C and the strictly lower triangular part is not referenced. -C If UPLO = 'L', the leading k-by-k lower triangular part -C of this array must contain the lower triangular matrix T -C and the strictly upper triangular part is not referenced. -C Note that when DIAG = 'U', the diagonal elements of T are -C not referenced either, but are assumed to be unity. -C -C LDT INTEGER -C The leading dimension of array T. -C LDT >= MAX(1,M), if SIDE = 'L'; -C LDT >= MAX(1,N), if SIDE = 'R'. -C -C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) -C On entry, if UPLO = 'U', the leading M-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg-like matrix H. -C On entry, if UPLO = 'L', the leading M-by-N lower -C Hessenberg part of this array must contain the lower -C Hessenberg-like matrix H. -C On exit, the leading M-by-N part of this array contains -C the matrix product alpha*op( T )*H, if SIDE = 'L', -C or alpha*H*op( T ), if SIDE = 'R'. If TRANST = 'N', this -C product has the same pattern as the given matrix H; -C the elements below the L-th subdiagonal (if UPLO = 'U'), -C or above the L-th superdiagonal (if UPLO = 'L'), are not -C referenced in this case. If TRANST = 'T', the elements -C below the (N+L)-th row (if UPLO = 'U', SIDE = 'R', and -C M > N+L), or at the right of the (M+L)-th column -C (if UPLO = 'L', SIDE = 'L', and N > M+L), are not set to -C zero nor referenced. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The calculations are efficiently performed taking the problem -C structure into account. -C -C FURTHER COMMENTS -C -C The matrix H may have the following patterns, when m = 7, n = 6, -C and l = 2 are used for illustration: -C -C UPLO = 'U' UPLO = 'L' -C -C [ x x x x x x ] [ x x x 0 0 0 ] -C [ x x x x x x ] [ x x x x 0 0 ] -C [ x x x x x x ] [ x x x x x 0 ] -C H = [ 0 x x x x x ], H = [ x x x x x x ]. -C [ 0 0 x x x x ] [ x x x x x x ] -C [ 0 0 0 x x x ] [ x x x x x x ] -C [ 0 0 0 0 x x ] [ x x x x x x ] -C -C The products T*H or H*T have the same pattern as H, but the -C products T'*H or H*T' may be full matrices. -C -C If m = n, the matrix H is upper or lower triangular, for l = 0, -C and upper or lower Hessenberg, for l = 1. -C -C This routine is a specialization of the BLAS 3 routine DTRMM. -C BLAS 1 calls are used when appropriate, instead of in-line code, -C in order to increase the efficiency. If the matrix H is full, or -C its zero triangle has small order, an optimized DTRMM code could -C be faster than MB01ZD. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER DIAG, SIDE, TRANST, UPLO - INTEGER INFO, L, LDH, LDT, M, N - DOUBLE PRECISION ALPHA -C .. -C .. Array Arguments .. - DOUBLE PRECISION H( LDH, * ), T( LDT, * ) -C .. -C .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, TRANS, UPPER - INTEGER I, I1, I2, J, K, M2, NROWT - DOUBLE PRECISION TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - LSIDE = LSAME( SIDE, 'L' ) - UPPER = LSAME( UPLO, 'U' ) - TRANS = LSAME( TRANST, 'T' ) .OR. LSAME( TRANST, 'C' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( LSIDE )THEN - NROWT = M - ELSE - NROWT = N - END IF -C - IF( UPPER )THEN - M2 = M - ELSE - M2 = N - END IF -C - INFO = 0 - IF( .NOT.( LSIDE .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( TRANS .OR. LSAME( TRANST, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( NOUNIT .OR. LSAME( DIAG, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M2-1 ) ) THEN - INFO = -7 - ELSE IF( LDT.LT.MAX( 1, NROWT ) ) THEN - INFO = -10 - ELSE IF( LDH.LT.MAX( 1, M ) )THEN - INFO = -12 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01ZD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF( MIN( M, N ).EQ.0 ) - $ RETURN -C -C Also, when alpha = 0. -C - IF( ALPHA.EQ.ZERO ) THEN -C - DO 20, J = 1, N - IF( UPPER ) THEN - I1 = 1 - I2 = MIN( J+L, M ) - ELSE - I1 = MAX( 1, J-L ) - I2 = M - END IF -C - DO 10, I = I1, I2 - H( I, J ) = ZERO - 10 CONTINUE -C - 20 CONTINUE -C - RETURN - END IF -C -C Start the operations. -C - IF( LSIDE )THEN - IF( .NOT.TRANS ) THEN -C -C Form H := alpha*T*H. -C - IF( UPPER ) THEN -C - DO 40, J = 1, N -C - DO 30, K = 1, MIN( J+L, M ) - IF( H( K, J ).NE.ZERO ) THEN - TEMP = ALPHA*H( K, J ) - CALL DAXPY ( K-1, TEMP, T( 1, K ), 1, H( 1, J ), - $ 1 ) - IF( NOUNIT ) - $ TEMP = TEMP*T( K, K ) - H( K, J ) = TEMP - END IF - 30 CONTINUE -C - 40 CONTINUE -C - ELSE -C - DO 60, J = 1, N -C - DO 50 K = M, MAX( 1, J-L ), -1 - IF( H( K, J ).NE.ZERO ) THEN - TEMP = ALPHA*H( K, J ) - H( K, J ) = TEMP - IF( NOUNIT ) - $ H( K, J ) = H( K, J )*T( K, K ) - CALL DAXPY ( M-K, TEMP, T( K+1, K ), 1, - $ H( K+1, J ), 1 ) - END IF - 50 CONTINUE -C - 60 CONTINUE -C - END IF -C - ELSE -C -C Form H := alpha*T'*H. -C - IF( UPPER ) THEN -C - DO 80, J = 1, N - I1 = J + L -C - DO 70, I = M, 1, -1 - IF( I.GT.I1 ) THEN - TEMP = DDOT( I1, T( 1, I ), 1, H( 1, J ), 1 ) - ELSE - TEMP = H( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*T( I, I ) - TEMP = TEMP + DDOT( I-1, T( 1, I ), 1, - $ H( 1, J ), 1 ) - END IF - H( I, J ) = ALPHA*TEMP - 70 CONTINUE -C - 80 CONTINUE -C - ELSE -C - DO 100, J = 1, MIN( M+L, N ) - I1 = J - L -C - DO 90, I = 1, M - IF( I.LT.I1 ) THEN - TEMP = DDOT( M-I1+1, T( I1, I ), 1, H( I1, J ), - $ 1 ) - ELSE - TEMP = H( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*T( I, I ) - TEMP = TEMP + DDOT( M-I, T( I+1, I ), 1, - $ H( I+1, J ), 1 ) - END IF - H( I, J ) = ALPHA*TEMP - 90 CONTINUE -C - 100 CONTINUE -C - END IF -C - END IF -C - ELSE -C - IF( .NOT.TRANS ) THEN -C -C Form H := alpha*H*T. -C - IF( UPPER ) THEN -C - DO 120, J = N, 1, -1 - I2 = MIN( J+L, M ) - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( J, J ) - CALL DSCAL ( I2, TEMP, H( 1, J ), 1 ) -C - DO 110, K = 1, J - 1 - CALL DAXPY ( I2, ALPHA*T( K, J ), H( 1, K ), 1, - $ H( 1, J ), 1 ) - 110 CONTINUE -C - 120 CONTINUE -C - ELSE -C - DO 140, J = 1, N - I1 = MAX( 1, J-L ) - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( J, J ) - CALL DSCAL ( M-I1+1, TEMP, H( I1, J ), 1 ) -C - DO 130, K = J + 1, N - CALL DAXPY ( M-I1+1, ALPHA*T( K, J ), H( I1, K ), - $ 1, H( I1, J ), 1 ) - 130 CONTINUE -C - 140 CONTINUE -C - END IF -C - ELSE -C -C Form H := alpha*H*T'. -C - IF( UPPER ) THEN - M2 = MIN( N+L, M ) -C - DO 170, K = 1, N - I1 = MIN( K+L, M ) - I2 = MIN( K+L, M2 ) -C - DO 160, J = 1, K - 1 - IF( T( J, K ).NE.ZERO ) THEN - TEMP = ALPHA*T( J, K ) - CALL DAXPY ( I1, TEMP, H( 1, K ), 1, H( 1, J ), - $ 1 ) -C - DO 150, I = I1 + 1, I2 - H( I, J ) = TEMP*H( I, K ) - 150 CONTINUE -C - END IF - 160 CONTINUE -C - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( K, K ) - IF( TEMP.NE.ONE ) - $ CALL DSCAL( I2, TEMP, H( 1, K ), 1 ) - 170 CONTINUE -C - ELSE -C - DO 200, K = N, 1, -1 - I1 = MAX( 1, K-L ) - I2 = MAX( 1, K-L+1 ) - M2 = MIN( M, I2-1 ) -C - DO 190, J = K + 1, N - IF( T( J, K ).NE.ZERO ) THEN - TEMP = ALPHA*T( J, K ) - CALL DAXPY ( M-I2+1, TEMP, H( I2, K ), 1, - $ H( I2, J ), 1 ) -C - DO 180, I = I1, M2 - H( I, J ) = TEMP*H( I, K ) - 180 CONTINUE -C - END IF - 190 CONTINUE -C - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*T( K, K ) - IF( TEMP.NE.ONE ) - $ CALL DSCAL( M-I1+1, TEMP, H( I1, K ), 1 ) - 200 CONTINUE -C - END IF -C - END IF -C - END IF -C - RETURN -C -C *** Last line of MB01ZD *** - END diff --git a/slycot/src/MB02CD.f b/slycot/src/MB02CD.f deleted file mode 100644 index 2c878db9..00000000 --- a/slycot/src/MB02CD.f +++ /dev/null @@ -1,597 +0,0 @@ - SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, - $ LDL, CS, LCS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor and the generator and/or the -C Cholesky factor of the inverse of a symmetric positive definite -C (s.p.d.) block Toeplitz matrix T, defined by either its first -C block row, or its first block column, depending on the routine -C parameter TYPET. Transformation information is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine, as follows: -C = 'G': only computes the generator G of the inverse; -C = 'R': computes the generator G of the inverse and the -C Cholesky factor R of T, i.e., if TYPET = 'R', -C then R'*R = T, and if TYPET = 'C', then R*R' = T; -C = 'L': computes the generator G and the Cholesky factor L -C of the inverse, i.e., if TYPET = 'R', then -C L'*L = inv(T), and if TYPET = 'C', then -C L*L' = inv(T); -C = 'A': computes the generator G, the Cholesky factor L -C of the inverse and the Cholesky factor R of T; -C = 'O': only computes the Cholesky factor R of T. -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix; if demanded, the Cholesky factors -C R and L are upper and lower triangular, -C respectively, and G contains the transposed -C generator of the inverse; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix; if demanded, the Cholesky -C factors R and L are lower and upper triangular, -C respectively, and G contains the generator of the -C inverse. This choice results in a column oriented -C algorithm which is usually faster. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N*K) / (LDT,K) -C On entry, the leading K-by-N*K / N*K-by-K part of this -C array must contain the first block row / column of an -C s.p.d. block Toeplitz matrix. -C On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K -C part of this array contains, in the first K-by-K block, -C the upper / lower Cholesky factor of T(1:K,1:K), and in -C the remaining part, the Householder transformations -C applied during the process. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,N*K), if TYPET = 'C'. -C -C G (output) DOUBLE PRECISION array, dimension -C (LDG,N*K) / (LDG,2*K) -C If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading -C 2*K-by-N*K / N*K-by-2*K part of this array contains, in -C the first K-by-K block of the second block row / column, -C the lower right block of L (necessary for updating -C factorizations in SLICOT Library routine MB02DD), and -C in the remaining part, the generator of the inverse of T. -C Actually, to obtain a generator one has to set -C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; -C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. -C -C LDG INTEGER -C The leading dimension of the array G. -C LDG >= MAX(1,2*K), if TYPET = 'R' and -C JOB = 'G', 'R', 'L', or 'A'; -C LDG >= MAX(1,N*K), if TYPET = 'C' and -C JOB = 'G', 'R', 'L', or 'A'; -C LDG >= 1, if JOB = 'O'. -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N*K) -C If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading -C N*K-by-N*K part of this array contains the upper / lower -C Cholesky factor of T. -C The elements in the strictly lower / upper triangular part -C are not referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1,N*K), if JOB = 'R', 'A', or 'O'; -C LDR >= 1, if JOB = 'G', or 'L'. -C -C L (output) DOUBLE PRECISION array, dimension (LDL,N*K) -C If INFO = 0 and JOB = 'L', or 'A', then the leading -C N*K-by-N*K part of this array contains the lower / upper -C Cholesky factor of the inverse of T. -C The elements in the strictly upper / lower triangular part -C are not referenced. -C -C LDL INTEGER -C The leading dimension of the array L. -C LDL >= MAX(1,N*K), if JOB = 'L', or 'A'; -C LDL >= 1, if JOB = 'G', 'R', or 'O'. -C -C CS (output) DOUBLE PRECISION array, dimension (LCS) -C If INFO = 0, then the leading 3*(N-1)*K part of this -C array contains information about the hyperbolic rotations -C and Householder transformations applied during the -C process. This information is needed for updating the -C factorizations in SLICOT Library routine MB02DD. -C -C LCS INTEGER -C The length of the array CS. LCS >= 3*(N-1)*K. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,(N-1)*K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is not (numerically) positive -C definite. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 2 -C The algorithm requires 0(K N ) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2000, -C February 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB, TYPET - INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), - $ T(LDT,*) -C .. Local Scalars .. - INTEGER I, IERR, MAXWRK, STARTI, STARTR, STARTT - LOGICAL COMPG, COMPL, COMPR, ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) - COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL - COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR. - $ LSAME( JOB, 'O' ) - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPG .OR. COMPR ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN - INFO = -6 - ELSE IF ( LDG.LT.1 .OR. - $ ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) - $ .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN - INFO = -8 - ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN - INFO = -10 - ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN - INFO = -12 - ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN - DWORK(1) = MAX( 1, ( N - 1 )*K ) - INFO = -16 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 1 - IF ( ISROW ) THEN -C -C T is the first block row of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG ) - CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, G(K+1,1), LDG ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1), - $ LDG ) - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG ) - END IF -C - IF ( COMPL ) THEN - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) - END IF -C -C Processing the generator. -C - IF ( COMPG ) THEN -C -C Here we use G as working array for holding the generator. -C T contains the second row of the generator. -C G contains in its first block row the second row of the -C inverse generator. -C The second block row of G is partitioned as follows: -C -C [ First block of the inverse generator, ... -C First row of the generator, ... -C The rest of the blocks of the inverse generator ] -C -C The reason for the odd partitioning is that the first block -C of the inverse generator will be thrown out at the end and -C we want to avoid reordering. -C -C (N-1)*K locations of DWORK are used by SLICOT Library -C routine MB02CY. -C - DO 10 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I + 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 -C -C Transformations acting on the generator: -C - CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG, - $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, - $ G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT, - $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG, - $ R(STARTR,STARTR), LDR) - END IF -C -C Transformations acting on the inverse generator: -C - CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI), - $ LDG ) - CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), - $ LDG, G(1,STARTR), LDG, T(1,STARTR), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, - $ G(K+1,STARTI), LDG, G, LDG, T(1,STARTR), - $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG, - $ L(STARTR,1), LDL ) - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, - $ L(STARTR,(I-1)*K+1), LDL ) - END IF - 10 CONTINUE -C - ELSE -C -C Here R is used as working array for holding the generator. -C Again, T contains the second row of the generator. -C The current row of R contains the first row of the -C generator. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1), - $ LDR ) -C - DO 20 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, - $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, - $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), - $ LDT, T(1,STARTR), LDT, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR), - $ LDR, R(STARTR+K,STARTR+K), LDR ) - END IF - 20 CONTINUE -C - END IF -C - ELSE -C -C T is the first block column of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG ) - CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, G(1,K+1), LDG ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1), - $ LDG ) - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG ) - END IF -C - IF ( COMPL ) THEN - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) - END IF -C -C Processing the generator. -C - IF ( COMPG ) THEN -C -C Here we use G as working array for holding the generator. -C T contains the second column of the generator. -C G contains in its first block column the second column of -C the inverse generator. -C The second block column of G is partitioned as follows: -C -C [ First block of the inverse generator; ... -C First column of the generator; ... -C The rest of the blocks of the inverse generator ] -C -C The reason for the odd partitioning is that the first block -C of the inverse generator will be thrown out at the end and -C we want to avoid reordering. -C -C (N-1)*K locations of DWORK are used by SLICOT Library -C routine MB02CY. -C - DO 30 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I + 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 -C -C Transformations acting on the generator: -C - CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, - $ K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPR ) THEN - CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG, - $ R(STARTR,STARTR), LDR) - END IF -C -C Transformations acting on the inverse generator: -C - CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1), - $ LDG ) - CALL MB02CY( 'Column', 'Triangular', K, K, K, K, - $ G(1,K+1), LDG, G(STARTR,1), LDG, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, - $ G(STARTI,K+1), LDG, G, LDG, T(STARTR,1), - $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG, - $ L(1,STARTR), LDL ) - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, - $ L((I-1)*K+1,STARTR), LDL ) - END IF - 30 CONTINUE -C - ELSE -C -C Here R is used as working array for holding the generator. -C Again, T contains the second column of the generator. -C The current column of R contains the first column of the -C generator. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1), - $ LDR ) -C - DO 40 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, - $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( N.GT.I ) THEN - CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, - $ K, R(STARTR+K,STARTR), LDR, - $ T(STARTR+K,1), LDT, T(STARTR,1), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR), - $ LDR, R(STARTR+K,STARTR+K), LDR ) - END IF - 40 CONTINUE -C - END IF - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02CD *** - END diff --git a/slycot/src/MB02CU.f b/slycot/src/MB02CU.f deleted file mode 100644 index 38bddf38..00000000 --- a/slycot/src/MB02CU.f +++ /dev/null @@ -1,1015 +0,0 @@ - SUBROUTINE MB02CU( TYPEG, K, P, Q, NB, A1, LDA1, A2, LDA2, B, LDB, - $ RNK, IPVT, CS, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To bring the first blocks of a generator to proper form. -C The positive part of the generator is contained in the arrays A1 -C and A2. The negative part of the generator is contained in B. -C Transformation information will be stored and can be applied -C via SLICOT Library routine MB02CV. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPEG CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'D': generator is column oriented and rank -C deficiencies are expected; -C = 'C': generator is column oriented and rank -C deficiencies are not expected; -C = 'R': generator is row oriented and rank -C deficiencies are not expected. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in A1 to be processed. K >= 0. -C -C P (input) INTEGER -C The number of columns of the positive generator. P >= K. -C -C Q (input) INTEGER -C The number of columns in B containing the negative -C generators. -C If TYPEG = 'D', Q >= K; -C If TYPEG = 'C' or 'R', Q >= 0. -C -C NB (input) INTEGER -C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies -C the block size to be used in the blocked parts of the -C algorithm. If NB <= 0, an unblocked algorithm is used. -C -C A1 (input/output) DOUBLE PRECISION array, dimension -C (LDA1, K) -C On entry, the leading K-by-K part of this array must -C contain the leading submatrix of the positive part of the -C generator. If TYPEG = 'C', A1 is assumed to be lower -C triangular and the strictly upper triangular part is not -C referenced. If TYPEG = 'R', A1 is assumed to be upper -C triangular and the strictly lower triangular part is not -C referenced. -C On exit, if TYPEG = 'D', the leading K-by-RNK part of this -C array contains the lower trapezoidal part of the proper -C generator and information for the Householder -C transformations applied during the reduction process. -C On exit, if TYPEG = 'C', the leading K-by-K part of this -C array contains the leading lower triangular part of the -C proper generator. -C On exit, if TYPEG = 'R', the leading K-by-K part of this -C array contains the leading upper triangular part of the -C proper generator. -C -C LDA1 INTEGER -C The leading dimension of the array A1. LDA1 >= MAX(1,K). -C -C A2 (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); -C if TYPEG = 'R', dimension (LDA2, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-(P-K) part of this array must contain the (K+1)-st -C to P-th columns of the positive part of the generator. -C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of -C this array must contain the (K+1)-st to P-th rows of the -C positive part of the generator. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-(P-K) part of this array contains information for -C Householder transformations. -C On exit, if TYPEG = 'R', the leading (P-K)-by-K part of -C this array contains information for Householder -C transformations. -C -C LDA2 INTEGER -C The leading dimension of the array A2. -C If P = K, LDA2 >= 1; -C If P > K and (TYPEG = 'D' or TYPEG = 'C'), -C LDA2 >= MAX(1,K); -C if P > K and TYPEG = 'R', LDA2 >= P-K. -C -C B (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); -C if TYPEG = 'R', dimension (LDB, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-Q part of this array must contain the negative part -C of the generator. -C On entry, if TYPEG = 'R', the leading Q-by-K part of this -C array must contain the negative part of the generator. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-Q part of this array contains information for -C Householder transformations. -C On exit, if TYPEG = 'R', the leading Q-by-K part of this -C array contains information for Householder transformations. -C -C LDB INTEGER -C The leading dimension of the array B. -C If Q = 0, LDB >= 1; -C if Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), -C LDB >= MAX(1,K); -C if Q > 0 and TYPEG = 'R', LDB >= Q. -C -C RNK (output) INTEGER -C If TYPEG = 'D', the number of columns in the reduced -C generator which are found to be linearly independent. -C If TYPEG = 'C' or TYPEG = 'R', then RNK is not set. -C -C IPVT (output) INTEGER array, dimension (K) -C If TYPEG = 'D', then if IPVT(i) = k, the k-th row of the -C proper generator is the reduced i-th row of the input -C generator. -C If TYPEG = 'C' or TYPEG = 'R', this array is not -C referenced. -C -C CS (output) DOUBLE PRECISION array, dimension (x) -C If TYPEG = 'D' and P = K, x = 3*K; -C if TYPEG = 'D' and P > K, x = 5*K; -C if (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; -C if (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. -C On exit, the first x elements of this array contain -C necessary information for the SLICOT library routine -C MB02CV (Givens and modified hyperbolic rotation -C parameters, scalar factors of the Householder -C transformations). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If TYPEG = 'D', this number specifies the used tolerance -C for handling deficiencies. If the hyperbolic norm -C of two diagonal elements in the positive and negative -C generators appears to be less than or equal to TOL, then -C the corresponding columns are not reduced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,4*K), if TYPEG = 'D'; -C LDWORK >= MAX(1,MAX(NB,1)*K), if TYPEG = 'C' or 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if TYPEG = 'D', the generator represents a -C (numerically) indefinite matrix; and if TYPEG = 'C' -C or TYPEG = 'R', the generator represents a -C (numerically) semidefinite matrix. -C -C METHOD -C -C If TYPEG = 'C' or TYPEG = 'R', blocked Householder transformations -C and modified hyperbolic rotations are used to downdate the -C matrix [ A1 A2 sqrt(-1)*B ], cf. [1], [2]. -C If TYPEG = 'D', then an algorithm with row pivoting is used. In -C the first stage it maximizes the hyperbolic norm of the active -C row. As soon as the hyperbolic norm is below the threshold TOL, -C the strategy is changed. Now, in the second stage, the algorithm -C applies an LQ decomposition with row pivoting on B such that -C the Euclidean norm of the active row is maximized. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(K *( P + Q )) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D0 ) -C .. Scalar Arguments .. - CHARACTER TYPEG - INTEGER INFO, K, LDA1, LDA2, LDB, LDWORK, NB, P, Q, RNK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), - $ DWORK(*) -C .. Local Scalars .. - LOGICAL LCOL, LRDEF - INTEGER COL2, I, IB, IERR, IMAX, ITEMP, J, JJ, LEN, - $ NBL, PDW, PHV, POS, PST2, PVT, WRKMIN - DOUBLE PRECISION ALPHA, ALPHA2, BETA, C, DMAX, S, TAU1, TAU2, - $ TEMP, TEMP2 -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAPY2, DNRM2 - EXTERNAL IDAMAX, DLAPY2, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DGELQ2, DGEQR2, DLARF, DLARFB, DLARFG, - $ DLARFT, DLARTG, DROT, DSCAL, DSWAP, MA02FD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SIGN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COL2 = P - K - LRDEF = LSAME( TYPEG, 'D' ) - LCOL = LSAME( TYPEG, 'C' ) - IF ( LRDEF ) THEN - WRKMIN = MAX( 1, 4*K ) - ELSE - WRKMIN = MAX( 1, NB*K, K ) - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( P.LT.K ) THEN - INFO = -3 - ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN - INFO = -4 - ELSE IF ( LDA1.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. - $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. - $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.( P - K ) ) ) ) THEN - INFO = -9 - ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. - $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.MAX( 1, K ) ) ) .OR. - $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.Q ) ) ) THEN - INFO = -11 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( K.EQ.0 .OR. ( .NOT.LRDEF .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN - IF ( LRDEF ) - $ RNK = 0 - RETURN - END IF -C - IF ( LRDEF ) THEN -C -C Deficient generator. -C - IF ( COL2.EQ.0 ) THEN - PST2 = 2*K - ELSE - PST2 = 4*K - END IF -C -C Initialize partial hyperbolic row norms. -C - RNK = 0 - PHV = 3*K -C - DO 10 I = 1, K - IPVT(I) = I - DWORK(I) = DNRM2( K, A1(I,1), LDA1 ) - 10 CONTINUE -C - DO 20 I = 1, K - DWORK(I) = DLAPY2( DWORK(I), - $ DNRM2( COL2, A2(I,1), LDA2 ) ) - DWORK(I+K) = DWORK(I) - 20 CONTINUE -C - PDW = 2*K -C - DO 30 I = 1, K - PDW = PDW + 1 - DWORK(PDW) = DNRM2( Q, B(I,1), LDB ) - 30 CONTINUE -C -C Compute factorization. -C - DO 90 I = 1, K -C -C Determine pivot row and swap if necessary. -C - PDW = I - ALPHA = ABS( DWORK(PDW) ) - BETA = ABS( DWORK(PDW+2*K) ) - DMAX = SIGN( SQRT( ABS( ALPHA - BETA ) )* - $ SQRT( ALPHA + BETA ), ALPHA - BETA ) - IMAX = I -C - DO 40 J = 1, K - I - PDW = PDW + 1 - ALPHA = ABS( DWORK(PDW) ) - BETA = ABS ( DWORK(PDW+2*K) ) - TEMP = SIGN( SQRT( ABS( ALPHA - BETA ) )* - $ SQRT( ALPHA + BETA ), ALPHA - BETA ) - IF ( TEMP.GT.DMAX ) THEN - IMAX = I + J - DMAX = TEMP - END IF - 40 CONTINUE -C -C Proceed with the reduction if the hyperbolic norm is -C beyond the threshold. -C - IF ( DMAX.GT.TOL ) THEN -C - PVT = IMAX - IF ( PVT.NE.I ) THEN - CALL DSWAP( K, A1(PVT,1), LDA1, A1(I,1), LDA1 ) - CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(I,1), LDA2 ) - CALL DSWAP( Q, B(PVT,1), LDB, B(I,1), LDB ) - ITEMP = IPVT(PVT) - IPVT(PVT) = IPVT(I) - IPVT(I) = ITEMP - DWORK(PVT) = DWORK(I) - DWORK(K+PVT) = DWORK(K+I) - DWORK(2*K+PVT) = DWORK(2*K+I) - END IF -C -C Generate and apply elementary reflectors. -C - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(I,1), A2(I,2), LDA2, TAU2 ) - ALPHA2 = A2(I,1) - IF ( K.GT.I ) THEN - A2(I,1) = ONE - CALL DLARF( 'Right', K-I, COL2, A2(I,1), LDA2, - $ TAU2, A2(I+1,1), LDA2, DWORK(PHV+1) ) - END IF - A2(I,1) = TAU2 - ELSE IF ( COL2.GT.0 ) THEN - ALPHA2 = A2(I,1) - A2(I,1) = ZERO - END IF -C - IF ( K.GT.I ) THEN - CALL DLARFG( K-I+1, A1(I,I), A1(I,I+1), LDA1, TAU1 ) - ALPHA = A1(I,I) - A1(I,I) = ONE - CALL DLARF( 'Right', K-I, K-I+1, A1(I,I), LDA1, TAU1, - $ A1(I+1,I), LDA1, DWORK(PHV+1) ) - CS(PST2+I) = TAU1 - ELSE - ALPHA = A1(I,I) - END IF -C - IF ( COL2.GT.0 ) THEN - TEMP = ALPHA - CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) - IF ( K.GT.I ) - $ CALL DROT( K-I, A1(I+1,I), 1, A2(I+1,1), 1, C, S ) - CS(2*K+I*2-1) = C - CS(2*K+I*2) = S - END IF - A1(I,I) = ALPHA -C - IF ( Q.GT.1 ) THEN - CALL DLARFG( Q, B(I,1), B(I,2), LDB, TAU2 ) - BETA = B(I,1) - IF ( K.GT.I ) THEN - B(I,1) = ONE - CALL DLARF( 'Right', K-I, Q, B(I,1), LDB, TAU2, - $ B(I+1,1), LDB, DWORK(PHV+1) ) - END IF - B(I,1) = TAU2 - ELSE IF ( Q.GT.0 ) THEN - BETA = B(I,1) - B(I,1) = ZERO - ELSE - BETA = ZERO - END IF -C -C Create hyperbolic Givens rotation. -C - CALL MA02FD( A1(I,I), BETA, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: This should not happen. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.I ) THEN - CALL DSCAL( K-I, ONE/C, A1(I+1,I), 1 ) - CALL DAXPY( K-I, -S/C, B(I+1,1), 1, A1(I+1,I), 1 ) - CALL DSCAL( K-I, C, B(I+1,1), 1 ) - CALL DAXPY( K-I, -S, A1(I+1,I), 1, B(I+1,1), 1 ) - END IF - CS(I*2-1) = C - CS(I*2) = S -C -C Downdate the norms in A1. -C - DO 50 J = I + 1, K - TEMP = ONE - ( ABS( A1(J,I) ) / DWORK(J) )**2 - TEMP2 = ONE + P05*TEMP* - $ ( DWORK(J) / DWORK(K+J) )**2 - IF ( TEMP2.EQ.ONE ) THEN - DWORK(J) = DLAPY2( DNRM2( K-I, A1(J,I+1), LDA1 ), - $ DNRM2( COL2, A2(J,1), LDA2 ) ) - DWORK(K+J) = DWORK(J) - DWORK(2*K+J) = DNRM2( Q, B(J,1), LDB ) - ELSE - IF ( TEMP.GE.ZERO ) THEN - DWORK(J) = DWORK(J)*SQRT( TEMP ) - ELSE - DWORK(J) = -DWORK(J)*SQRT( -TEMP ) - END IF - END IF - 50 CONTINUE -C - RNK = RNK + 1 - ELSE IF ( ABS( DMAX ).LT.TOL ) THEN -C -C Displacement is positive semidefinite. -C Do an LQ decomposition with pivoting of the leftover -C negative part to find diagonal elements with almost zero -C norm. These columns cannot be removed from the -C generator. -C -C Initialize norms. -C - DO 60 J = I, K - DWORK(J) = DNRM2( Q, B(J,1), LDB ) - DWORK(J+K) = DWORK(J) - 60 CONTINUE -C - LEN = Q - POS = 1 -C - DO 80 J = I, K -C -C Generate and apply elementary reflectors. -C - PVT = ( J-1 ) + IDAMAX( K-J+1, DWORK(J), 1 ) -C -C Swap rows if necessary. -C - IF ( PVT.NE.J ) THEN - CALL DSWAP( K, A1(PVT,1), LDA1, A1(J,1), LDA1 ) - CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(J,1), LDA2 ) - CALL DSWAP( Q, B(PVT,1), LDB, B(J,1), LDB ) - ITEMP = IPVT(PVT) - IPVT(PVT) = IPVT(J) - IPVT(J) = ITEMP - DWORK(PVT) = DWORK(J) - DWORK(K+PVT) = DWORK(K+J) - END IF -C -C Annihilate second part of the positive generators. -C - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) - ALPHA2 = A2(J,1) - IF ( K.GT.J ) THEN - A2(J,1) = ONE - CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, - $ TAU2, A2(J+1,1), LDA2, DWORK(PHV+1)) - END IF - A2(J,1) = TAU2 - ELSE IF ( COL2.GT.0 ) THEN - ALPHA2 = A2(J,1) - A2(J,1) = ZERO - END IF -C -C Transform first part of the positive generators to -C lower triangular form. -C - IF ( K.GT.J ) THEN - CALL DLARFG( K-J+1, A1(J,J), A1(J,J+1), LDA1, - $ TAU1 ) - ALPHA = A1(J,J) - A1(J,J) = ONE - CALL DLARF( 'Right', K-J, K-J+1, A1(J,J), LDA1, - $ TAU1, A1(J+1,J), LDA1, DWORK(PHV+1) ) - CS(PST2+J) = TAU1 - ELSE - ALPHA = A1(J,J) - END IF -C - IF ( COL2.GT.0 ) THEN - TEMP = ALPHA - CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, - $ S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - END IF - A1(J,J) = ALPHA -C -C Transform negative part to lower triangular form. -C - IF ( LEN.GT.1) THEN - CALL DLARFG( LEN, B(J,POS), B(J,POS+1), LDB, TAU2 ) - BETA = B(J,POS) - IF ( K.GT.J ) THEN - B(J,POS) = ONE - CALL DLARF( 'Right', K-J, LEN, B(J,POS), LDB, - $ TAU2, B(J+1,POS), LDB, DWORK(PHV+1)) - END IF - B(J,POS) = BETA - CS(J*2-1) = TAU2 - END IF -C -C Downdate the norms of the rows in the negative part. -C - DO 70 JJ = J + 1, K - IF ( DWORK(JJ).NE.ZERO ) THEN - TEMP = ONE - ( ABS( B(JJ,POS) ) - $ / DWORK(JJ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK(JJ) / DWORK(K+JJ) )**2 - IF ( TEMP2.EQ.ONE ) THEN - DWORK(JJ) = DNRM2( LEN-1, B(JJ,POS+1), LDB) - DWORK(K+JJ) = DWORK(JJ) - ELSE - IF ( TEMP.GE.ZERO ) THEN - DWORK(JJ) = DWORK(JJ)*SQRT( TEMP ) - ELSE - DWORK(JJ) = -DWORK(JJ)*SQRT( -TEMP ) - END IF - END IF - END IF - 70 CONTINUE -C - LEN = LEN - 1 - POS = POS + 1 - 80 CONTINUE -C - RETURN - ELSE -C -C Error return: -C -C Displacement is indefinite. -C Due to roundoff error, positive semidefiniteness is -C violated. This is a rather bad situation. There is no -C meaningful way to continue the computations from this -C point. -C - INFO = 1 - RETURN - END IF - 90 CONTINUE -C - ELSE IF ( LCOL ) THEN -C -C Column oriented and not deficient generator. -C -C Apply an LQ like hyperbolic/orthogonal blocked decomposition. -C - IF ( COL2.GT.0 ) THEN - NBL = MIN( COL2, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 110 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGELQ2( IB, COL2, A2(I,1), LDA2, CS(4*K+I), - $ DWORK, IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, - $ A2(I,1), LDA2, CS(4*K+I), DWORK, K ) - CALL DLARFB( 'Right', 'No Transpose', 'Forward', - $ 'Rowwise', K-I-IB+1, COL2, IB, - $ A2(I,1), LDA2, DWORK, K, A2(I+IB,1), - $ LDA2, DWORK(IB+1), K ) - END IF -C -C Annihilate the remaining parts of A2. -C - DO 100 J = I, I + IB - 1 - IF ( COL2.GT.1 ) THEN - LEN = MIN( COL2, J-I+1 ) - CALL DLARFG( LEN, A2(J,1), A2(J,2), LDA2, TAU2 ) - ALPHA2 = A2(J,1) - IF ( K.GT.J ) THEN - A2(J,1) = ONE - CALL DLARF( 'Right', K-J, LEN, A2(J,1), LDA2, - $ TAU2, A2(J+1,1), LDA2, DWORK ) - END IF - A2(J,1) = TAU2 - ELSE - ALPHA2 = A2(J,1) - A2(J,1) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, - $ S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 100 CONTINUE -C - 110 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 120 J = I, K - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) - ALPHA2 = A2(J,1) - IF ( K.GT.J ) THEN - A2(J,1) = ONE - CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, - $ TAU2, A2(J+1,1), LDA2, DWORK ) - END IF - A2(J,1) = TAU2 - ELSE - ALPHA2 = A2(J,1) - A2(J,1) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 120 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C -C Annihilate B with hyperbolic transformations. -C - NBL = MIN( NB, Q ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 140 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGELQ2( IB, Q, B(I,1), LDB, CS(PST2+I), DWORK, - $ IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), - $ LDB, CS(PST2+I), DWORK, K ) - CALL DLARFB( 'Right', 'No Transpose', 'Forward', - $ 'Rowwise', K-I-IB+1, Q, IB, B(I,1), - $ LDB, DWORK, K, B(I+IB,1), LDB, - $ DWORK( IB+1 ), K ) - END IF -C -C Annihilate the remaining parts of B. -C - DO 130 J = I, I + IB - 1 - IF ( Q.GT.1 ) THEN - CALL DLARFG( J-I+1, B(J,1), B(J,2), LDB, TAU2 ) - ALPHA2 = B(J,1) - IF ( K.GT.J ) THEN - B(J,1) = ONE - CALL DLARF( 'Right', K-J, J-I+1, B(J,1), LDB, - $ TAU2, B(J+1,1), LDB, DWORK ) - END IF - B(J,1) = TAU2 - ELSE - ALPHA2 = B(J,1) - B(J,1) = ZERO - END IF -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) - CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) - CALL DSCAL( K-J, C, B(J+1,1), 1 ) - CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) - END IF - CS(J*2-1) = C - CS(J*2) = S - 130 CONTINUE -C - 140 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 150 J = I, K - IF ( Q.GT.1 ) THEN - CALL DLARFG( Q, B(J,1), B(J,2), LDB, TAU2 ) - ALPHA2 = B(J,1) - IF ( K.GT.J ) THEN - B(J,1) = ONE - CALL DLARF( 'Right', K-J, Q, B(J,1), LDB, TAU2, - $ B(J+1,1), LDB, DWORK ) - END IF - B(J,1) = TAU2 - ELSE IF ( Q.GT.0 ) THEN - ALPHA2 = B(J,1) - B(J,1) = ZERO - END IF - IF ( Q.GT.0 ) THEN -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) - CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) - CALL DSCAL( K-J, C, B(J+1,1), 1 ) - CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) - END IF - CS(J*2-1) = C - CS(J*2) = S - END IF - 150 CONTINUE -C - ELSE -C -C Row oriented and not deficient generator. -C - IF ( COL2.GT.0 ) THEN - NBL = MIN( NB, COL2 ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 170 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGEQR2( COL2, IB, A2(1,I), LDA2, CS(4*K+I), - $ DWORK, IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, - $ A2(1,I), LDA2, CS(4*K+I), DWORK, K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', COL2, K-I-IB+1, IB, - $ A2(1,I), LDA2, DWORK, K, A2(1,I+IB), - $ LDA2, DWORK(IB+1), K ) - END IF -C -C Annihilate the remaining parts of A2. -C - DO 160 J = I, I + IB - 1 - IF ( COL2.GT.1 ) THEN - LEN = MIN( COL2, J-I+1 ) - CALL DLARFG( LEN, A2(1,J), A2(2,J), 1, TAU2 ) - ALPHA2 = A2(1,J) - IF ( K.GT.J ) THEN - A2(1,J) = ONE - CALL DLARF( 'Left', LEN, K-J, A2(1,J), 1, - $ TAU2, A2(1,J+1), LDA2, DWORK ) - END IF - A2(1,J) = TAU2 - ELSE - ALPHA2 = A2(1,J) - A2(1,J) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), - $ LDA2, C, S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 160 CONTINUE -C - 170 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 180 J = I, K - IF ( COL2.GT.1 ) THEN - CALL DLARFG( COL2, A2(1,J), A2(2,J), 1, TAU2 ) - ALPHA2 = A2(1,J) - IF ( K.GT.J ) THEN - A2(1,J) = ONE - CALL DLARF( 'Left', COL2, K-J, A2(1,J), 1, TAU2, - $ A2(1,J+1), LDA2, DWORK ) - END IF - A2(1,J) = TAU2 - ELSE - ALPHA2 = A2(1,J) - A2(1,J) = ZERO - END IF - ALPHA = A1(J,J) - CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) - IF ( K.GT.J ) - $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), LDA2, C, - $ S ) - CS(2*K+J*2-1) = C - CS(2*K+J*2) = S - 180 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C -C Annihilate B with hyperbolic transformations. -C - NBL = MIN( NB, Q ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 200 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DGEQR2( Q, IB, B(1,I), LDB, CS(PST2+I), DWORK, - $ IERR ) - IF ( I+IB.LE.K ) THEN - CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), - $ LDB, CS(PST2+I), DWORK, K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', Q, K-I-IB+1, IB, B(1,I), - $ LDB, DWORK, K, B(1,I+IB), LDB, - $ DWORK( IB+1 ), K ) - END IF -C -C Annihilate the remaining parts of B. -C - DO 190 J = I, I + IB - 1 - IF ( Q.GT.1 ) THEN - CALL DLARFG( J-I+1, B(1,J), B(2,J), 1, TAU2 ) - ALPHA2 = B(1,J) - IF ( K.GT.J ) THEN - B(1,J) = ONE - CALL DLARF( 'Left', J-I+1, K-J, B(1,J), 1, - $ TAU2, B(1,J+1), LDB, DWORK ) - END IF - B(1,J) = TAU2 - ELSE - ALPHA2 = B(1,J) - B(1,J) = ZERO - END IF -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) - CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), - $ LDA1 ) - CALL DSCAL( K-J, C, B(1,J+1), LDB ) - CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), - $ LDB ) - END IF - CS(J*2-1) = C - CS(J*2) = S - 190 CONTINUE -C - 200 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 210 J = I, K - IF ( Q.GT.1 ) THEN - CALL DLARFG( Q, B(1,J), B(2,J), 1, TAU2 ) - ALPHA2 = B(1,J) - IF ( K.GT.J ) THEN - B(1,J) = ONE - CALL DLARF( 'Left', Q, K-J, B(1,J), 1, TAU2, - $ B(1,J+1), LDB, DWORK ) - END IF - B(1,J) = TAU2 - ELSE IF ( Q.GT.0 ) THEN - ALPHA2 = B(1,J) - B(1,J) = ZERO - END IF - IF ( Q.GT.0 ) THEN -C -C Create hyperbolic rotation. -C - CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C -C Apply hyperbolic rotation. -C - IF ( K.GT.J ) THEN - CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) - CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), LDA1 - $ ) - CALL DSCAL( K-J, C, B(1,J+1), LDB ) - CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), LDB - $ ) - END IF - CS(J*2-1) = C - CS(J*2) = S - END IF - 210 CONTINUE -C - END IF -C -C *** Last line of MB02CU *** - END diff --git a/slycot/src/MB02CV.f b/slycot/src/MB02CV.f deleted file mode 100644 index f049fca5..00000000 --- a/slycot/src/MB02CV.f +++ /dev/null @@ -1,795 +0,0 @@ - SUBROUTINE MB02CV( TYPEG, STRUCG, K, N, P, Q, NB, RNK, A1, LDA1, - $ A2, LDA2, B, LDB, F1, LDF1, F2, LDF2, G, LDG, - $ CS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the transformations created by the SLICOT Library routine -C MB02CU on other columns / rows of the generator, contained in the -C arrays F1, F2 and G. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPEG CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'D': generator is column oriented and rank -C deficient; -C = 'C': generator is column oriented and not rank -C deficient; -C = 'R': generator is row oriented and not rank -C deficient. -C Note that this parameter must be equivalent with the -C used TYPEG in the call of MB02CU. -C -C STRUCG CHARACTER*1 -C Information about the structure of the generators, -C as follows: -C = 'T': the trailing block of the positive generator -C is upper / lower triangular, and the trailing -C block of the negative generator is zero; -C = 'N': no special structure to mention. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in A1 to be processed. K >= 0. -C -C N (input) INTEGER -C If TYPEG = 'D' or TYPEG = 'C', the number of rows in F1; -C if TYPEG = 'R', the number of columns in F1. N >= 0. -C -C P (input) INTEGER -C The number of columns of the positive generator. P >= K. -C -C Q (input) INTEGER -C The number of columns in B. -C If TYPEG = 'D', Q >= K; -C If TYPEG = 'C' or 'R', Q >= 0. -C -C NB (input) INTEGER -C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies -C the block size to be used in the blocked parts of the -C algorithm. NB must be equivalent with the used block size -C in the routine MB02CU. -C -C RNK (input) INTEGER -C If TYPEG = 'D', the number of linearly independent columns -C in the generator as returned by MB02CU. 0 <= RNK <= K. -C If TYPEG = 'C' or 'R', the value of this parameter is -C irrelevant. -C -C A1 (input) DOUBLE PRECISION array, dimension -C (LDA1, K) -C On entry, if TYPEG = 'D', the leading K-by-K part of this -C array must contain the matrix A1 as returned by MB02CU. -C If TYPEG = 'C' or 'R', this array is not referenced. -C -C LDA1 INTEGER -C The leading dimension of the array A1. -C If TYPEG = 'D', LDA1 >= MAX(1,K); -C if TYPEG = 'C' or TYPEG = 'R', LDA1 >= 1. -C -C A2 (input) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); -C if TYPEG = 'R', dimension (LDA2, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-(P-K) part of this array must contain the matrix -C A2 as returned by MB02CU. -C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of -C this array must contain the matrix A2 as returned by -C MB02CU. -C -C LDA2 INTEGER -C The leading dimension of the array A2. -C If P = K, LDA2 >= 1; -C If P > K and (TYPEG = 'D' or TYPEG = 'C'), -C LDA2 >= MAX(1,K); -C if P > K and TYPEG = 'R', LDA2 >= P-K. -C -C B (input) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); -C if TYPEG = 'R', dimension (LDB, K). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C K-by-Q part of this array must contain the matrix B as -C returned by MB02CU. -C On entry, if TYPEG = 'R', the leading Q-by-K part of this -C array must contain the matrix B as returned by MB02CU. -C -C LDB INTEGER -C The leading dimension of the array B. -C If Q = 0, LDB >= 1; -C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), -C LDB >= MAX(1,K); -C if Q > 0 and TYPEG = 'R', LDB >= Q. -C -C F1 (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF1, K); -C if TYPEG = 'R', dimension (LDF1, N). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-K part of this array must contain the first part -C of the positive generator to be processed. -C On entry, if TYPEG = 'R', the leading K-by-N part of this -C array must contain the first part of the positive -C generator to be processed. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-K part of this array contains the first part of the -C transformed positive generator. -C On exit, if TYPEG = 'R', the leading K-by-N part of this -C array contains the first part of the transformed positive -C generator. -C -C LDF1 INTEGER -C The leading dimension of the array F1. -C If TYPEG = 'D' or TYPEG = 'C', LDF1 >= MAX(1,N); -C if TYPEG = 'R', LDF1 >= MAX(1,K). -C -C F2 (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF2, P-K); -C if TYPEG = 'R', dimension (LDF2, N). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-(P-K) part of this array must contain the second part -C of the positive generator to be processed. -C On entry, if TYPEG = 'R', the leading (P-K)-by-N part of -C this array must contain the second part of the positive -C generator to be processed. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-(P-K) part of this array contains the second part of -C the transformed positive generator. -C On exit, if TYPEG = 'R', the leading (P-K)-by-N part of -C this array contains the second part of the transformed -C positive generator. -C -C LDF2 INTEGER -C The leading dimension of the array F2. -C If P = K, LDF2 >= 1; -C If P > K and (TYPEG = 'D' or TYPEG = 'C'), -C LDF2 >= MAX(1,N); -C if P > K and TYPEG = 'R', LDF2 >= P-K. -C -C G (input/output) DOUBLE PRECISION array, -C if TYPEG = 'D' or TYPEG = 'C', dimension (LDG, Q); -C if TYPEG = 'R', dimension (LDG, N). -C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-Q part of this array must contain the negative part -C of the generator to be processed. -C On entry, if TYPEG = 'R', the leading Q-by-N part of this -C array must contain the negative part of the generator to -C be processed. -C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading -C N-by-Q part of this array contains the transformed -C negative generator. -C On exit, if TYPEG = 'R', the leading Q-by-N part of this -C array contains the transformed negative generator. -C -C LDG INTEGER -C The leading dimension of the array G. -C If Q = 0, LDG >= 1; -C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), -C LDG >= MAX(1,N); -C if Q > 0 and TYPEG = 'R', LDG >= Q. -C -C CS (input) DOUBLE PRECISION array, dimension (x) -C If TYPEG = 'D' and P = K, x = 3*K; -C If TYPEG = 'D' and P > K, x = 5*K; -C If (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; -C If (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. -C On entry, the first x elements of this array must contain -C Givens and modified hyperbolic rotation parameters, and -C scalar factors of the Householder transformations as -C returned by MB02CU. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -23, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C TYPEG = 'D': LDWORK >= MAX(1,N); -C (TYPEG = 'C' or TYPEG = 'R') and NB <= 0: -C LDWORK >= MAX(1,N); -C (TYPEG = 'C' or TYPEG = 'R') and NB >= 1: -C LDWORK >= MAX(1,( N + K )*NB). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N*K*( P + Q )) floating point operations. -C -C METHOD -C -C The Householder transformations and modified hyperbolic rotations -C computed by SLICOT Library routine MB02CU are applied to the -C corresponding parts of the matrices F1, F2 and G. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C March 2004, March 2007. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER STRUCG, TYPEG - INTEGER INFO, K, LDA1, LDA2, LDB, LDF1, LDF2, LDG, - $ LDWORK, N, NB, P, Q, RNK -C .. Array Arguments .. - DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), - $ DWORK(*), F1(LDF1,*), F2(LDF2,*), G(LDG,*) -C .. Local Scalars .. - INTEGER COL2, I, IB, J, JJ, LEN, NBL, POS, PST2, - $ WRKMIN - DOUBLE PRECISION ALPHA, BETA, C, S, TAU, TEMP - LOGICAL LRDEF, LTRI, LCOL -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLARF, DLARFB, DLARFT, DROT, DSCAL, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COL2 = MAX( 0, P - K ) - LRDEF = LSAME( TYPEG, 'D' ) - LCOL = LSAME( TYPEG, 'C' ) - LTRI = LSAME( STRUCG, 'T' ) - IF ( LRDEF ) THEN - WRKMIN = MAX( 1, N ) - ELSE - IF ( NB.GE.1 ) THEN - WRKMIN = MAX( 1, ( N + K )*NB ) - ELSE - WRKMIN = MAX( 1, N ) - END IF - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRI .OR. LSAME( STRUCG, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( P.LT.K ) THEN - INFO = -5 - ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN - INFO = -6 - ELSE IF ( LRDEF .AND. ( RNK.LT.0 .OR. RNK.GT.K ) ) THEN - INFO = -8 - ELSE IF ( ( LDA1.LT.1 ) .OR. ( LRDEF .AND. LDA1.LT.K ) ) THEN - INFO = -10 - ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. - $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. - $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDA2.LT.( P-K ) ) ) ) THEN - INFO = -12 - ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. - $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.MAX( 1, K ) ) ) .OR. - $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDB.LT.Q ) ) ) THEN - INFO = -14 - ELSE IF ( ( LRDEF .OR. LCOL ) .AND. LDF1.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF ( (.NOT.( LRDEF .OR. LCOL ) ) .AND. LDF1.LT.MAX( 1, K ) ) - $ THEN - INFO = -16 - ELSE IF ( ( ( P.EQ.K ) .AND. LDF2.LT.1 ) .OR. - $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDF2.LT.MAX( 1, N ) ) ) .OR. - $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDF2.LT.( P-K ) ) ) ) THEN - INFO = -18 - ELSE IF ( ( ( Q.EQ.0 ) .AND. LDG.LT.1 ) .OR. - $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. - $ ( LDG.LT.MAX( 1, N ) ) ) .OR. - $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. - $ ( LDG.LT.Q ) ) ) THEN - INFO = -20 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -23 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CV', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N ).EQ.0 .OR. - $ ( ( .NOT.LRDEF ) .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN - RETURN - END IF -C - IF ( LRDEF ) THEN -C -C Deficient generator. -C - IF ( COL2.EQ.0 ) THEN - PST2 = 2*K - ELSE - PST2 = 4*K - END IF -C - DO 10 I = 1, RNK -C -C Apply elementary reflectors. -C - IF ( COL2.GT.1 ) THEN - TAU = A2(I,1) - A2(I,1) = ONE - CALL DLARF( 'Right', N, COL2, A2(I,1), LDA2, TAU, F2, - $ LDF2, DWORK ) - A2(I,1) = TAU - END IF -C - IF ( K.GT.I ) THEN - ALPHA = A1(I,I) - A1(I,I) = ONE - CALL DLARF( 'Right', N, K-I+1, A1(I,I), LDA1, CS(PST2+I), - $ F1(1,I), LDF1, DWORK ) - A1(I,I) = ALPHA - END IF -C - IF ( COL2.GT.0 ) THEN - C = CS(2*K+I*2-1) - S = CS(2*K+I*2) - CALL DROT( N, F1(1,I), 1, F2, 1, C, S ) - END IF -C - IF ( Q.GT.1 ) THEN - TAU = B(I,1) - B(I,1) = ONE - CALL DLARF( 'Right', N, Q, B(I,1), LDB, TAU, - $ G, LDG, DWORK ) - B(I,1) = TAU - END IF -C -C Apply hyperbolic rotation. -C - C = CS(I*2-1) - S = CS(I*2) - CALL DSCAL( N, ONE/C, F1(1,I), 1 ) - CALL DAXPY( N, -S/C, G(1,1), 1, F1(1,I), 1 ) - CALL DSCAL( N, C, G(1,1), 1 ) - CALL DAXPY( N, -S, F1(1,I), 1, G(1,1), 1 ) - 10 CONTINUE -C - LEN = Q - POS = 1 -C - DO 20 J = RNK + 1, K -C -C Apply the reductions working on singular rows. -C - IF ( COL2.GT.1 ) THEN - TAU = A2(J,1) - A2(J,1) = ONE - CALL DLARF( 'Right', N, COL2, A2(J,1), LDA2, TAU, F2, - $ LDF2, DWORK ) - A2(J,1) = TAU - END IF - IF ( K.GT.J ) THEN - ALPHA = A1(J,J) - A1(J,J) = ONE - CALL DLARF( 'Right', N, K-J+1, A1(J,J), LDA1, CS(PST2+J), - $ F1(1,J), LDF1, DWORK ) - A1(J,J) = ALPHA - END IF - IF ( COL2.GT.0 ) THEN - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( N, F1(1,J), 1, F2, 1, C, S ) - END IF - IF ( LEN.GT.1 ) THEN - BETA = B(J,POS) - B(J,POS) = ONE - CALL DLARF( 'Right', N, LEN, B(J,POS), LDB, CS(J*2-1), - $ G(1,POS), LDG, DWORK ) - B(J,POS) = BETA - END IF - LEN = LEN - 1 - POS = POS + 1 - 20 CONTINUE -C - ELSE IF ( LCOL ) THEN -C -C Column oriented and not deficient generator. -C -C Apply an LQ like hyperbolic/orthogonal blocked decomposition. -C - IF ( LTRI ) THEN - LEN = MAX( N - K, 0 ) - ELSE - LEN = N - END IF - IF ( COL2.GT.0 ) THEN -C - NBL = MIN( COL2, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 50 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, A2(I,1), - $ LDA2, CS(4*K+I), DWORK, N+K ) - CALL DLARFB( 'Right', 'No Transpose', 'Forward', - $ 'Rowwise', LEN, COL2, IB, A2(I,1), - $ LDA2, DWORK, N+K, F2, LDF2, - $ DWORK(IB+1), N+K ) -C - DO 40 J = I, I + IB - 1 - TAU = A2(J,1) - A2(J,1) = ONE - CALL DLARF( 'Right', LEN, MIN( COL2, J-I+1 ), - $ A2(J,1), LDA2, TAU, F2, LDF2, DWORK ) - A2(J,1) = TAU - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(LEN,J) - F1(LEN,J) = C*TEMP - F2(LEN,1) = -S*TEMP -C - DO 30 JJ = 2, COL2 - F2(LEN,JJ) = ZERO - 30 CONTINUE -C - END IF - 40 CONTINUE -C - 50 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 70 J = I, K - IF ( COL2.GT.1 ) THEN - TAU = A2(J,1) - A2(J,1) = ONE - CALL DLARF( 'Right', LEN, COL2, A2(J,1), LDA2, TAU, - $ F2, LDF2, DWORK ) - A2(J,1) = TAU - END IF -C - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(LEN,J) - F1(LEN,J) = C*TEMP - F2(LEN,1) = -S*TEMP -C - DO 60 JJ = 2, COL2 - F2(LEN,JJ) = ZERO - 60 CONTINUE -C - END IF - 70 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C - IF ( LTRI ) THEN - LEN = N - K - ELSE - LEN = N - END IF -C - NBL = MIN( Q, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 100 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), - $ LDB, CS(PST2+I), DWORK, N+K ) - CALL DLARFB( 'Right', 'NonTranspose', 'Forward', - $ 'Rowwise', LEN, Q, IB, B(I,1), - $ LDB, DWORK, N+K, G, LDG, - $ DWORK(IB+1), N+K ) -C - DO 90 J = I, I + IB - 1 - TAU = B(J,1) - B(J,1) = ONE - CALL DLARF( 'Right', LEN, J-I+1, B(J,1), LDB, - $ TAU, G, LDG, DWORK ) - B(J,1) = TAU -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) - CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) - CALL DSCAL( LEN, C, G, 1 ) - CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(LEN,1) = -S/C*F1(LEN,J) - F1(LEN,J) = F1(LEN,J) / C -C - DO 80 JJ = 2, Q - G(LEN,JJ) = ZERO - 80 CONTINUE -C - END IF - 90 CONTINUE -C - 100 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 120 J = I, K - IF ( Q.GT.1 ) THEN - TAU = B(J,1) - B(J,1) = ONE - CALL DLARF( 'Right', LEN, Q, B(J,1), LDB, TAU, - $ G, LDG, DWORK ) - B(J,1) = TAU - END IF - IF ( Q.GT.0 ) THEN -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) - CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) - CALL DSCAL( LEN, C, G, 1 ) - CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(LEN,1) = -S/C*F1(LEN,J) - F1(LEN,J) = F1(LEN,J) / C -C - DO 110 JJ = 2, Q - G(LEN,JJ) = ZERO - 110 CONTINUE -C - END IF - END IF - 120 CONTINUE -C - ELSE -C -C Row oriented and not deficient generator. -C - IF ( LTRI ) THEN - LEN = MAX( N - K, 0 ) - ELSE - LEN = N - END IF -C - IF ( COL2.GT.0 ) THEN - NBL = MIN( NB, COL2 ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 150 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, - $ A2(1,I), LDA2, CS(4*K+I), DWORK, N+K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', COL2, LEN, IB, A2(1,I), - $ LDA2, DWORK, N+K, F2, LDF2, - $ DWORK(IB+1), N+K ) -C - DO 140 J = I, I + IB - 1 - TAU = A2(1,J) - A2(1,J) = ONE - CALL DLARF( 'Left', MIN( COL2, J-I+1 ), LEN, - $ A2(1,J), 1, TAU, F2, LDF2, DWORK ) - A2(1,J) = TAU - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(J,LEN) - F1(J,LEN) = C*TEMP - F2(1,LEN) = -S*TEMP -C - DO 130 JJ = 2, COL2 - F2(JJ,LEN) = ZERO - 130 CONTINUE -C - END IF - 140 CONTINUE -C - 150 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 170 J = I, K - IF ( COL2.GT.1 ) THEN - TAU = A2(1,J) - A2(1,J) = ONE - CALL DLARF( 'Left', COL2, LEN, A2(1,J), 1, TAU, - $ F2, LDF2, DWORK ) - A2(1,J) = TAU - END IF -C - C = CS(2*K+J*2-1) - S = CS(2*K+J*2) - CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) - IF ( LTRI ) THEN - LEN = LEN + 1 - TEMP = F1(J,LEN) - F1(J,LEN) = C*TEMP - F2(1,LEN) = -S*TEMP -C - DO 160 JJ = 2, COL2 - F2(JJ,LEN) = ZERO - 160 CONTINUE -C - END IF - 170 CONTINUE -C - PST2 = 5*K - ELSE - PST2 = 2*K - END IF -C - IF ( LTRI ) THEN - LEN = N - K - ELSE - LEN = N - END IF -C - NBL = MIN( Q, NB ) - IF ( NBL.GT.0 ) THEN -C -C Blocked version. -C - DO 200 I = 1, K - NBL + 1, NBL - IB = MIN( K-I+1, NBL ) - CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), - $ LDB, CS(PST2+I), DWORK, N+K ) - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', Q, LEN, IB, B(1,I), - $ LDB, DWORK, N+K, G, LDG, - $ DWORK(IB+1), N+K ) -C - DO 190 J = I, I + IB - 1 - TAU = B(1,J) - B(1,J) = ONE - CALL DLARF( 'Left', J-I+1, LEN, B(1,J), 1, - $ TAU, G, LDG, DWORK ) - B(1,J) = TAU -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) - CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) - CALL DSCAL( LEN, C, G, LDG ) - CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(1,LEN) = -S/C*F1(J,LEN) - F1(J,LEN) = F1(J,LEN) / C -C - DO 180 JJ = 2, Q - G(JJ,LEN) = ZERO - 180 CONTINUE -C - END IF - 190 CONTINUE -C - 200 CONTINUE -C - ELSE - I = 1 - END IF -C -C Unblocked version for the last or only block. -C - DO 220 J = I, K - IF ( Q.GT.1 ) THEN - TAU = B(1,J) - B(1,J) = ONE - CALL DLARF( 'Left', Q, LEN, B(1,J), 1, TAU, - $ G, LDG, DWORK ) - B(1,J) = TAU - END IF - IF ( Q.GT.0 ) THEN -C -C Apply hyperbolic rotation. -C - C = CS(J*2-1) - S = CS(J*2) - CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) - CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) - CALL DSCAL( LEN, C, G, LDG ) - CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) - IF ( LTRI ) THEN - LEN = LEN + 1 - G(1,LEN) = -S/C*F1(J,LEN) - F1(J,LEN) = F1(J,LEN) / C -C - DO 210 JJ = 2, Q - G(JJ,LEN) = ZERO - 210 CONTINUE -C - END IF - END IF - 220 CONTINUE -C - END IF -C -C *** Last line of MB02CV *** - END diff --git a/slycot/src/MB02CX.f b/slycot/src/MB02CX.f deleted file mode 100644 index be4989cb..00000000 --- a/slycot/src/MB02CX.f +++ /dev/null @@ -1,318 +0,0 @@ - SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To bring the first blocks of a generator in proper form. -C The columns / rows of the positive and negative generators -C are contained in the arrays A and B, respectively. -C Transformation information will be stored and can be applied -C via SLICOT Library routine MB02CY. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'R': A and B are the first blocks of the rows of the -C positive and negative generators; -C = 'C': A and B are the first blocks of the columns of the -C positive and negative generators. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of rows / columns in A containing the positive -C generators. P >= 0. -C -C Q (input) INTEGER -C The number of rows / columns in B containing the negative -C generators. Q >= 0. -C -C K (input) INTEGER -C The number of columns / rows in A and B to be processed. -C Normally, the size of the first block. P >= K >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA, K) / (LDA, P) -C On entry, the leading P-by-K upper / K-by-P lower -C triangular part of this array must contain the rows / -C columns of the positive part in the first block of the -C generator. -C On exit, the leading P-by-K upper / K-by-P lower -C triangular part of this array contains the rows / columns -C of the positive part in the first block of the proper -C generator. -C The lower / upper trapezoidal part is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,P), if TYPET = 'R'; -C LDA >= MAX(1,K), if TYPET = 'C'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB, K) / (LDB, Q) -C On entry, the leading Q-by-K / K-by-Q part of this array -C must contain the rows / columns of the negative part in -C the first block of the generator. -C On exit, the leading Q-by-K / K-by-Q part of this array -C contains part of the necessary information for the -C Householder transformations. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,Q), if TYPET = 'R'; -C LDB >= MAX(1,K), if TYPET = 'C'. -C -C CS (output) DOUBLE PRECISION array, dimension (LCS) -C On exit, the leading 2*K + MIN(K,Q) part of this array -C contains necessary information for the SLICOT Library -C routine MB02CY (modified hyperbolic rotation parameters -C and scalar factors of the Householder transformations). -C -C LCS INTEGER -C The length of the array CS. LCS >= 2*K + MIN(K,Q). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: succesful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The matrix -C associated with the generator is not (numerically) -C positive definite. -C -C METHOD -C -C If TYPET = 'R', a QR decomposition of B is first computed. -C Then, the elements below the first row of each column i of B -C are annihilated by a Householder transformation modifying the -C first element in that column. This first element, in turn, is -C then annihilated by a modified hyperbolic rotation, acting also -C on the i-th row of A. -C -C If TYPET = 'C', an LQ decomposition of B is first computed. -C Then, the elements on the right of the first column of each row i -C of B are annihilated by a Householder transformation modifying the -C first element in that row. This first element, in turn, is -C then annihilated by a modified hyperbolic rotation, acting also -C on the i-th column of A. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2000, -C February 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPET - INTEGER INFO, K, LDA, LDB, LCS, LDWORK, P, Q -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*) -C .. Local Scalars .. - LOGICAL ISROW - INTEGER I, IERR - DOUBLE PRECISION ALPHA, BETA, C, MAXWRK, S, TAU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DGELQF, DGEQRF, DLARF, DLARFG, DSCAL, - $ MA02FD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( P.LT.0 ) THEN - INFO = -2 - ELSE IF ( Q.LT.0 ) THEN - INFO = -3 - ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN - INFO = -4 - ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. - $ ( .NOT.ISROW .AND. LDA.LT.K ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. - $ ( .NOT.ISROW .AND. LDB.LT.K ) ) THEN - INFO = -8 - ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN - INFO = -10 - ELSE IF ( LDWORK.LT.MAX( 1, K ) ) THEN - DWORK(1) = MAX( 1, K ) - INFO = -12 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( Q, K ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - IF ( ISROW ) THEN -C -C The generator is row wise stored. -C -C Step 0: Do QR decomposition of B. -C - CALL DGEQRF ( Q, K, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 10 I = 1, K -C -C Step 1: annihilate the i-th column of B. -C - IF ( Q.GT.1 ) THEN - CALL DLARFG( MIN( I, Q ), B(1,I), B(2,I), 1, TAU ) - ALPHA = B(1,I) - B(1,I) = ONE - IF ( K.GT.I ) - $ CALL DLARF( 'Left', MIN( I, Q ), K-I, B(1,I), 1, TAU, - $ B(1,I+1), LDB, DWORK ) - B(1,I) = ALPHA - ELSE - ALPHA = B(1,I) - TAU = ZERO - END IF -C -C Step 2: annihilate the top entry of the column. -C - BETA = A(I,I) - CALL MA02FD( BETA, ALPHA, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - CS(I*2-1) = C - CS(I*2) = S - CALL DSCAL( K-I+1, ONE/C, A(I,I), LDA ) - CALL DAXPY( K-I+1, -S/C, B(1,I), LDB, A(I,I), LDA ) - CALL DSCAL( K-I+1, C, B(1,I), LDB ) - CALL DAXPY( K-I+1, -S, A(I,I), LDA, B(1,I), LDB ) - B(1,I) = TAU - 10 CONTINUE -C - ELSE -C -C The generator is column wise stored. -C -C Step 0: Do LQ decomposition of B. -C - CALL DGELQF ( K, Q, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 20 I = 1, K -C -C Step 1: annihilate the i-th row of B. -C - IF ( Q.GT.1 ) THEN - CALL DLARFG( MIN( I, Q ), B(I,1), B(I,2), LDB, TAU ) - ALPHA = B(I,1) - B(I,1) = ONE - IF ( K.GT.I ) - $ CALL DLARF( 'Right', K-I, MIN( I, Q ), B(I,1), LDB, - $ TAU, B(I+1,1), LDB, DWORK ) - B(I,1) = ALPHA - ELSE - ALPHA = B(I,1) - TAU = ZERO - END IF -C -C Step 2: annihilate the left entry of the row. -C - BETA = A(I,I) - CALL MA02FD( BETA, ALPHA, C, S, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - CS(I*2-1) = C - CS(I*2) = S - CALL DSCAL( K-I+1, ONE/C, A(I,I), 1 ) - CALL DAXPY( K-I+1, -S/C, B(I,1), 1, A(I,I), 1 ) - CALL DSCAL( K-I+1, C, B(I,1), 1 ) - CALL DAXPY( K-I+1, -S, A(I,I), 1, B(I,1), 1 ) - B(I,1) = TAU - 20 CONTINUE -C - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02CX *** - END diff --git a/slycot/src/MB02CY.f b/slycot/src/MB02CY.f deleted file mode 100644 index 7d977dee..00000000 --- a/slycot/src/MB02CY.f +++ /dev/null @@ -1,372 +0,0 @@ - SUBROUTINE MB02CY( TYPET, STRUCG, P, Q, N, K, A, LDA, B, LDB, H, - $ LDH, CS, LCS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the transformations created by the SLICOT Library -C routine MB02CX on other columns / rows of the generator, -C contained in the arrays A and B of positive and negative -C generators, respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of the generator, as follows: -C = 'R': A and B are additional columns of the generator; -C = 'C': A and B are additional rows of the generator. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C STRUCG CHARACTER*1 -C Information about the structure of the two generators, -C as follows: -C = 'T': the trailing block of the positive generator -C is lower / upper triangular, and the trailing -C block of the negative generator is zero; -C = 'N': no special structure to mention. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of rows / columns in A containing the positive -C generators. P >= 0. -C -C Q (input) INTEGER -C The number of rows / columns in B containing the negative -C generators. Q >= 0. -C -C N (input) INTEGER -C The number of columns / rows in A and B to be processed. -C N >= 0. -C -C K (input) INTEGER -C The number of columns / rows in H. P >= K >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA, N) / (LDA, P) -C On entry, the leading P-by-N / N-by-P part of this array -C must contain the positive part of the generator. -C On exit, the leading P-by-N / N-by-P part of this array -C contains the transformed positive part of the generator. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,P), if TYPET = 'R'; -C LDA >= MAX(1,N), if TYPET = 'C'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB, N) / (LDB, Q) -C On entry, the leading Q-by-N / N-by-Q part of this array -C must contain the negative part of the generator. -C On exit, the leading Q-by-N / N-by-Q part of this array -C contains the transformed negative part of the generator. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,Q), if TYPET = 'R'; -C LDB >= MAX(1,N), if TYPET = 'C'. -C -C H (input) DOUBLE PRECISION array, dimension -C (LDH, K) / (LDH, Q) -C The leading Q-by-K / K-by-Q part of this array must -C contain part of the necessary information for the -C Householder transformations computed by SLICOT Library -C routine MB02CX. -C -C LDH INTEGER -C The leading dimension of the array H. -C LDH >= MAX(1,Q), if TYPET = 'R'; -C LDH >= MAX(1,K), if TYPET = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (LCS) -C The leading 2*K + MIN(K,Q) part of this array must -C contain the necessary information for modified hyperbolic -C rotations and the scalar factors of the Householder -C transformations computed by SLICOT Library routine MB02CX. -C -C LCS INTEGER -C The length of the array CS. LCS >= 2*K + MIN(K,Q). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: succesful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder transformations and modified hyperbolic rotations -C computed by SLICOT Library routine MB02CX are applied to the -C corresponding parts of the matrices A and B. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2000, -C February 2004, March 2007. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K, LDA, LDB, LCS, LDH, LDWORK, N, P, Q - CHARACTER STRUCG, TYPET -C .. Array Arguments .. - DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*), H(LDH,*) -C .. Local Scalars .. - LOGICAL ISLWR, ISROW - INTEGER I, IERR, CI, MAXWRK - DOUBLE PRECISION C, S, TAU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLARF, DLASET, DORMLQ, DORMQR, DSCAL, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) - ISLWR = LSAME( STRUCG, 'T' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( ISLWR .OR. LSAME( STRUCG, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( P.LT.0 ) THEN - INFO = -3 - ELSE IF ( Q.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN - INFO = -6 - ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. - $ ( .NOT.ISROW .AND. LDA.LT.N ) ) THEN - INFO = -8 - ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. - $ ( .NOT.ISROW .AND. LDB.LT.N ) ) THEN - INFO = -10 - ELSE IF ( LDH.LT.1 .OR. ( ISROW .AND. LDH.LT.Q ) .OR. - $ ( .NOT.ISROW .AND. LDH.LT.K ) ) THEN - INFO = -12 - ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = MAX( 1, N ) - INFO = -16 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02CY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( N, K, Q ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Applying the transformations. -C - IF ( ISROW ) THEN -C -C The generator is row wise stored. -C - IF ( ISLWR ) THEN -C - DO 10 I = 1, K -C -C Apply Householder transformation avoiding touching of -C zero blocks. -C - CI = N - K + I - 1 - TAU = H(1,I) - H(1,I) = ONE - CALL DLARF( 'Left', MIN( I, Q ), CI, H(1,I), 1, TAU, B, - $ LDB, DWORK ) - H(1,I) = TAU -C -C Now apply the hyperbolic rotation under the assumption -C that A(I, N-K+I+1:N) and B(1, N-K+I:N) are zero. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( CI, ONE/C, A(I,1), LDA ) - CALL DAXPY( CI, -S/C, B(1,1), LDB, A(I,1), LDA ) - CALL DSCAL( CI, C, B(1,1), LDB ) - CALL DAXPY( CI, -S, A(I,1), LDA, B(1,1), LDB ) -C - B(1,N-K+I) = -S/C * A(I,N-K+I) - A(I,N-K+I) = ONE/C * A(I,N-K+I) -C -C All below B(1,N-K+I) should be zero. -C - IF( Q.GT.1 ) - $ CALL DLASET( 'All', Q-1, 1, ZERO, ZERO, B(2,N-K+I), - $ 1 ) - 10 CONTINUE -C - ELSE -C -C Apply the QR reduction on B. -C - CALL DORMQR( 'Left', 'Transpose', Q, N, MIN( K, Q ), H, - $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 20 I = 1, K -C -C Apply Householder transformation. -C - TAU = H(1,I) - H(1,I) = ONE - CALL DLARF( 'Left', MIN( I, Q ), N, H(1,I), 1, TAU, B, - $ LDB, DWORK ) - H(1,I) = TAU -C -C Apply Hyperbolic Rotation. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( N, ONE/C, A(I,1), LDA ) - CALL DAXPY( N, -S/C, B(1,1), LDB, A(I,1), LDA ) - CALL DSCAL( N, C, B(1,1), LDB ) - CALL DAXPY( N, -S, A(I,1), LDA, B(1,1), LDB ) - 20 CONTINUE -C - END IF -C - ELSE -C -C The generator is column wise stored. -C - IF ( ISLWR ) THEN -C - DO 30 I = 1, K -C -C Apply Householder transformation avoiding touching zeros. -C - CI = N - K + I - 1 - TAU = H(I,1) - H(I,1) = ONE - CALL DLARF( 'Right', CI, MIN( I, Q ), H(I,1), LDH, TAU, - $ B, LDB, DWORK ) - H(I,1) = TAU -C -C Apply Hyperbolic Rotation. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( CI, ONE/C, A(1,I), 1 ) - CALL DAXPY( CI, -S/C, B(1,1), 1, A(1,I), 1 ) - CALL DSCAL( CI, C, B(1,1), 1 ) - CALL DAXPY( CI, -S, A(1,I), 1, B(1,1), 1 ) -C - B(N-K+I,1) = -S/C * A(N-K+I,I) - A(N-K+I,I) = ONE/C * A(N-K+I,I) -C -C All elements right behind B(N-K+I,1) should be zero. -C - IF( Q.GT.1 ) - $ CALL DLASET( 'All', 1, Q-1, ZERO, ZERO, B(N-K+I,2), - $ LDB ) - 30 CONTINUE -C - ELSE -C -C Apply the LQ reduction on B. -C - CALL DORMLQ( 'Right', 'Transpose', N, Q, MIN( K, Q ), H, - $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) - MAXWRK = DWORK(1) -C - DO 40 I = 1, K -C -C Apply Householder transformation. -C - TAU = H(I,1) - H(I,1) = ONE - CALL DLARF( 'Right', N, MIN( I, Q ), H(I,1), LDH, TAU, B, - $ LDB, DWORK ) - H(I,1) = TAU -C -C Apply Hyperbolic Rotation. -C - C = CS(I*2-1) - S = CS(I*2) -C - CALL DSCAL( N, ONE/C, A(1,I), 1 ) - CALL DAXPY( N, -S/C, B(1,1), 1, A(1,I), 1 ) - CALL DSCAL( N, C, B(1,1), 1 ) - CALL DAXPY( N, -S, A(1,I), 1, B(1,1), 1 ) - 40 CONTINUE -C - END IF -C - END IF -C - DWORK(1) = MAX( MAXWRK, N ) -C - RETURN -C -C *** Last line of MB02CY *** - END diff --git a/slycot/src/MB02DD.f b/slycot/src/MB02DD.f deleted file mode 100644 index fadd6b44..00000000 --- a/slycot/src/MB02DD.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G, - $ LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To update the Cholesky factor and the generator and/or the -C Cholesky factor of the inverse of a symmetric positive definite -C (s.p.d.) block Toeplitz matrix T, given the information from -C a previous factorization and additional blocks in TA of its first -C block row, or its first block column, depending on the routine -C parameter TYPET. Transformation information is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine, as follows: -C = 'R': updates the generator G of the inverse and -C computes the new columns / rows for the Cholesky -C factor R of T; -C = 'A': updates the generator G, computes the new -C columns / rows for the Cholesky factor R of T and -C the new rows / columns for the Cholesky factor L -C of the inverse; -C = 'O': only computes the new columns / rows for the -C Cholesky factor R of T. -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': the first block row of an s.p.d. block Toeplitz -C matrix was/is defined; if demanded, the Cholesky -C factors R and L are upper and lower triangular, -C respectively, and G contains the transposed -C generator of the inverse; -C = 'C': the first block column of an s.p.d. block Toeplitz -C matrix was/is defined; if demanded, the Cholesky -C factors R and L are lower and upper triangular, -C respectively, and G contains the generator of the -C inverse. This choice results in a column oriented -C algorithm which is usually faster. -C Note: in this routine, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C M (input) INTEGER -C The number of blocks in TA. M >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C TA (input/output) DOUBLE PRECISION array, dimension -C (LDTA,M*K) / (LDTA,K) -C On entry, the leading K-by-M*K / M*K-by-K part of this -C array must contain the (N+1)-th to (N+M)-th blocks in the -C first block row / column of an s.p.d. block Toeplitz -C matrix. -C On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part -C of this array contains information on the Householder -C transformations used, such that the array -C -C [ T TA ] / [ T ] -C [ TA ] -C -C serves as the new transformation matrix T for further -C applications of this routine. -C -C LDTA INTEGER -C The leading dimension of the array TA. -C LDTA >= MAX(1,K), if TYPET = 'R'; -C LDTA >= MAX(1,M*K), if TYPET = 'C'. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N*K) / -C (LDT,K) -C The leading K-by-N*K / N*K-by-K part of this array must -C contain transformation information generated by the SLICOT -C Library routine MB02CD, i.e., in the first K-by-K block, -C the upper / lower Cholesky factor of T(1:K,1:K), and in -C the remaining part, the Householder transformations -C applied during the initial factorization process. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,N*K), if TYPET = 'C'. -C -C G (input/output) DOUBLE PRECISION array, dimension -C (LDG,( N + M )*K) / (LDG,2*K) -C On entry, if JOB = 'R', or 'A', then the leading -C 2*K-by-N*K / N*K-by-2*K part of this array must contain, -C in the first K-by-K block of the second block row / -C column, the lower right block of the Cholesky factor of -C the inverse of T, and in the remaining part, the generator -C of the inverse of T. -C On exit, if INFO = 0 and JOB = 'R', or 'A', then the -C leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of -C this array contains the same information as on entry, now -C for the updated Toeplitz matrix. Actually, to obtain a -C generator of the inverse one has to set -C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; -C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. -C -C LDG INTEGER -C The leading dimension of the array G. -C LDG >= MAX(1,2*K), if TYPET = 'R' and JOB = 'R', or 'A'; -C LDG >= MAX(1,( N + M )*K), -C if TYPET = 'C' and JOB = 'R', or 'A'; -C LDG >= 1, if JOB = 'O'. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR,M*K) / (LDR,( N + M )*K) -C On input, the leading N*K-by-K part of R(K+1,1) / -C K-by-N*K part of R(1,K+1) contains the last block column / -C row of the previous Cholesky factor R. -C On exit, if INFO = 0, then the leading -C ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this -C array contains the last M*K columns / rows of the upper / -C lower Cholesky factor of T. The elements in the strictly -C lower / upper triangular part are not referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1, ( N + M )*K), if TYPET = 'R'; -C LDR >= MAX(1, M*K), if TYPET = 'C'. -C -C L (output) DOUBLE PRECISION array, dimension -C (LDL,( N + M )*K) / (LDL,M*K) -C If INFO = 0 and JOB = 'A', then the leading -C M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this -C array contains the last M*K rows / columns of the lower / -C upper Cholesky factor of the inverse of T. The elements -C in the strictly upper / lower triangular part are not -C referenced. -C -C LDL INTEGER -C The leading dimension of the array L. -C LDL >= MAX(1, M*K), if TYPET = 'R' and JOB = 'A'; -C LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A'; -C LDL >= 1, if JOB = 'R', or 'O'. -C -C CS (input/output) DOUBLE PRECISION array, dimension (LCS) -C On input, the leading 3*(N-1)*K part of this array must -C contain the necessary information about the hyperbolic -C rotations and Householder transformations applied -C previously by SLICOT Library routine MB02CD. -C On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of -C this array contains information about all the hyperbolic -C rotations and Householder transformations applied during -C the whole process. -C -C LCS INTEGER -C The length of the array CS. LCS >= 3*(N+M-1)*K. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,(N+M-1)*K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The block Toeplitz -C matrix associated with [ T TA ] / [ T' TA' ]' is -C not (numerically) positive definite. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 2 -C The algorithm requires 0(K ( N M + M ) ) floating point -C operations. -C -C FURTHER COMMENTS -C -C For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns. -C Although the calculations could still be performed when N = 0, -C but min(K,M) > 0, this case is not considered as an "update". -C SLICOT Library routine MB02CD should be called with the argument -C M instead of N. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Feb. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB, TYPET - INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK, - $ M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), - $ T(LDT,*), TA(LDTA,*) -C .. Local Scalars .. - INTEGER I, IERR, J, MAXWRK, STARTI, STARTR, STARTT - LOGICAL COMPG, COMPL, ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPL = LSAME( JOB, 'A' ) - COMPG = LSAME( JOB, 'R' ) .OR. COMPL - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN - INFO = -7 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN - INFO = -9 - ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) - $ .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) ) - $ .OR. LDG.LT.1 ) THEN - INFO = -11 - ELSE IF ( ( ( ISROW .AND. LDR.LT.( N + M )*K ) .OR. - $ ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR. - $ LDR.LT.1 ) THEN - INFO = -13 - ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K ) - $ .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) ) - $ .OR. LDL.LT.1 ) THEN - INFO = -15 - ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN - INFO = -17 - ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN - DWORK(1) = MAX( 1, ( N + M - 1 )*K ) - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N, M ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 1 - IF ( ISROW ) THEN -C -C Apply Cholesky factor of T(1:K, 1:K) on TA. -C - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K, - $ ONE, T, LDT, TA, LDTA ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG ) - IF ( M.GE.N-1 .AND. N.GT.1 ) THEN - CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG, - $ G(K+1,K*(M+1)+1), LDG ) - ELSE - DO 10 I = N*K, K + 1, -1 - CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 ) - 10 CONTINUE - END IF - CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG ) - END IF -C - CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR ) -C -C Apply the stored transformations on the new columns. -C - DO 20 I = 2, N -C -C Copy the last M-1 blocks of the positive generator together; -C the last M blocks of the negative generator are contained -C in TA. -C - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, - $ R(STARTR,K+1), LDR ) -C -C Apply the transformations stored in T on the generator. -C - CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K, - $ R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - 20 CONTINUE -C -C Now, we have "normality" and can apply further M Schur steps. -C - DO 30 I = 1, M -C -C Copy the first M-I+1 blocks of the positive generator -C together; the first M-I+1 blocks of the negative generator -C are contained in TA. -C - STARTT = 3*( N + I - 2 )*K + 1 - STARTI = ( M - I + 1 )*K + 1 - STARTR = ( N + I - 1 )*K + 1 - IF ( I.EQ.1 ) THEN - CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, - $ R(STARTR,K+1), LDR ) - ELSE - CALL DLACPY( 'Upper', K, (M-I+1)*K, - $ R(STARTR-K,(I-2)*K+1), LDR, - $ R(STARTR,(I-1)*K+1), LDR ) - END IF -C -C Reduce the generator to proper form. -C - CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR, - $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( M.GT.I ) THEN - CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K, - $ R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA, - $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPG ) THEN -C -C Transformations acting on the inverse generator: -C - CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), - $ LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1), - $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K, - $ G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1), - $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG, - $ L((I-1)*K+1,1), LDL ) - CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, - $ L((I-1)*K+1,STARTR), LDL ) - END IF -C - END IF - 30 CONTINUE -C - ELSE -C -C Apply Cholesky factor of T(1:K, 1:K) on TA. -C - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K, - $ ONE, T, LDT, TA, LDTA ) -C -C Initialize the output matrices. -C - IF ( COMPG ) THEN - CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG ) - IF ( M.GE.N-1 .AND. N.GT.1 ) THEN - CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG, - $ G(K*(M+1)+1,K+1), LDG ) - ELSE - DO 40 I = 1, K - DO 35 J = N*K, K + 1, -1 - G(J+M*K,K+I) = G(J,K+I) - 35 CONTINUE - 40 CONTINUE - END IF - CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG ) - END IF -C - CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR ) -C -C Apply the stored transformations on the new rows. -C - DO 50 I = 2, N -C -C Copy the last M-1 blocks of the positive generator together; -C the last M blocks of the negative generator are contained -C in TA. -C - STARTR = ( I - 1 )*K + 1 - STARTT = 3*( I - 2 )*K + 1 - CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, - $ R(K+1,STARTR), LDR ) -C -C Apply the transformations stored in T on the generator. -C - CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K, - $ R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT, - $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - 50 CONTINUE -C -C Now, we have "normality" and can apply further M Schur steps. -C - DO 60 I = 1, M -C -C Copy the first M-I+1 blocks of the positive generator -C together; the first M-I+1 blocks of the negative generator -C are contained in TA. -C - STARTT = 3*( N + I - 2 )*K + 1 - STARTI = ( M - I + 1 )*K + 1 - STARTR = ( N + I - 1 )*K + 1 - IF ( I.EQ.1 ) THEN - CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, - $ R(K+1,STARTR), LDR ) - ELSE - CALL DLACPY( 'Lower', (M-I+1)*K, K, - $ R((I-2)*K+1,STARTR-K), LDR, - $ R((I-1)*K+1,STARTR), LDR ) - END IF -C -C Reduce the generator to proper form. -C - CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR, - $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK, - $ LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - IF ( M.GT.I ) THEN - CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K, - $ R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA, - $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C - IF ( COMPG ) THEN -C -C Transformations acting on the inverse generator: -C - CALL MB02CY( 'Column', 'Triangular', K, K, K, K, - $ G(1,K+1), LDG, G(STARTR,1), LDG, - $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, - $ DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K, - $ G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1), - $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) -C - IF ( COMPL ) THEN - CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG, - $ L(1,(I-1)*K+1), LDL ) - CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, - $ L(STARTR,(I-1)*K+1), LDL ) - END IF -C - END IF - 60 CONTINUE -C - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02DD *** - END diff --git a/slycot/src/MB02ED.f b/slycot/src/MB02ED.f deleted file mode 100644 index d5c366cb..00000000 --- a/slycot/src/MB02ED.f +++ /dev/null @@ -1,445 +0,0 @@ - SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of linear equations T*X = B or X*T = B with -C a symmetric positive definite (s.p.d.) block Toeplitz matrix T. -C T is defined either by its first block row or its first block -C column, depending on the parameter TYPET. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix, and the system X*T = B is solved; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix, and the system T*X = B is -C solved. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides. NRHS >= 0. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N*K) / (LDT,K) -C On entry, the leading K-by-N*K / N*K-by-K part of this -C array must contain the first block row / column of an -C s.p.d. block Toeplitz matrix. -C On exit, if INFO = 0 and NRHS > 0, then the leading -C K-by-N*K / N*K-by-K part of this array contains the last -C row / column of the Cholesky factor of inv(T). -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,N*K), if TYPET = 'C'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,N*K) / (LDB,NRHS) -C On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of -C this array must contain the right hand side matrix B. -C On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of -C this array contains the solution matrix X. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,NRHS), if TYPET = 'R'; -C LDB >= MAX(1,N*K), if TYPET = 'C'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,N*K*K+(N+2)*K). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is not (numerically) positive -C definite. -C -C METHOD -C -C Householder transformations, modified hyperbolic rotations and -C block Gaussian eliminations are used in the Schur algorithm [1], -C [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically equivalent with forming -C the Cholesky factor R and the inverse Cholesky factor of T, using -C the generalized Schur algorithm, and solving the systems of -C equations R*X = L*B or X*R = B*L by a blocked backward -C substitution algorithm. -C 3 2 2 2 -C The algorithm requires 0(K N + K N NRHS) floating point -C operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C February 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPET - INTEGER INFO, K, LDB, LDT, LDWORK, N, NRHS -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), T(LDT,*) -C .. Local Scalars .. - INTEGER I, IERR, MAXWRK, STARTH, STARTI, STARTN, - $ STARTR, STARTT - LOGICAL ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DPOTRF, DTRMM, DTRSM, - $ MB02CX, MB02CY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.NRHS ) .OR. - $ ( .NOT.ISROW .AND. LDB.LT.N*K ) ) THEN - INFO = -8 - ELSE IF ( LDWORK.LT.MAX( 1, N*K*K + ( N + 2 )*K ) ) THEN - DWORK(1) = MAX( 1, N*K*K + ( N + 2 )*K ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N, NRHS ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 0 - STARTN = 1 - STARTT = N*K*K + 1 - STARTH = STARTT + 3*K -C - IF ( ISROW ) THEN -C -C T is the first block row of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) -C -C Initialize the generator, do the first Schur step and set -C B = -B. -C T contains the nonzero blocks of the positive parts in the -C generator and the inverse generator. -C DWORK(STARTN) contains the nonzero blocks of the negative parts -C in the generator and the inverse generator. -C - CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', NRHS, - $ K, ONE, T, LDT, B, LDB ) - IF ( N.GT.1 ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (N-1)*K, - $ K, ONE, B, LDB, T(1,K+1), LDT, -ONE, B(1,K+1), - $ LDB ) -C - CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), K ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, DWORK(STARTN), K ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'All', K, (N-1)*K, T(1,K+1), LDT, - $ DWORK(STARTN+K*K), K ) - CALL DLACPY( 'All', K, K, DWORK(STARTN), K, T(1,(N-1)*K+1), - $ LDT ) -C - CALL DTRMM ( 'Right', 'Lower', 'NonTranspose', 'NonUnit', NRHS, - $ K, ONE, T(1,(N-1)*K+1), LDT, B, LDB ) -C -C Processing the generator. -C - DO 10 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I )*K + 1 -C -C Transform the generator of T to proper form. -C - CALL MB02CX( 'Row', K, K, K, T, LDT, - $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) - CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, - $ T(1,K+1), LDT, DWORK(STARTN+I*K*K), K, - $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Block Gaussian eliminates the i-th block in B. -C - CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', - $ NRHS, K, -ONE, T, LDT, B(1,STARTR), LDB ) - IF ( N.GT.I ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, - $ (N-I)*K, K, ONE, B(1,STARTR), LDB, T(1,K+1), - $ LDT, ONE, B(1,STARTR+K), LDB ) -C -C Apply hyperbolic transformations on the negative generator. -C - CALL DLASET( 'All', K, K, ZERO, ZERO, T(1,STARTI), LDT ) - CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, - $ T(1,STARTI), LDT, DWORK(STARTN), K, - $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Note that DWORK(STARTN+(I-1)*K*K) serves simultaneously -C as the transformation container as well as the new block in -C the negative generator. -C - CALL MB02CY( 'Row', 'Triangular', K, K, K, K, - $ T(1,(N-1)*K+1), LDT, DWORK(STARTN+(I-1)*K*K), - $ K, DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Finally the Gaussian elimination is applied on the inverse -C generator. -C - CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (I-1)*K, - $ K, ONE, B(1,STARTR), LDB, T(1,STARTI), LDT, ONE, - $ B, LDB ) - CALL DTRMM( 'Right', 'Lower', 'NonTranspose', 'NonUnit', - $ NRHS, K, ONE, T(1,(N-1)*K+1), LDT, B(1,STARTR), - $ LDB ) - 10 CONTINUE -C - ELSE -C -C T is the first block column of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) -C -C Initialize the generator, do the first Schur step and set -C B = -B. -C T contains the nonzero blocks of the positive parts in the -C generator and the inverse generator. -C DWORK(STARTN) contains the nonzero blocks of the negative parts -C in the generator and the inverse generator. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, - $ NRHS, ONE, T, LDT, B, LDB ) - IF ( N.GT.1 ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-1)*K, NRHS, - $ K, ONE, T(K+1,1), LDT, B, LDB, -ONE, B(K+1,1), - $ LDB ) -C - CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), N*K ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, - $ ONE, T, LDT, DWORK(STARTN), N*K ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'All', (N-1)*K, K, T(K+1,1), LDT, - $ DWORK(STARTN+K), N*K ) - CALL DLACPY( 'All', K, K, DWORK(STARTN), N*K, T((N-1)*K+1,1), - $ LDT ) -C - CALL DTRMM ( 'Left', 'Upper', 'NonTranspose', 'NonUnit', K, - $ NRHS, ONE, T((N-1)*K+1,1), LDT, B, LDB ) -C -C Processing the generator. -C - DO 20 I = 2, N - STARTR = ( I - 1 )*K + 1 - STARTI = ( N - I )*K + 1 -C -C Transform the generator of T to proper form. -C - CALL MB02CX( 'Column', K, K, K, T, LDT, - $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) - CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, K, - $ T(K+1,1), LDT, DWORK(STARTN+I*K), N*K, - $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Block Gaussian eliminates the i-th block in B. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, - $ NRHS, -ONE, T, LDT, B(STARTR,1), LDB ) - IF ( N.GT.I ) - $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-I)*K, - $ NRHS, K, ONE, T(K+1,1), LDT, B(STARTR,1), - $ LDB, ONE, B(STARTR+K,1), LDB ) -C -C Apply hyperbolic transformations on the negative generator. -C - CALL DLASET( 'All', K, K, ZERO, ZERO, T(STARTI,1), LDT ) - CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, - $ T(STARTI,1), LDT, DWORK(STARTN), N*K, - $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, - $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Note that DWORK(STARTN+(I-1)*K) serves simultaneously -C as the transformation container as well as the new block in -C the negative generator. -C - CALL MB02CY( 'Column', 'Triangular', K, K, K, K, - $ T((N-1)*K+1,1), LDT, DWORK(STARTN+(I-1)*K), - $ N*K, DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), - $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) -C -C Finally the Gaussian elimination is applied on the inverse -C generator. -C - CALL DGEMM( 'NonTranspose', 'NonTranspose', (I-1)*K, NRHS, - $ K, ONE, T(STARTI,1), LDT, B(STARTR,1), LDB, ONE, - $ B, LDB ) - CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', - $ K, NRHS, ONE, T((N-1)*K+1,1), LDT, B(STARTR,1), - $ LDB ) -C - 20 CONTINUE -C - END IF -C - DWORK(1) = MAX( 1, STARTH - 1 + MAXWRK ) -C - RETURN -C -C *** Last line of MB02ED *** - END diff --git a/slycot/src/MB02FD.f b/slycot/src/MB02FD.f deleted file mode 100644 index 0e608a83..00000000 --- a/slycot/src/MB02FD.f +++ /dev/null @@ -1,383 +0,0 @@ - SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the incomplete Cholesky (ICC) factor of a symmetric -C positive definite (s.p.d.) block Toeplitz matrix T, defined by -C either its first block row, or its first block column, depending -C on the routine parameter TYPET. -C -C By subsequent calls of this routine, further rows / columns of -C the Cholesky factor can be added. -C Furthermore, the generator of the Schur complement of the leading -C (P+S)*K-by-(P+S)*K block in T is available, which can be used, -C e.g., for measuring the quality of the ICC factorization. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix; the ICC factor R is upper -C trapezoidal; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix; the ICC factor R is lower -C trapezoidal; this choice leads to better -C localized memory references and hence a faster -C algorithm. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 0. -C -C P (input) INTEGER -C The number of previously computed block rows / columns -C of R. 0 <= P <= N. -C -C S (input) INTEGER -C The number of block rows / columns of R to compute. -C 0 <= S <= N-P. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,(N-P)*K) / (LDT,K) -C On entry, if P = 0, then the leading K-by-N*K / N*K-by-K -C part of this array must contain the first block row / -C column of an s.p.d. block Toeplitz matrix. -C If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must -C contain the negative generator of the Schur complement of -C the leading P*K-by-P*K part in T, computed from previous -C calls of this routine. -C On exit, if INFO = 0, then the leading K-by-(N-P)*K / -C (N-P)*K-by-K part of this array contains, in the first -C K-by-K block, the upper / lower Cholesky factor of -C T(1:K,1:K), in the following S-1 K-by-K blocks, the -C Householder transformations applied during the process, -C and in the remaining part, the negative generator of the -C Schur complement of the leading (P+S)*K-by(P+S)*K part -C in T. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K), if TYPET = 'R'; -C LDT >= MAX(1,(N-P)*K), if TYPET = 'C'. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR, N*K) / (LDR, S*K ) if P = 0; -C (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0. -C On entry, if P > 0, then the leading K-by-(N-P+1)*K / -C (N-P+1)*K-by-K part of this array must contain the -C nonzero blocks of the last block row / column in the -C ICC factor from a previous call of this routine. Note that -C this part is identical with the positive generator of -C the Schur complement of the leading P*K-by-P*K part in T. -C If P = 0, then R is only an output parameter. -C On exit, if INFO = 0 and P = 0, then the leading -C S*K-by-N*K / N*K-by-S*K part of this array contains the -C upper / lower trapezoidal ICC factor. -C On exit, if INFO = 0 and P > 0, then the leading -C (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this -C array contains the upper / lower trapezoidal part of the -C P-th to (P+S)-th block rows / columns of the ICC factor. -C The elements in the strictly lower / upper trapezoidal -C part are not referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1, S*K ), if TYPET = 'R' and P = 0; -C LDR >= MAX(1, (S+1)*K ), if TYPET = 'R' and P > 0; -C LDR >= MAX(1, N*K ), if TYPET = 'C' and P = 0; -C LDR >= MAX(1, (N-P+1)*K ), if TYPET = 'C' and P > 0. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -11, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,(N+1)*K,4*K), if P = 0; -C LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed; the Toeplitz matrix -C associated with T is not (numerically) positive -C definite in its leading (P+S)*K-by-(P+S)*K part. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 -C The algorithm requires 0(K S (N-P)) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, April 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, -C Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TYPET - INTEGER INFO, K, LDR, LDT, LDWORK, N, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), R(LDR,*), T(LDT,*) -C .. Local Scalars .. - INTEGER COUNTR, I, IERR, MAXWRK, ST, STARTR - LOGICAL ISROW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DPOTRF, DTRSM, MB02CX, MB02CY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - ISROW = LSAME( TYPET, 'R' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN - INFO = -4 - ELSE IF ( S.LT.0 .OR. S.GT.( N-P ) ) THEN - INFO = -5 - ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.( N-P )*K ) ) THEN - INFO = -7 - ELSE IF ( LDR.LT.1 .OR. - $ ( ISROW .AND. P.EQ.0 .AND. ( LDR.LT.S*K ) ) .OR. - $ ( ISROW .AND. P.GT.0 .AND. ( LDR.LT.( S+1 )*K ) ) .OR. - $ ( .NOT.ISROW .AND. P.EQ.0 .AND. ( LDR.LT.N*K ) ) .OR. - $ ( .NOT.ISROW .AND. P.GT.0 .AND. ( LDR.LT.( N-P+1 )*K ) ) ) THEN - INFO = -9 - ELSE - IF ( P.EQ.0 ) THEN - COUNTR = ( N + 1 )*K - ELSE - COUNTR = ( N - P + 2 )*K - END IF - COUNTR = MAX( COUNTR, 4*K ) - IF ( LDWORK.LT.MAX( 1, COUNTR ) ) THEN - DWORK(1) = MAX( 1, COUNTR ) - INFO = -11 - END IF - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, N, S ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - MAXWRK = 1 -C - IF ( ISROW ) THEN -C - IF ( P.EQ.0 ) THEN -C -C T is the first block row of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) - CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) -C - IF ( S.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ST = 2 - COUNTR = ( N - 1 )*K - ELSE - ST = 1 - COUNTR = ( N - P )*K - END IF -C - STARTR = 1 -C - DO 10 I = ST, S - CALL DLACPY( 'Upper', K, COUNTR, R(STARTR,STARTR), LDR, - $ R(STARTR+K,STARTR+K), LDR ) - STARTR = STARTR + K - COUNTR = COUNTR - K - CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, - $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - CALL MB02CY( 'Row', 'NoStructure', K, K, COUNTR, K, - $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), LDT, - $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - 10 CONTINUE -C - ELSE -C - IF ( P.EQ.0 ) THEN -C -C T is the first block column of a block Toeplitz matrix. -C Bring T to proper form by triangularizing its first block. -C - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - IF ( N.GT.1 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) - CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) -C - IF ( S.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ST = 2 - COUNTR = ( N - 1 )*K - ELSE - ST = 1 - COUNTR = ( N - P )*K - END IF -C - STARTR = 1 -C - DO 20 I = ST, S - CALL DLACPY( 'Lower', COUNTR, K, R(STARTR,STARTR), LDR, - $ R(STARTR+K,STARTR+K), LDR ) - STARTR = STARTR + K - COUNTR = COUNTR - K - CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, - $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF -C - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - CALL MB02CY( 'Column', 'NoStructure', K, K, COUNTR, K, - $ R(STARTR+K,STARTR), LDR, T(STARTR+K,1), LDT, - $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), - $ LDWORK-3*K, IERR ) - MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) - 20 CONTINUE -C - END IF -C - DWORK(1) = MAXWRK -C - RETURN -C -C *** Last line of MB02FD *** - END diff --git a/slycot/src/MB02GD.f b/slycot/src/MB02GD.f deleted file mode 100644 index c227a556..00000000 --- a/slycot/src/MB02GD.f +++ /dev/null @@ -1,558 +0,0 @@ - SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor of a banded symmetric positive -C definite (s.p.d.) block Toeplitz matrix, defined by either its -C first block row, or its first block column, depending on the -C routine parameter TYPET. -C -C By subsequent calls of this routine the Cholesky factor can be -C computed block column by block column. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPET CHARACTER*1 -C Specifies the type of T, as follows: -C = 'R': T contains the first block row of an s.p.d. block -C Toeplitz matrix; the Cholesky factor is upper -C triangular; -C = 'C': T contains the first block column of an s.p.d. -C block Toeplitz matrix; the Cholesky factor is -C lower triangular. This choice results in a column -C oriented algorithm which is usually faster. -C Note: in the sequel, the notation x / y means that -C x corresponds to TYPET = 'R' and y corresponds to -C TYPET = 'C'. -C -C TRIU CHARACTER*1 -C Specifies the structure of the last block in T, as -C follows: -C = 'N': the last block has no special structure; -C = 'T': the last block is lower / upper triangular. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows / columns in T, which should be equal -C to the blocksize. K >= 0. -C -C N (input) INTEGER -C The number of blocks in T. N >= 1. -C If TRIU = 'N', N >= 1; -C if TRIU = 'T', N >= 2. -C -C NL (input) INTEGER -C The lower block bandwidth, i.e., NL + 1 is the number of -C nonzero blocks in the first block column of the block -C Toeplitz matrix. -C If TRIU = 'N', 0 <= NL < N; -C if TRIU = 'T', 1 <= NL < N. -C -C P (input) INTEGER -C The number of previously computed block rows / columns of -C the Cholesky factor. 0 <= P <= N. -C -C S (input) INTEGER -C The number of block rows / columns of the Cholesky factor -C to compute. 0 <= S <= N - P. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,(NL+1)*K) / (LDT,K) -C On entry, if P = 0, the leading K-by-(NL+1)*K / -C (NL+1)*K-by-K part of this array must contain the first -C block row / column of an s.p.d. block Toeplitz matrix. -C On entry, if P > 0, the leading K-by-(NL+1)*K / -C (NL+1)*K-by-K part of this array must contain the P-th -C block row / column of the Cholesky factor. -C On exit, if INFO = 0, then the leading K-by-(NL+1)*K / -C (NL+1)*K-by-K part of this array contains the (P+S)-th -C block row / column of the Cholesky factor. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= MAX(1,K) / MAX(1,(NL+1)*K). -C -C RB (input/output) DOUBLE PRECISION array, dimension -C (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K) -C On entry, if TYPET = 'R' and TRIU = 'N' and P > 0, -C the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array -C must contain the (P*K+1)-st to ((P+NL)*K)-th columns -C of the upper Cholesky factor in banded format from a -C previous call of this routine. -C On entry, if TYPET = 'R' and TRIU = 'T' and P > 0, -C the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array -C must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns -C of the upper Cholesky factor in banded format from a -C previous call of this routine. -C On exit, if TYPET = 'R' and TRIU = 'N', the leading -C (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the -C upper Cholesky factor in banded format. -C On exit, if TYPET = 'R' and TRIU = 'T', the leading -C (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the -C upper Cholesky factor in banded format. -C On exit, if TYPET = 'C' and TRIU = 'N', the leading -C (NL+1)*K-by-MIN(S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower -C Cholesky factor in banded format. -C On exit, if TYPET = 'C' and TRIU = 'T', the leading -C (NL*K+1)-by-MIN(S,N-P)*K part of this array contains -C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower -C Cholesky factor in banded format. -C For further details regarding the band storage scheme see -C the documentation of the LAPACK routine DPBTF2. -C -C LDRB INTEGER -C The leading dimension of the array RB. -C If TRIU = 'N', LDRB >= MAX( (NL+1)*K,1 ); -C if TRIU = 'T', LDRB >= NL*K+1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -13, DWORK(1) returns the minimum -C value of LDWORK. -C The first 1 + ( NL + 1 )*K*K elements of DWORK should be -C preserved during successive calls of the routine. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 + ( NL + 1 )*K*K + NL*K. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is not (numerically) positive -C definite. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C 3 -C The algorithm requires O( K *N*NL ) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRIU, TYPET - INTEGER INFO, K, LDRB, LDT, LDWORK, N, NL, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), T(LDT,*) -C .. Local Scalars .. - CHARACTER STRUCT - LOGICAL ISROW, LTRI - INTEGER HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB, - $ NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN, - $ WRKOPT -C .. Local Arrays .. - INTEGER IPVT(1) - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLASET, DPOTRF, DTRSM, MB02CU, - $ MB02CV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN, MOD -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRI = LSAME( TRIU, 'T' ) - LENR = ( NL + 1 )*K - IF ( LTRI ) THEN - SIZR = NL*K + 1 - ELSE - SIZR = LENR - END IF - ISROW = LSAME( TYPET, 'R' ) - WRKMIN = 1 + ( LENR + NL )*K -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( ( LTRI .AND. N.LT.2 ) .OR. - $ ( .NOT.LTRI .AND. N.LT.1 ) ) THEN - INFO = -4 - ELSE IF ( NL.GE.N .OR. ( LTRI .AND. NL.LT.1 ) .OR. - $ ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN - INFO = -5 - ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN - INFO = -6 - ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN - INFO = -7 - ELSE IF ( ( ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR. - $ ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) ) - $ THEN - INFO = -9 - ELSE IF ( ( LTRI .AND. LDRB.LT.SIZR ) .OR. - $ ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) ) - $ THEN - INFO = -11 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -13 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02GD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( S*K.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Compute the generator if P = 0. -C - IF ( P.EQ.0 ) THEN - IF ( ISROW ) THEN - CALL DPOTRF( 'Upper', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF - IF ( NL.GT.0 ) - $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, - $ NL*K, ONE, T, LDT, T(1,K+1), LDT ) -C -C Copy the first block row to RB. -C - IF ( LTRI ) THEN -C - DO 10 I = 1, LENR - K - CALL DCOPY( MIN( I, K ), T(1,I), 1, - $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) - 10 CONTINUE -C - DO 20 I = K, 1, -1 - CALL DCOPY( I, T(K-I+1,LENR-I+1), 1, - $ RB( 1,LENR-I+1 ), 1 ) - 20 CONTINUE -C - ELSE -C - DO 30 I = 1, LENR - CALL DCOPY( MIN( I, K ), T(1,I), 1, - $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) - 30 CONTINUE -C - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K ) - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K ) - POSR = K + 1 - ELSE - CALL DPOTRF( 'Lower', K, T, LDT, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The matrix is not positive definite. -C - INFO = 1 - RETURN - END IF - IF ( NL.GT.0 ) - $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', - $ NL*K, K, ONE, T, LDT, T(K+1,1), LDT ) -C -C Copy the first block column to RB. -C - POSR = 1 - IF ( LTRI ) THEN -C - DO 40 I = 1, K - CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 ) - POSR = POSR + 1 - 40 CONTINUE -C - ELSE -C - DO 50 I = 1, K - CALL DCOPY( LENR-I+1, T(I,I), 1, RB(1,POSR), 1 ) - IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN - CALL DLASET( 'All', I-1, 1, ZERO, ZERO, - $ RB(LENR-I+2,POSR), LDRB ) - END IF - POSR = POSR + 1 - 50 CONTINUE -C - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR ) - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR ) - END IF - PRE = 1 - STPS = S - 1 - ELSE - PRE = P - STPS = S - POSR = 1 - END IF -C - PDW = LENR*K + 1 - HEAD = MOD( ( PRE - 1 )*K, LENR ) -C -C Determine block size for the involved block Householder -C transformations. -C - IF ( ISROW ) THEN - NB = MIN( ILAENV( 1, 'DGEQRF', ' ', K, LENR, -1, -1 ), K ) - ELSE - NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, K, -1, -1 ), K ) - END IF - KK = PDW + 4*K - WRKOPT = KK + LENR*NB - KK = LDWORK - KK - IF ( KK.LT.LENR*NB ) NB = KK / LENR - IF ( ISROW ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) ) - ELSE - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) ) - END IF - IF ( NB.LT.NBMIN ) NB = 0 -C -C Generator reduction process. -C - IF ( ISROW ) THEN -C - DO 90 I = PRE, PRE + STPS - 1 - CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1, - $ DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1), - $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The positive definiteness is (numerically) -C not satisfied. -C - INFO = 1 - RETURN - END IF -C - LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) - LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) - IF ( LEN.EQ.( LENR-K ) ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1, - $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT, - $ DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( ( N - I )*K.GE.LENR ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1, - $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT, - $ DUM, 1, DWORK(2), K, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K ) -C -C Copy current block row to RB. -C - IF ( LTRI ) THEN -C - DO 60 J = 1, MIN( LEN + LEN2 + K, LENR - K ) - CALL DCOPY( MIN( J, K ), T(1,J), 1, - $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 ) - 60 CONTINUE -C - IF ( LEN+LEN2+K.GE.LENR ) THEN -C - DO 70 JJ = K, 1, -1 - CALL DCOPY( JJ, T(K-JJ+1,LENR-JJ+1), 1, - $ RB(1,POSR+LENR-JJ), 1 ) - 70 CONTINUE -C - END IF - POSR = POSR + K -C - ELSE -C - DO 80 J = 1, LEN + LEN2 + K - CALL DCOPY( MIN( J, K ), T(1,J), 1, - $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 ) - IF ( J.GT.LENR-K ) THEN - CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO, - $ RB(1,POSR+J-1), 1 ) - END IF - 80 CONTINUE -C - POSR = POSR + K - END IF - HEAD = MOD( HEAD + K, LENR ) - 90 CONTINUE -C - ELSE -C - DO 120 I = PRE, PRE + STPS - 1 -C - CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1, - $ DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1), - $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( IERR.NE.0 ) THEN -C -C Error return: The positive definiteness is (numerically) -C not satisfied. -C - INFO = 1 - RETURN - END IF -C - LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) - LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) - IF ( LEN.EQ.( LENR-K ) ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM, - $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT, - $ DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - IF ( ( N - I )*K.GE.LENR ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM, - $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1), - $ LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1), - $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) -C - CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR ) -C -C Copy current block column to RB. -C - IF ( LTRI ) THEN -C - DO 100 J = 1, K - CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1, - $ RB(1,POSR), 1 ) - POSR = POSR + 1 - 100 CONTINUE -C - ELSE -C - DO 110 J = 1, K - CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1, - $ RB(1,POSR), 1 ) - IF ( LENR.LT.(N-I)*K ) THEN - CALL DLASET( 'All', J-1, 1, ZERO, ZERO, - $ RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1, - $ POSR), LDRB ) - END IF - POSR = POSR + 1 - 110 CONTINUE -C - END IF - HEAD = MOD( HEAD + K, LENR ) - 120 CONTINUE -C - END IF - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02GD *** - END diff --git a/slycot/src/MB02HD.f b/slycot/src/MB02HD.f deleted file mode 100644 index c93d2474..00000000 --- a/slycot/src/MB02HD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE MB02HD( TRIU, K, L, M, ML, N, NU, P, S, TC, LDTC, TR, - $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a banded K*M-by-L*N block Toeplitz matrix T with -C block size (K,L), specified by the nonzero blocks of its first -C block column TC and row TR, a LOWER triangular matrix R (in band -C storage scheme) such that -C T T -C T T = R R . (1) -C -C It is assumed that the first MIN(M*K, N*L) columns of T are -C linearly independent. -C -C By subsequent calls of this routine, the matrix R can be computed -C block column by block column. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRIU CHARACTER*1 -C Specifies the structure, if any, of the last blocks in TC -C and TR, as follows: -C = 'N': TC and TR have no special structure; -C = 'T': TC and TR are upper and lower triangular, -C respectively. Depending on the block sizes, two -C different shapes of the last blocks in TC and TR -C are possible, as illustrated below: -C -C 1) TC TR 2) TC TR -C -C x x x x 0 0 x x x x x 0 0 0 -C 0 x x x x 0 0 x x x x x 0 0 -C 0 0 x x x x 0 0 x x x x x 0 -C 0 0 0 x x x -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in the blocks of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in the blocks of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in the first block column of T. -C M >= 1. -C -C ML (input) INTEGER -C The lower block bandwidth, i.e., ML + 1 is the number of -C nonzero blocks in the first block column of T. -C 0 <= ML < M and (ML + 1)*K >= L and -C if ( M*K <= N*L ), ML >= M - INT( ( M*K - 1 )/L ) - 1; -C ML >= M - INT( M*K/L ) or -C MOD( M*K, L ) >= K; -C if ( M*K >= N*L ), ML*K >= N*( L - K ). -C -C N (input) INTEGER -C The number of blocks in the first block row of T. -C N >= 1. -C -C NU (input) INTEGER -C The upper block bandwidth, i.e., NU + 1 is the number of -C nonzero blocks in the first block row of T. -C If TRIU = 'N', 0 <= NU < N and -C (M + NU)*L >= MIN( M*K, N*L ); -C if TRIU = 'T', MAX(1-ML,0) <= NU < N and -C (M + NU)*L >= MIN( M*K, N*L ). -C -C P (input) INTEGER -C The number of previously computed block columns of R. -C P*L < MIN( M*K,N*L ) + L and P >= 0. -C -C S (input) INTEGER -C The number of block columns of R to compute. -C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) -C On entry, if P = 0, the leading (ML+1)*K-by-L part of this -C array must contain the nonzero blocks in the first block -C column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,(ML+1)*K), if P = 0. -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,NU*L) -C On entry, if P = 0, the leading K-by-NU*L part of this -C array must contain the 2nd to the (NU+1)-st blocks of -C the first block row of T. -C -C LDTR INTEGER -C The leading dimension of the array TR. -C LDTR >= MAX(1,K), if P = 0. -C -C RB (output) DOUBLE PRECISION array, dimension -C (LDRB,MIN( S*L,MIN( M*K,N*L )-P*L )) -C On exit, if INFO = 0 and TRIU = 'N', the leading -C MIN( ML+NU+1,N )*L-by-MIN( S*L,MIN( M*K,N*L )-P*L ) part -C of this array contains the (P+1)-th to (P+S)-th block -C column of the lower R factor (1) in band storage format. -C On exit, if INFO = 0 and TRIU = 'T', the leading -C MIN( (ML+NU)*L+1,N*L )-by-MIN( S*L,MIN( M*K,N*L )-P*L ) -C part of this array contains the (P+1)-th to (P+S)-th block -C column of the lower R factor (1) in band storage format. -C For further details regarding the band storage scheme see -C the documentation of the LAPACK routine DPBTF2. -C -C LDRB INTEGER -C The leading dimension of the array RB. -C LDRB >= MAX( MIN( ML+NU+1,N )*L,1 ), if TRIU = 'N'; -C LDRB >= MAX( MIN( (ML+NU)*L+1,N*L ),1 ), if TRIU = 'T'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C The first 1 + 2*MIN( ML+NU+1,N )*L*(K+L) elements of DWORK -C should be preserved during successive calls of the routine. -C -C LDWORK INTEGER -C The length of the array DWORK. -C Let x = MIN( ML+NU+1,N ), then -C LDWORK >= 1 + MAX( x*L*L + (2*NU+1)*L*K, -C 2*x*L*(K+L) + (6+x)*L ), if P = 0; -C LDWORK >= 1 + 2*x*L*(K+L) + (6+x)*L, if P > 0. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the full rank condition for the first MIN(M*K, N*L) -C columns of T is (numerically) violated. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method yields a factor R which has comparable -C accuracy with the Cholesky factor of T^T * T. -C The algorithm requires -C 2 2 -C O( L *K*N*( ML + NU ) + N*( ML + NU )*L *( L + K ) ) -C -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRIU - INTEGER INFO, K, L, LDRB, LDTC, LDTR, LDWORK, M, ML, N, - $ NU, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - CHARACTER STRUCT - INTEGER COL2, HEAD, I, IERR, J, KK, LEN, LEN2, LENC, - $ LENL, LENR, NB, NBMIN, PDC, PDR, PDW, PFR, PNR, - $ POSR, PRE, PT, RNK, SIZR, STPS, WRKMIN, WRKOPT, - $ X - LOGICAL LTRI -C .. Local Arrays .. - INTEGER IPVT(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, - $ MA02AD, MB02CU, MB02CV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, MOD -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRI = LSAME( TRIU, 'T' ) - X = MIN( ML + NU + 1, N ) - LENR = X*L - IF ( LTRI ) THEN - SIZR = MIN( ( ML + NU )*L + 1, N*L ) - ELSE - SIZR = LENR - END IF - IF ( P.EQ.0 ) THEN - WRKMIN = 1 + MAX( LENR*L + ( 2*NU + 1 )*L*K, - $ 2*LENR*( K + L ) + ( 6 + X )*L ) - ELSE - WRKMIN = 1 + 2*LENR*( K + L ) + ( 6 + X )*L - END IF - POSR = 1 -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.1 ) THEN - INFO = -4 - ELSE IF ( ML.GE.M .OR. ( ML + 1 )*K.LT.L .OR. ( M*K.LE.N*L .AND. - $ ( ( ML.LT.M - INT( ( M*K - 1 )/L ) - 1 ) .OR. - $ ( ML.LT.M - INT( M*K/L ).AND.MOD( M*K, L ).LT.K ) ) ) - $ .OR. ( M*K.GE.N*L .AND. ML*K.LT.N*( L - K ) ) ) THEN - INFO = -5 - ELSE IF ( N.LT.1 ) THEN - INFO = -6 - ELSE IF ( NU.GE.N .OR. NU.LT.0 .OR. ( LTRI .AND. NU.LT.1-ML ) .OR. - $ (M + NU)*L.LT.MIN( M*K, N*L ) ) THEN - INFO = -7 - ELSE IF ( P.LT.0 .OR. ( P*L - L ).GE.MIN( M*K, N*L ) ) THEN - INFO = -8 - ELSE IF ( S.LT.0 .OR. ( P + S - 1 )*L.GE.MIN( M*K, N*L ) ) THEN - INFO = -9 - ELSE IF ( P.EQ.0 .AND. LDTC.LT.MAX( 1, ( ML + 1 )*K ) ) THEN - INFO = -11 - ELSE IF ( P.EQ.0 .AND. LDTR.LT.MAX( 1, K ) ) THEN - INFO = -13 - ELSE IF ( LDRB.LT.MAX( SIZR, 1 ) ) THEN - INFO = 15 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( L*K*S.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WRKOPT = 1 -C -C Compute the generator if P = 0. -C - IF ( P.EQ.0 ) THEN -C -C 1st column of the generator. -C - LENC = ( ML + 1 )*K - LENL = MAX( ML + 1 + MIN( NU, N - M ), 0 ) - PDC = LENR*L + 1 - PDW = PDC + LENC*L -C -C QR decomposition of the nonzero blocks in TC. -C - CALL DLACPY( 'All', LENC, L, TC, LDTC, DWORK(PDC+1), LENC ) - CALL DGEQRF( LENC, L, DWORK(PDC+1), LENC, DWORK(PDW+1), - $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) -C -C The R factor is the transposed of the first block in the -C generator. -C - CALL MA02AD( 'Upper part', L, L, DWORK(PDC+1), LENC, DWORK(2), - $ LENR ) -C -C Get the first block column of the Q factor. -C - CALL DORGQR( LENC, L, L, DWORK(PDC+1), LENC, DWORK(PDW+1), - $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) -C -C Construct a flipped copy of TC for faster multiplication. -C - PT = LENC - 2*K + 1 -C - DO 10 I = PDW + 1, PDW + ML*K*L, K*L - CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) - PT = PT - K - 10 CONTINUE -C -C Multiply T^T with the first block column of Q. -C - PDW = I - PDR = L + 2 - LEN = NU*L - CALL DLASET( 'All', LENR-L, L, ZERO, ZERO, DWORK(PDR), LENR ) -C - DO 20 I = 1, ML + 1 - CALL DGEMM( 'Transpose', 'NonTranspose', MIN( I-1, N-1 )*L, - $ L, K, ONE, DWORK(PDW), K, DWORK(PDC+1), LENC, - $ ONE, DWORK(PDR), LENR ) - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'Transpose', 'NonTranspose', LEN, L, K, ONE, - $ TR, LDTR, DWORK(PDC+1), LENC, ONE, - $ DWORK(PDR+(I-1)*L), LENR ) - END IF - PDW = PDW - K*L - PDC = PDC + K - IF ( I.GE.N-NU ) LEN = LEN - L - 20 CONTINUE -C -C Copy the first block column to R. -C - IF ( LTRI ) THEN -C - DO 30 I = 1, L - CALL DCOPY( MIN( SIZR, N*L - I + 1 ), - $ DWORK(( I - 1 )*LENR + I + 1), 1, RB(1,POSR), - $ 1 ) - POSR = POSR + 1 - 30 CONTINUE -C - ELSE -C - DO 40 I = 1, L - CALL DCOPY( LENR-I+1, DWORK(( I - 1 )*LENR + I + 1), 1, - $ RB(1,POSR), 1 ) - IF ( LENR.LT.N*L .AND. I.GT.1 ) THEN - CALL DLASET( 'All', I-1, 1, ZERO, ZERO, - $ RB(LENR-I+2,POSR), LDRB ) - END IF - POSR = POSR + 1 - 40 CONTINUE -C - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C 2nd column of the generator. -C - PDR = LENR*L + 1 - CALL MA02AD( 'All', K, NU*L, TR, LDTR, DWORK(PDR+1), LENR ) - CALL DLASET( 'All', LENR-NU*L, K, ZERO, ZERO, - $ DWORK(PDR+NU*L+1), LENR ) -C -C 3rd column of the generator. -C - PNR = PDR + LENR*K - CALL DLACPY( 'All', LENR-L, L, DWORK(L+2), LENR, DWORK(PNR+1), - $ LENR ) - CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PNR+LENR-L+1), - $ LENR ) -C -C 4th column of the generator. -C - PFR = PNR + LENR*L -C - PDW = PFR + MOD( ( M - ML - 1 )*L, LENR ) - PT = ML*K + 1 - DO 50 I = 1, MIN( ML + 1, LENL ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW+1), - $ LENR ) - PT = PT - K - PDW = PFR + MOD( PDW + L - PFR, LENR ) - 50 CONTINUE - PT = 1 - DO 60 I = ML + 2, LENL - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW+1), - $ LENR ) - PT = PT + L - PDW = PFR + MOD( PDW + L - PFR, LENR ) - 60 CONTINUE - PRE = 1 - STPS = S - 1 - ELSE - PDR = LENR*L + 1 - PNR = PDR + LENR*K - PFR = PNR + LENR*L - PRE = P - STPS = S - END IF -C - PDW = PFR + LENR*K - HEAD = MOD( ( PRE - 1 )*L, LENR ) -C -C Determine block size for the involved block Householder -C transformations. -C - NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, L, -1, -1 ), L ) - KK = PDW + 6*L - WRKOPT = MAX( WRKOPT, KK + LENR*NB ) - KK = LDWORK - KK - IF ( KK.LT.LENR*NB ) NB = KK / LENR - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, L, -1, -1 ) ) - IF ( NB.LT.NBMIN ) NB = 0 -C -C Generator reduction process. -C - DO 90 I = PRE, PRE + STPS - 1 -C -C The 4th generator column is not used in the first (M-ML) steps. -C - IF ( I.LT.M-ML ) THEN - COL2 = L - ELSE - COL2 = K + L - END IF -C - KK = MIN( L, M*K - I*L ) - CALL MB02CU( 'Column', KK, KK+K, COL2, NB, DWORK(2), LENR, - $ DWORK(PDR+HEAD+1), LENR, DWORK(PNR+HEAD+1), LENR, - $ RNK, IPVT, DWORK(PDW+1), ZERO, DWORK(PDW+6*L+1), - $ LDWORK-PDW-6*L, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The rank condition is (numerically) not -C satisfied. -C - INFO = 1 - RETURN - END IF -C - LEN = MAX( MIN( ( N - I )*L - KK, LENR - HEAD - KK ), 0 ) - LEN2 = MAX( MIN( ( N - I )*L - LEN - KK, HEAD ), 0 ) - IF ( LEN.EQ.( LENR - KK ) ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF - CALL MB02CV( 'Column', STRUCT, KK, LEN, KK+K, COL2, NB, -1, - $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, - $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+2), LENR, - $ DWORK(PDR+HEAD+KK+1), LENR, DWORK(PNR+HEAD+KK+1), - $ LENR, DWORK(PDW+1), DWORK(PDW+6*L+1), - $ LDWORK-PDW-6*L, IERR ) -C - IF ( ( N - I )*L.GE.LENR ) THEN - STRUCT = TRIU - ELSE - STRUCT = 'N' - END IF -C - CALL MB02CV( 'Column', STRUCT, KK, LEN2, KK+K, COL2, NB, -1, - $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, - $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+LEN+2), LENR, - $ DWORK(PDR+1), LENR, DWORK(PNR+1), LENR, - $ DWORK(PDW+1), DWORK(PDW+6*L+1), - $ LDWORK-PDW-6*L, IERR ) -C - CALL DLASET( 'All', L, K+COL2, ZERO, ZERO, DWORK(PDR+HEAD+1), - $ LENR ) -C -C Copy current block column to R. -C - IF ( LTRI ) THEN -C - DO 70 J = 1, KK - CALL DCOPY( MIN( SIZR, (N-I)*L-J+1 ), - $ DWORK(( J - 1 )*LENR + J + 1), 1, - $ RB(1,POSR), 1 ) - POSR = POSR + 1 - 70 CONTINUE -C - ELSE -C - DO 80 J = 1, KK - CALL DCOPY( MIN( SIZR-J+1, (N-I)*L-J+1 ), - $ DWORK(( J - 1 )*LENR + J + 1), 1, - $ RB(1,POSR), 1 ) - IF ( LENR.LT.( N - I )*L .AND. J.GT.1 ) THEN - CALL DLASET( 'All', J-1, 1, ZERO, ZERO, - $ RB(MIN( SIZR-J+1, (N-I)*L-J+1 )+1,POSR), - $ LDRB ) - END IF - POSR = POSR + 1 - 80 CONTINUE -C - END IF -C - HEAD = MOD( HEAD + L, LENR ) - 90 CONTINUE -C - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02HD *** - END diff --git a/slycot/src/MB02ID.f b/slycot/src/MB02ID.f deleted file mode 100644 index a0e5e659..00000000 --- a/slycot/src/MB02ID.f +++ /dev/null @@ -1,508 +0,0 @@ - SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, - $ LDB, C, LDC, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the overdetermined or underdetermined real linear systems -C involving an M*K-by-N*L block Toeplitz matrix T that is specified -C by its first block column and row. It is assumed that T has full -C rank. -C The following options are provided: -C -C 1. If JOB = 'O' or JOB = 'A' : find the least squares solution of -C an overdetermined system, i.e., solve the least squares problem -C -C minimize || B - T*X ||. (1) -C -C 2. If JOB = 'U' or JOB = 'A' : find the minimum norm solution of -C the undetermined system -C T -C T * X = C. (2) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the problem to be solved as follows -C = 'O': solve the overdetermined system (1); -C = 'U': solve the underdetermined system (2); -C = 'A': solve (1) and (2). -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in the blocks of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in the blocks of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in the first block column of T. -C M >= 0. -C -C N (input) INTEGER -C The number of blocks in the first block row of T. -C 0 <= N <= M*K / L. -C -C RB (input) INTEGER -C If JOB = 'O' or 'A', the number of columns in B. RB >= 0. -C -C RC (input) INTEGER -C If JOB = 'U' or 'A', the number of columns in C. RC >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) -C On entry, the leading M*K-by-L part of this array must -C contain the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. LDTC >= MAX(1,M*K) -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) -C On entry, the leading K-by-(N-1)*L part of this array must -C contain the 2nd to the N-th blocks of the first block row -C of T. -C -C LDTR INTEGER -C The leading dimension of the array TR. LDTR >= MAX(1,K). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,RB) -C On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB -C part of this array must contain the right hand side -C matrix B of the overdetermined system (1). -C On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB -C part of this array contains the solution of the -C overdetermined system (1). -C This array is not referenced if JOB = 'U'. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,M*K), if JOB = 'O' or JOB = 'A'; -C LDB >= 1, if JOB = 'U'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,RC) -C On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC -C part of this array must contain the right hand side -C matrix C of the underdetermined system (2). -C On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC -C part of this array contains the solution of the -C underdetermined system (2). -C This array is not referenced if JOB = 'O'. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDB >= 1, if JOB = 'O'; -C LDB >= MAX(1,M*K), if JOB = 'U' or JOB = 'A'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K ) -C and y = N*M*K*L + N*L, then -C if MIN( M,N ) = 1 and JOB = 'O', -C LDWORK >= MAX( y + MAX( M*K,RB ),1 ); -C if MIN( M,N ) = 1 and JOB = 'U', -C LDWORK >= MAX( y + MAX( M*K,RC ),1 ); -C if MIN( M,N ) = 1 and JOB = 'A', -C LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 ); -C if MIN( M,N ) > 1 and JOB = 'O', -C LDWORK >= MAX( x,N*L*RB + 1 ); -C if MIN( M,N ) > 1 and JOB = 'U', -C LDWORK >= MAX( x,N*L*RC + 1 ); -C if MIN( M,N ) > 1 and JOB = 'A', -C LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction algorithm failed. The Toeplitz matrix -C associated with T is (numerically) not of full rank. -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) ) -C and additionally -C -C if JOB = 'O' or JOB = 'A', -C O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB ); -C if JOB = 'U' or JOB = 'A', -C O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC ); -C -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, - $ RB, RC -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(LDWORK), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - INTEGER I, IERR, KK, LEN, NB, NBMIN, PDI, PDW, PNI, PNR, - $ PPI, PPR, PT, RNK, WRKMIN, WRKOPT, X, Y - LOGICAL COMPO, COMPU -C .. Local Arrays .. - INTEGER IPVT(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DGELS, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, - $ DTRMM, DTRSM, DTRTRI, MA02AD, MB02CU, MB02CV, - $ MB02KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPO = LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) - COMPU = LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) - X = MAX( 2*N*L*( L + K ) + ( 6 + N )*L, - $ ( N*L + M*K + 1 )*L + M*K ) - Y = N*M*K*L + N*L - IF ( MIN( M, N ).EQ.1 ) THEN - WRKMIN = MAX( M*K, 1 ) - IF ( COMPO ) WRKMIN = MAX( WRKMIN, RB ) - IF ( COMPU ) WRKMIN = MAX( WRKMIN, RC ) - WRKMIN = MAX( Y + WRKMIN, 1 ) - ELSE - WRKMIN = X - IF ( COMPO ) WRKMIN = MAX( WRKMIN, N*L*RB + 1 ) - IF ( COMPU ) WRKMIN = MAX( WRKMIN, N*L*RC + 1 ) - END IF - WRKOPT = 1 -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPO .OR. COMPU ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 .OR. ( N*L ).GT.( M*K ) ) THEN - INFO = -5 - ELSE IF ( COMPO .AND. RB.LT.0 ) THEN - INFO = -6 - ELSE IF ( COMPU .AND. RC.LT.0 ) THEN - INFO = -7 - ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN - INFO = -9 - ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN - INFO = -11 - ELSE IF ( LDB.LT.1 .OR. ( COMPO .AND. LDB.LT.M*K ) ) THEN - INFO = -13 - ELSE IF ( LDC.LT.1 .OR. ( COMPU .AND. LDC.LT.M*K ) ) THEN - INFO = -15 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02ID', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( COMPO .AND. MIN( N*L, RB ).EQ.0 ) THEN - COMPO = .FALSE. - END IF - IF( COMPU .AND. MIN( N*L, RC ).EQ.0 ) THEN - CALL DLASET( 'Full', M*K, RC, ZERO, ZERO, C, LDC ) - COMPU = .FALSE. - END IF - IF ( .NOT.( COMPO .OR. COMPU ) ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Check cases M = 1 or N = 1. -C - IF ( MIN( M, N ).EQ.1 ) THEN - PDW = K*L*M*N - IF ( COMPO ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), - $ M*K ) - CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, B, - $ LDB, DWORK(PDW+1), LDWORK-PDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) - END IF - IF ( COMPU ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), - $ M*K ) - CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, LDC, - $ DWORK(PDW+1), LDWORK-PDW, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) - END IF - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C Step 1: Compute the generator. -C - IF ( COMPO ) THEN - CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, ONE, ZERO, - $ TC, LDTC, TR, LDTR, B, LDB, DWORK, N*L, - $ DWORK(N*L*RB+1), LDWORK-N*L*RB, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(N*L*RB+1) ) + N*L*RB ) - CALL DLACPY( 'All', N*L, RB, DWORK, N*L, B, LDB ) - END IF -C - PDW = N*L*L + 1 - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK(PDW), M*K ) - CALL DGEQRF( M*K, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), - $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + - $ PDW + (M*K+1)*L - 1 ) -C - DO 10 I = PDW, PDW + M*K*L - 1, M*K + 1 - IF ( DWORK(I).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF - 10 CONTINUE -C - CALL MA02AD( 'Upper', L, L, DWORK(PDW), M*K, DWORK, N*L ) - CALL DORGQR( M*K, L, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), - $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + - $ PDW + (M*K+1)*L - 1 ) - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, ZERO, - $ TC, LDTC, TR, LDTR, DWORK(PDW), M*K, DWORK(L+1), - C N*L, DWORK(PDW+M*K*L), LDWORK-PDW-M*K*L+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K*L) ) + PDW + M*K*L - 1 ) - PPR = N*L*L + 1 - PNR = N*L*( L + K ) + 1 - CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(PPR+L), N*L ) - CALL DLACPY( 'All', (N-1)*L, L, DWORK(L+1), N*L, DWORK(PNR+L), - $ N*L ) - PT = ( M - 1 )*K + 1 - PDW = PNR + N*L*L + L -C - DO 30 I = 1, MIN( M, N-1 ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), N*L ) - PT = PT - K - PDW = PDW + L - 30 CONTINUE -C - PT = 1 -C - DO 40 I = M + 1, N - 1 - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), N*L ) - PT = PT + L - PDW = PDW + L - 40 CONTINUE -C - IF ( COMPO ) THEN -C -C Apply the first reduction step to T'*B. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RB, ONE, DWORK, N*L, B, LDB ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RB, L, ONE, - $ DWORK(L+1), N*L, B, LDB, -ONE, B(L+1,1), LDB ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, - $ RB, ONE, DWORK, N*L, B, LDB ) - END IF -C - IF ( COMPU ) THEN -C -C Apply the first reduction step to C. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RC, ONE, DWORK, N*L, C, LDC ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RC, L, ONE, - $ DWORK(L+1), N*L, C, LDC, -ONE, C(L+1,1), LDC ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, - $ RC, ONE, DWORK, N*L, C, LDC ) - END IF -C - PDI = ( N - 1 )*L + 1 - CALL DLACPY( 'Lower', L, L, DWORK, N*L, DWORK(PDI), N*L ) - CALL DTRTRI( 'Lower', 'NonUnit', L, DWORK(PDI), N*L, IERR ) - CALL MA02AD( 'Lower', L-1, L, DWORK(PDI+1), N*L, - $ DWORK((2*N-1)*L+1), N*L ) - CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PDI+1), N*L ) - CALL DLACPY( 'Upper', L, L, DWORK(PDI), N*L, DWORK(PNR), N*L ) - CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PNR+1), N*L ) - CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PPR), N*L ) - CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PNR+N*L*L), N*L ) -C - PPI = PPR - PPR = PPR + L - PNI = PNR - PNR = PNR + L - PDW = 2*N*L*( L + K ) + 1 - LEN = ( N - 1 )*L -C -C Determine block size for the involved block Householder -C transformations. -C - NB = MIN( ILAENV( 1, 'DGELQF', ' ', N*L, L, -1, -1 ), L ) - KK = PDW + 6*L - 1 - WRKOPT = MAX( WRKOPT, KK + N*L*NB ) - KK = LDWORK - KK - IF ( KK.LT.N*L*NB ) NB = KK / ( N*L ) - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', N*L, L, -1, -1 ) ) - IF ( NB.LT.NBMIN ) NB = 0 -C - DO 50 I = L + 1, N*L, L - CALL MB02CU( 'Column', L, L+K, L+K, NB, DWORK, N*L, DWORK(PPR), - $ N*L, DWORK(PNR), N*L, RNK, IPVT, DWORK(PDW), ZERO, - $ DWORK(PDW+6*L), LDWORK-PDW-6*L+1, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The rank condition is (numerically) not -C satisfied. -C - INFO = 1 - RETURN - END IF - CALL MB02CV( 'Column', 'NoStructure', L, LEN-L, L+K, L+K, NB, - $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, - $ DWORK(L+1), N*L, DWORK(PPR+L), N*L, DWORK(PNR+L), - $ N*L, DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - PDI = PDI - L - IF ( COMPO ) THEN -C -C Block Gaussian elimination to B. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RB, -ONE, DWORK, N*L, B(I,1), LDB ) - IF ( LEN.GT.L ) THEN - CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RB, L, - $ ONE, DWORK(L+1), N*L, B(I,1), LDB, ONE, - $ B(I+L,1), LDB ) - END IF - END IF - IF ( COMPU ) THEN -C -C Block Gaussian elimination to C. -C - CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', - $ L, RC, -ONE, DWORK, N*L, C(I,1), LDC ) - IF ( LEN.GT.L ) THEN - CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RC, L, - $ ONE, DWORK(L+1), N*L, C(I,1), LDC, ONE, - $ C(I+L,1), LDC ) - END IF - END IF - CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PDI), N*L ) - CALL MB02CV( 'Column', 'Triangular', L, I+L-1, L+K, L+K, NB, - $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, - $ DWORK(PDI), N*L, DWORK(PPI), N*L, DWORK(PNI), N*L, - $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - IF ( COMPO ) THEN -C -C Apply block Gaussian elimination to B. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', I-1, RB, L, ONE, - $ DWORK(PDI), N*L, B(I,1), LDB, ONE, B, LDB ) - CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, - $ RB, ONE, DWORK((N-1)*L+1), N*L, B(I,1), LDB ) - END IF - IF ( COMPU ) THEN -C -C Apply block Gaussian elimination to C. -C - CALL DGEMM( 'NonTranspose', 'NonTranspose', I-1, RC, L, ONE, - $ DWORK(PDI), N*L, C(I,1), LDC, ONE, C, LDC ) - CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, - $ RC, ONE, DWORK((N-1)*L+1), N*L, C(I,1), LDC ) - END IF - LEN = LEN - L - PNR = PNR + L - PPR = PPR + L - 50 CONTINUE -C - IF ( COMPU ) THEN - CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, ONE, - $ ZERO, TC, LDTC, TR, LDTR, C, LDC, DWORK, M*K, - $ DWORK(M*K*RC+1), LDWORK-M*K*RC, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M*K*RC+1) ) + M*K*RC ) - CALL DLACPY( 'All', M*K, RC, DWORK, M*K, C, LDC ) - END IF - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02ID *** - END diff --git a/slycot/src/MB02JD.f b/slycot/src/MB02JD.f deleted file mode 100644 index 95c49b43..00000000 --- a/slycot/src/MB02JD.f +++ /dev/null @@ -1,486 +0,0 @@ - SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q, - $ LDQ, R, LDR, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a lower triangular matrix R and a matrix Q with -C Q^T Q = I such that -C T -C T = Q R , -C -C where T is a K*M-by-L*N block Toeplitz matrix with blocks of size -C (K,L). The first column of T will be denoted by TC and the first -C row by TR. It is assumed that the first MIN(M*K, N*L) columns of T -C have full rank. -C -C By subsequent calls of this routine the factors Q and R can be -C computed block column by block column. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine as follows: -C = 'Q': computes Q and R; -C = 'R': only computes R. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in one block of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in one block of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in one block column of T. M >= 0. -C -C N (input) INTEGER -C The number of blocks in one block row of T. N >= 0. -C -C P (input) INTEGER -C The number of previously computed block columns of R. -C P*L < MIN( M*K,N*L ) + L and P >= 0. -C -C S (input) INTEGER -C The number of block columns of R to compute. -C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) -C On entry, if P = 0, the leading M*K-by-L part of this -C array must contain the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,M*K). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) -C On entry, if P = 0, the leading K-by-(N-1)*L part of this -C array must contain the first block row of T without the -C leading K-by-L block. -C -C LDTR INTEGER -C The leading dimension of the array TR. -C LDTR >= MAX(1,K). -C -C Q (input/output) DOUBLE PRECISION array, dimension -C (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L )) -C On entry, if JOB = 'Q' and P > 0, the leading M*K-by-L -C part of this array must contain the last block column of Q -C from a previous call of this routine. -C On exit, if JOB = 'Q' and INFO = 0, the leading -C M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array -C contains the P-th to (P+S)-th block columns of the factor -C Q. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= MAX(1,M*K), if JOB = 'Q'; -C LDQ >= 1, if JOB = 'R'. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR,MIN( S*L, MIN( M*K,N*L )-P*L )) -C On entry, if P > 0, the leading (N-P+1)*L-by-L -C part of this array must contain the nozero part of the -C last block column of R from a previous call of this -C routine. -C One exit, if INFO = 0, the leading -C MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L ) -C part of this array contains the nonzero parts of the P-th -C to (P+S)-th block columns of the lower triangular -C factor R. -C Note that elements in the strictly upper triangular part -C will not be referenced. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX( 1, MIN( N, N-P+1 )*L ) -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C On exit, if INFO = -17, DWORK(1) returns the minimum -C value of LDWORK. -C If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L ) -C elements of DWORK should be preserved during successive -C calls of the routine. -C If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements -C of DWORK should be preserved during successive calls of -C the routine. -C -C LDWORK INTEGER -C The length of the array DWORK. -C JOB = 'Q': -C LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L -C + MAX( M*K,( N - MAX( 1,P )*L ) ); -C JOB = 'R': -C If P = 0, -C LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L -C + (N-1)*L, M*K*( L + 1 ) + L ); -C If P > 0, -C LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the full rank condition for the first MIN(M*K, N*L) -C columns of T is (numerically) violated. -C -C METHOD -C -C Block Householder transformations and modified hyperbolic -C rotations are used in the Schur algorithm [1], [2]. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The implemented method yields a factor R which has comparable -C accuracy with the Cholesky factor of T^T * T. Q is implicitly -C computed from the formula Q = T * inv(R^T R) * R, i.e., for ill -C conditioned problems this factor is of very limited value. -C 2 -C The algorithm requires 0(K*L *M*N) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, - $ M, N, P, S -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - INTEGER COLR, I, IERR, KK, LEN, NB, NBMIN, PDQ, PDW, - $ PNQ, PNR, PRE, PT, RNK, SHFR, STPS, WRKMIN, - $ WRKOPT - LOGICAL COMPQ -C .. Local Arrays .. - INTEGER IPVT(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DGEQRF, DLACPY, DLASET, DORGQR, MA02AD, MB02CU, - $ MB02CV, MB02KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - COMPQ = LSAME( JOB, 'Q' ) - IF ( COMPQ ) THEN - WRKMIN = 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L - $ + MAX( M*K, ( N - MAX( 1, P ) )*L ) - ELSE - WRKMIN = 1 + ( N - 1 )*L*( L + 2*K ) + 6*L - $ + ( N - MAX( P, 1 ) )*L - IF ( P.EQ.0 ) THEN - WRKMIN = MAX( WRKMIN, M*K*( L + 1 ) + L ) - END IF - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( P*L.GE.MIN( M*K, N*L ) + L .OR. P.LT.0 ) THEN - INFO = -6 - ELSE IF ( ( P + S )*L.GE.MIN( M*K, N*L ) + L .OR. S.LT.0 ) THEN - INFO = -7 - ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN - INFO = -9 - ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN - INFO = -11 - ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.M*K ) ) THEN - INFO = -13 - ELSE IF ( LDR.LT.MAX( 1, MIN( N, N - P + 1 )*L ) ) THEN - INFO = -15 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'MB02JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, N, K*L, S ) .EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Catch M*K <= L. -C - WRKOPT = 1 - IF ( M*K.LE.L ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - PDW = M*K*L + 1 - CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), - $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) - CALL MA02AD( 'Upper part', M*K, L, DWORK, M*K, R, LDR ) - CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK(PDW), - $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) - IF ( COMPQ ) THEN - CALL DLACPY( 'All', M*K, M*K, DWORK, M*K, Q, LDQ ) - END IF - PDW = M*K*M*K + 1 - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, R(L+1,1), - $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C Compute the generator if P = 0. -C - IF ( P.EQ.0 ) THEN -C -C 1st column of the generator. -C - IF ( COMPQ ) THEN - CALL DLACPY( 'All', M*K, L, TC, LDTC, Q, LDQ ) - CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK(L+1), - $ LDWORK-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) - CALL MA02AD( 'Upper part', L, L, Q, LDQ, R, LDR ) - CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, - $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), - $ LDR, DWORK, LDWORK, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - ELSE - PDW = M*K*L + 1 - CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) - CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), DWORK(PDW+L), - $ LDWORK-PDW-L+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) - CALL MA02AD( 'Upper part', L, L, DWORK, M*K, R, LDR ) - CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK(PDW), - $ DWORK(PDW+L), LDWORK-PDW-L+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, - $ R(L+1,1), LDR, DWORK(PDW), LDWORK-PDW+1, - $ IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - DWORK(1) = DBLE( WRKOPT ) - RETURN - END IF -C -C 2nd column of the generator. -C - PNR = ( N - 1 )*L*K + 2 - CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(2), (N-1)*L ) -C -C 3rd and 4th column of the generator. -C - CALL DLACPY( 'All', (N-1)*L, L, R(L+1,1), LDR, DWORK(PNR), - $ (N-1)*L ) - PT = ( M - 1 )*K + 1 - PDW = PNR + ( N - 1 )*L*L -C - DO 10 I = 1, MIN( M, N-1 ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), - $ (N-1)*L ) - PT = PT - K - PDW = PDW + L - 10 CONTINUE -C - PT = 1 -C - DO 20 I = M + 1, N - 1 - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), - $ (N-1)*L ) - PT = PT + L - PDW = PDW + L - 20 CONTINUE -C - IF ( COMPQ ) THEN - PDQ = ( 2*K + L )*( N - 1 )*L + 2 - PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 - PNQ = PDQ + M*K*K - CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(PDQ), M*K ) - CALL DLASET( 'All', (M-1)*K, K, ZERO, ZERO, DWORK(PDQ+K), - $ M*K ) - CALL DLACPY( 'All', M*K, L, Q, LDQ, DWORK(PNQ), M*K ) - CALL DLASET( 'All', M*K, K, ZERO, ZERO, DWORK(PNQ+M*L*K), - $ M*K ) - ELSE - PDW = ( 2*K + L )*( N - 1 )*L + 2 - END IF - PRE = 1 - STPS = S - 1 - ELSE -C -C Set workspace pointers. -C - PNR = ( N - 1 )*L*K + 2 - IF ( COMPQ ) THEN - PDQ = ( 2*K + L )*( N - 1 )*L + 2 - PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 - PNQ = PDQ + M*K*K - ELSE - PDW = ( 2*K + L )*( N - 1 )*L + 2 - END IF - PRE = P - STPS = S - END IF -C -C Determine suitable size for the block Housholder reflectors. -C - IF ( COMPQ ) THEN - LEN = MAX( L + M*K, ( N - PRE + 1 )*L ) - ELSE - LEN = ( N - PRE + 1 )*L - END IF - NB = MIN( ILAENV( 1, 'DGELQF', ' ', LEN, L, -1, -1 ), L ) - KK = PDW + 6*L - 1 - WRKOPT = MAX( WRKOPT, KK + LEN*NB ) - KK = LDWORK - KK - IF ( KK.LT.LEN*NB ) NB = KK / LEN - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LEN, L, -1, -1 ) ) - IF ( NB.LT.NBMIN ) NB = 0 - COLR = L + 1 -C -C Generator reduction process. -C - LEN = ( N - PRE )*L - SHFR = ( PRE - 1 )*L - DO 30 I = PRE, PRE + STPS - 1 -C -C IF M*K < N*L the last block might have less than L columns. -C - KK = MIN( L, M*K - I*L ) - CALL DLACPY( 'Lower', LEN, KK, R(COLR-L,COLR-L), LDR, - $ R(COLR,COLR), LDR ) - CALL MB02CU( 'Column', KK, KK+K, L+K, NB, R(COLR,COLR), LDR, - $ DWORK(SHFR+2), (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, - $ RNK, IPVT, DWORK(PDW), ZERO, DWORK(PDW+6*L), - $ LDWORK-PDW-6*L+1, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The rank condition is (numerically) not -C satisfied. -C - INFO = 1 - RETURN - END IF - IF ( LEN.GT.KK ) THEN - CALL MB02CV( 'Column', 'NoStructure', KK, LEN-KK, KK+K, L+K, - $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), - $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, - $ R(COLR+KK,COLR), LDR, DWORK(SHFR+KK+2), - $ (N-1)*L, DWORK(PNR+SHFR+KK), (N-1)*L, - $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - END IF - IF ( COMPQ ) THEN - CALL DLASET( 'All', K, KK, ZERO, ZERO, Q(1,COLR), LDQ ) - IF ( M.GT.1 ) THEN - CALL DLACPY( 'All', (M-1)*K, KK, Q(1,COLR-L), LDQ, - $ Q(K+1,COLR), LDQ ) - END IF - CALL MB02CV( 'Column', 'NoStructure', KK, M*K, KK+K, L+K, - $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), - $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, Q(1,COLR), - $ LDQ, DWORK(PDQ), M*K, DWORK(PNQ), M*K, - $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, - $ IERR ) - END IF - LEN = LEN - L - COLR = COLR + L - SHFR = SHFR + L - 30 CONTINUE -C - DWORK(1) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of MB02JD *** - END diff --git a/slycot/src/MB02JX.f b/slycot/src/MB02JX.f deleted file mode 100644 index c941bd44..00000000 --- a/slycot/src/MB02JX.f +++ /dev/null @@ -1,737 +0,0 @@ - SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, - $ LDQ, R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a low rank QR factorization with column pivoting of a -C K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L); -C specifically, -C T -C T P = Q R , -C -C where R is lower trapezoidal, P is a block permutation matrix -C and Q^T Q = I. The number of columns in R is equivalent to the -C numerical rank of T with respect to the given tolerance TOL1. -C Note that the pivoting scheme is local, i.e., only columns -C belonging to the same block in T are permuted. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the output of the routine as follows: -C = 'Q': computes Q and R; -C = 'R': only computes R. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in one block of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in one block of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in one block column of T. M >= 0. -C -C N (input) INTEGER -C The number of blocks in one block row of T. N >= 0. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) -C The leading M*K-by-L part of this array must contain -C the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,M*K). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) -C The leading K-by-(N-1)*L part of this array must contain -C the first block row of T without the leading K-by-L -C block. -C -C LDTR INTEGER -C The leading dimension of the array TR. LDTR >= MAX(1,K). -C -C RNK (output) INTEGER -C The number of columns in R, which is equivalent to the -C numerical rank of T. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,RNK) -C If JOB = 'Q', then the leading M*K-by-RNK part of this -C array contains the factor Q. -C If JOB = 'R', then this array is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. -C LDQ >= MAX(1,M*K), if JOB = 'Q'; -C LDQ >= 1, if JOB = 'R'. -C -C R (output) DOUBLE PRECISION array, dimension (LDR,RNK) -C The leading N*L-by-RNK part of this array contains the -C lower trapezoidal factor R. -C -C LDR INTEGER -C The leading dimension of the array R. -C LDR >= MAX(1,N*L) -C -C JPVT (output) INTEGER array, dimension (MIN(M*K,N*L)) -C This array records the column pivoting performed. -C If JPVT(j) = k, then the j-th column of T*P was -C the k-th column of T. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If TOL1 >= 0.0, the user supplied diagonal tolerance; -C if TOL1 < 0.0, a default diagonal tolerance is used. -C -C TOL2 DOUBLE PRECISION -C If TOL2 >= 0.0, the user supplied offdiagonal tolerance; -C if TOL2 < 0.0, a default offdiagonal tolerance is used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; DWORK(2) and DWORK(3) return the used values -C for TOL1 and TOL2, respectively. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L -C + MAX(M*K,(N-1)*L) ), if JOB = 'Q'; -C LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, -C M*K*( L + 1 ) + L ), if JOB = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: due to perturbations induced by roundoff errors, or -C removal of nearly linearly dependent columns of the -C generator, the Schur algorithm encountered a -C situation where a diagonal element in the negative -C generator is larger in magnitude than the -C corresponding diagonal element in the positive -C generator (modulo TOL1); -C = 2: due to perturbations induced by roundoff errors, or -C removal of nearly linearly dependent columns of the -C generator, the Schur algorithm encountered a -C situation where diagonal elements in the positive -C and negative generator are equal in magnitude -C (modulo TOL1), but the offdiagonal elements suggest -C that these columns are not linearly dependent -C (modulo TOL2*ABS(diagonal element)). -C -C METHOD -C -C Householder transformations and modified hyperbolic rotations -C are used in the Schur algorithm [1], [2]. -C If, during the process, the hyperbolic norm of a row in the -C leading part of the generator is found to be less than or equal -C to TOL1, then this row is not reduced. If the difference of the -C corresponding columns has a norm less than or equal to TOL2 times -C the magnitude of the leading element, then this column is removed -C from the generator, as well as from R. Otherwise, the algorithm -C breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set -C to N*L*sqrt(eps) by default. -C If M*K > L, the columns of T are permuted so that the diagonal -C elements in one block column of R have decreasing magnitudes. -C -C REFERENCES -C -C [1] Kailath, T. and Sayed, A. -C Fast Reliable Algorithms for Matrices with Structure. -C SIAM Publications, Philadelphia, 1999. -C -C [2] Kressner, D. and Van Dooren, P. -C Factorizations and linear system solvers for matrices with -C Toeplitz structure. -C SLICOT Working Note 2000-2, 2000. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(K*RNK*L*M*N) floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001. -C D. Kressner, Technical Univ. Berlin, Germany, July 2002. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Householder transformation, matrix -C operations, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, M, N, - $ RNK - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), - $ TR(LDTR,*) - INTEGER JPVT(*) -C .. Local Scalars .. - LOGICAL COMPQ, LAST - INTEGER CPCOL, GAP, I, IERR, J, JJ, JWORK, KK, LEN, MK, - $ NZC, PDP, PDQ, PDW, PNQ, PNR, PP, PPR, PT, RDEF, - $ RRDF, RRNK, WRKMIN, WRKOPT - DOUBLE PRECISION LTOL1, LTOL2, NRM, TEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEQP3, DGEQRF, DLACPY, DLASET, - $ DORGQR, DSCAL, DSWAP, DTRMV, MA02AD, MB02CU, - $ MB02CV, MB02KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - WRKOPT = 3 - MK = M*K - COMPQ = LSAME( JOB, 'Q' ) - IF ( COMPQ ) THEN - WRKMIN = MAX( 3, ( MK + ( N - 1 )*L )*( L + 2*K ) + 9*L + - $ MAX( MK, ( N - 1 )*L ) ) - ELSE - WRKMIN = MAX( 3, MAX ( ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, - $ MK*( L + 1 ) + L ) ) - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( K.LT.0 ) THEN - INFO = -2 - ELSE IF ( L.LT.0 ) THEN - INFO = -3 - ELSE IF ( M.LT.0 ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDTC.LT.MAX( 1, MK ) ) THEN - INFO = -7 - ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN - INFO = -9 - ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.MK ) ) THEN - INFO = -12 - ELSE IF ( LDR.LT.MAX( 1, N*L ) ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02JX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, N, K, L ).EQ.0 ) THEN - RNK = 0 - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = ZERO - DWORK(3) = ZERO - RETURN - END IF -C - WRKOPT = WRKMIN -C - IF ( MK.LE.L ) THEN -C -C Catch M*K <= L. -C - CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) - PDW = MK*L + 1 - JWORK = PDW + MK - CALL DGEQRF( MK, L, DWORK, MK, DWORK(PDW), DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - CALL MA02AD( 'Upper part', MK, L, DWORK, MK, R, LDR ) - CALL DORGQR( MK, MK, MK, DWORK, MK, DWORK(PDW), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( COMPQ ) - $ CALL DLACPY( 'All', MK, MK, DWORK, MK, Q, LDQ ) - PDW = MK*MK + 1 - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, MK, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), - $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - DO 10 I = 1, MK - JPVT(I) = I - 10 CONTINUE -C - RNK = MK - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = ZERO - DWORK(3) = ZERO - RETURN - END IF -C -C Compute the generator: -C -C 1st column of the generator. -C - DO 20 I = 1, L - JPVT(I) = 0 - 20 CONTINUE -C - LTOL1 = TOL1 - LTOL2 = TOL2 -C - IF ( COMPQ ) THEN - CALL DLACPY( 'All', MK, L, TC, LDTC, Q, LDQ ) - CALL DGEQP3( MK, L, Q, LDQ, JPVT, DWORK, DWORK(L+1), - $ LDWORK-L, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) -C - IF ( LTOL1.LT.ZERO ) THEN -C -C Compute default tolerance LTOL1. -C -C Estimate the 2-norm of the first block column of the -C matrix with 5 power iterations. -C - TEMP = ONE / SQRT( DBLE( L ) ) - CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(L+1), 1 ) -C - DO 30 I = 1, 5 - CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, Q, - $ LDQ, DWORK(L+1), 1 ) - CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, Q, LDQ, - $ DWORK(L+1), 1 ) - NRM = DNRM2( L, DWORK(L+1), 1 ) - CALL DSCAL( L, ONE/NRM, DWORK(L+1), 1 ) - 30 CONTINUE -C - LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) - END IF -C - I = L -C - 40 CONTINUE - IF ( ABS( Q(I,I) ).LE.LTOL1 ) THEN - I = I - 1 - IF ( I.GT.0 ) GO TO 40 - END IF -C - RRNK = I - RRDF = L - RRNK - CALL MA02AD( 'Upper', RRNK, L, Q, LDQ, R, LDR ) - IF ( RRNK.GT.1 ) - $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) - CALL DORGQR( MK, L, RRNK, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, - $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), - $ LDR, DWORK, LDWORK, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C - ELSE -C - PDW = MK*L + 1 - JWORK = PDW + L - CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) - CALL DGEQP3( MK, L, DWORK, MK, JPVT, DWORK(PDW), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - IF ( LTOL1.LT.ZERO ) THEN -C -C Compute default tolerance LTOL1. -C -C Estimate the 2-norm of the first block column of the -C matrix with 5 power iterations. -C - TEMP = ONE / SQRT( DBLE( L ) ) - CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(JWORK), 1 ) -C - DO 50 I = 1, 5 - CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, DWORK, - $ MK, DWORK(JWORK), 1 ) - CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, DWORK, - $ MK, DWORK(JWORK), 1 ) - NRM = DNRM2( L, DWORK(JWORK), 1 ) - CALL DSCAL( L, ONE/NRM, DWORK(JWORK), 1 ) - 50 CONTINUE -C - LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) - END IF -C - RRNK = L - I = ( L - 1 )*MK + L -C - 60 CONTINUE - IF ( ABS( DWORK(I) ).LE.LTOL1 ) THEN - RRNK = RRNK - 1 - I = I - MK - 1 - IF ( I.GT.0 ) GO TO 60 - END IF -C - RRDF = L - RRNK - CALL MA02AD( 'Upper part', RRNK, L, DWORK, MK, R, LDR ) - IF ( RRNK.GT.1 ) - $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) - CALL DORGQR( MK, L, RRNK, DWORK, MK, DWORK(PDW), - $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( N.GT.1 ) THEN - CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, - $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), - $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - END IF - END IF -C -C Quick return if N = 1. -C - IF ( N.EQ.1 ) THEN - RNK = RRNK - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = LTOL1 - DWORK(3) = ZERO - RETURN - END IF -C -C Compute default tolerance LTOL2. -C - IF ( LTOL2.LT.ZERO ) - $ LTOL2 = DBLE( N*L )*SQRT( DLAMCH( 'Epsilon' ) ) -C - DO 70 J = 1, L - CALL DCOPY( RRNK, R(J,1), LDR, R(L+JPVT(J),RRNK+1), LDR ) - 70 CONTINUE -C - IF ( N.GT.2 ) - $ CALL DLACPY( 'All', (N-2)*L, RRNK, R(L+1,1), LDR, - $ R(2*L+1,RRNK+1), LDR ) -C -C 2nd column of the generator. -C - IF ( RRDF.GT.0 ) - $ CALL MA02AD( 'All', MIN( RRDF, K ), (N-1)*L, TR, LDTR, - $ R(L+1,2*RRNK+1), LDR ) - IF ( K.GT.RRDF ) - $ CALL MA02AD( 'All', K-RRDF, (N-1)*L, TR(RRDF+1,1), LDTR, DWORK, - $ (N-1)*L ) -C -C 3rd column of the generator. -C - PNR = ( N - 1 )*L*MAX( 0, K-RRDF ) + 1 - CALL DLACPY( 'All', (N-1)*L, RRNK, R(L+1,1), LDR, DWORK(PNR), - $ (N-1)*L ) -C -C 4th column of the generator. -C - PDW = PNR + ( N - 1 )*L*RRNK - PT = ( M - 1 )*K + 1 -C - DO 80 I = 1, MIN( M, N-1 ) - CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), (N-1)*L ) - PT = PT - K - PDW = PDW + L - 80 CONTINUE -C - PT = 1 -C - DO 90 I = M + 1, N - 1 - CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), (N-1)*L ) - PT = PT + L - PDW = PDW + L - 90 CONTINUE -C - IF ( COMPQ ) THEN - PDQ = PNR + ( N - 1 )*L*( RRNK + K ) - PNQ = PDQ + MK*MAX( 0, K-RRDF ) - PDW = PNQ + MK*( RRNK + K ) - CALL DLACPY( 'All', MK, RRNK, Q, LDQ, DWORK(PNQ), MK ) - IF ( M.GT.1 ) - $ CALL DLACPY( 'All', (M-1)*K, RRNK, Q, LDQ, Q(K+1,RRNK+1), - $ LDQ ) - CALL DLASET( 'All', K, RRNK, ZERO, ZERO, Q(1,RRNK+1), LDQ ) - IF ( RRDF.GT.0 ) - $ CALL DLASET( 'All', MK, RRDF, ZERO, ONE, Q(1,2*RRNK+1), - $ LDQ ) - CALL DLASET( 'All', RRDF, MAX( 0, K-RRDF ), ZERO, ZERO, - $ DWORK(PDQ), MK ) - CALL DLASET( 'All', M*K-RRDF, MAX( 0, K-RRDF ), ZERO, ONE, - $ DWORK(PDQ+RRDF), MK ) - CALL DLASET( 'All', MK, K, ZERO, ZERO, DWORK(PNQ+MK*RRNK), MK ) - ELSE - PDW = PNR + ( N - 1 )*L*( RRNK + K ) - END IF - PPR = 1 - RNK = RRNK - RDEF = RRDF - LEN = N*L - GAP = N*L - MIN( N*L, MK ) -C -C KK is the number of columns in the leading part of the -C generator. After sufficiently many rank drops or if -C M*K < N*L it may be less than L. -C - KK = MIN( L+K-RDEF, L ) - KK = MIN( KK, MK-L ) -C -C Generator reduction process. -C - DO 190 I = L + 1, MIN( MK, N*L ), L - IF ( I+L.LE.MIN( MK, N*L ) ) THEN - LAST = .FALSE. - ELSE - LAST = .TRUE. - END IF - PP = KK + MAX( K - RDEF, 0 ) - LEN = LEN - L - CALL MB02CU( 'Deficient', KK, PP, L+K-RDEF, -1, R(I,RNK+1), - $ LDR, DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, - $ RRNK, JPVT(I), DWORK(PDW), LTOL1, DWORK(PDW+5*L), - $ LDWORK-PDW-5*L+1, IERR ) - IF ( IERR.NE.0 ) THEN -C -C Error return: The current generator is indefinite. -C - INFO = 1 - RETURN - END IF -C -C Apply pivoting to other columns of R. -C - PDP = PDW + 6*L - I -C - DO 100 J = I, I + KK - 1 - JPVT(J) = JPVT(J) + I - 1 - DWORK(PDP+JPVT(J)) = DBLE(J) - 100 CONTINUE -C - DO 120 J = I, I + KK - 1 - TEMP = DBLE(J) - JJ = J-1 -C - 110 CONTINUE - JJ = JJ + 1 - IF ( DWORK(PDP+JJ).NE.TEMP ) GO TO 110 -C - IF ( JJ.NE.J ) THEN - DWORK(PDP+JJ) = DWORK(PDP+J) - CALL DSWAP( RNK, R(J,1), LDR, R(JJ,1), LDR ) - END IF - 120 CONTINUE -C - DO 130 J = I + KK, I + L - 1 - JPVT(J) = J - 130 CONTINUE -C -C Apply reduction to other rows of R. -C - IF ( LEN.GT.KK ) THEN - CALL MB02CV( 'Deficient', 'NoStructure', KK, LEN-KK, PP, - $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, - $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, - $ R(I+KK,RNK+1), LDR, DWORK(PPR+KK), (N-1)*L, - $ DWORK(PNR+KK), (N-1)*L, DWORK(PDW), - $ DWORK(PDW+5*L), LDWORK-PDW-5*L+1, IERR ) - END IF -C -C Apply reduction to Q. -C - IF ( COMPQ ) THEN - CALL MB02CV( 'Deficient', 'NoStructure', KK, MK, PP, - $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, - $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, - $ Q(1,RNK+1), LDQ, DWORK(PDQ), MK, DWORK(PNQ), - $ MK, DWORK(PDW), DWORK(PDW+5*L), - $ LDWORK-PDW-5*L+1, IERR ) - END IF -C -C Inspection of the rank deficient columns: -C Look for small diagonal entries. -C - NZC = 0 -C - DO 140 J = KK, RRNK + 1, -1 - IF ( ABS( R(I+J-1,RNK+J) ).LE.LTOL1 ) NZC = NZC + 1 - 140 CONTINUE -C -C The last NZC columns of the generator cannot be removed. -C Now, decide whether for the other rank deficient columns -C it is safe to remove. -C - PT = PNR -C - DO 150 J = RRNK + 1, KK - NZC - TEMP = R(I+J-1,RNK+J) - CALL DSCAL( LEN-J-GAP, TEMP, R(I+J,RNK+J), 1 ) - CALL DAXPY( LEN-J-GAP, -DWORK(PT+J-1), DWORK(PT+J), 1, - $ R(I+J,RNK+J), 1 ) - IF ( DNRM2( LEN-J-GAP, R(I+J,RNK+J), 1 ) - $ .GT.LTOL2*ABS( TEMP ) ) THEN -C -C Unlucky case: -C It is neither advisable to remove the whole column nor -C possible to remove the diagonal entries by Hyperbolic -C rotations. -C - INFO = 2 - RETURN - END IF - PT = PT + ( N - 1 )*L - 150 CONTINUE -C -C Annihilate unwanted elements in the factor R. -C - RRDF = KK - RRNK - CALL DLASET( 'All', I-1, RRNK, ZERO, ZERO, R(1,RNK+1), LDR ) - CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(I,RNK+2), - $ LDR ) -C -C Construct the generator for the next step. -C - IF ( .NOT.LAST ) THEN -C -C Compute KK for the next step. -C - KK = MIN( L+K-RDEF-RRDF+NZC, L ) - KK = MIN( KK, MK-I-L+1 ) -C - IF ( KK.LE.0 ) THEN - RNK = RNK + RRNK - GO TO 200 - END IF -C - CALL DLASET( 'All', L, RRDF, ZERO, ZERO, R(I,RNK+RRNK+1), - $ LDR ) -C -C The columns with small diagonal entries form parts of the -C new positive generator. -C - IF ( ( RRDF-NZC ).GT.0 .AND. NZC.GT.0 ) THEN - CPCOL = MIN( NZC, KK ) -C - DO 160 J = RNK + RRNK + 1, RNK + RRNK + CPCOL - CALL DCOPY( LEN-L, R(I+L,J+RRDF-NZC), 1, - $ R(I+L,J), 1 ) - 160 CONTINUE -C - END IF -C -C Construct the leading parts of the positive generator. -C - CPCOL = MIN( RRNK, KK-NZC ) - IF ( CPCOL.GT.0 ) THEN -C - DO 170 J = I, I + L - 1 - CALL DCOPY( CPCOL, R(J,RNK+1), LDR, - $ R(JPVT(J)+L,RNK+RRNK+NZC+1), LDR ) - 170 CONTINUE -C - IF ( LEN.GT.2*L ) THEN - CALL DLACPY( 'All', LEN-2*L, CPCOL, R(I+L,RNK+1), LDR, - $ R(I+2*L,RNK+RRNK+NZC+1), LDR ) - END IF - END IF - PPR = PPR + L -C -C Refill the leading parts of the positive generator. -C - CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) - IF ( CPCOL.GT.0 ) THEN - CALL DLACPY( 'All', LEN-L, CPCOL, DWORK(PPR), (N-1)*L, - $ R(I+L,RNK+2*RRNK+NZC+1), LDR ) - PPR = PPR + CPCOL*( N - 1 )*L - END IF - PNR = PNR + ( RRDF - NZC )*( N - 1 )*L + L -C -C Do the same things for Q. -C - IF ( COMPQ ) THEN - IF ( ( RRDF - NZC ).GT.0 .AND. NZC.GT.0 ) THEN - CPCOL = MIN( NZC, KK ) -C - DO 180 J = RNK + RRNK + 1, RNK + RRNK + CPCOL - CALL DCOPY( MK, Q(1,J+RRDF-NZC), 1, Q(1,J), 1 ) - 180 CONTINUE -C - END IF - CPCOL = MIN( RRNK, KK-NZC ) - IF ( CPCOL.GT.0 ) THEN - CALL DLASET( 'All', K, CPCOL, ZERO, ZERO, - $ Q(1,RNK+RRNK+NZC+1), LDQ ) - IF ( M.GT.1 ) - $ CALL DLACPY( 'All', (M-1)*K, CPCOL, Q(1,RNK+1), - $ LDQ, Q(K+1,RNK+RRNK+NZC+1), LDQ ) - END IF - CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) - IF ( CPCOL.GT.0 ) THEN - CALL DLACPY( 'All', MK, CPCOL, DWORK(PDQ), MK, - $ Q(1,RNK+2*RRNK+NZC+1), LDQ ) - PDQ = PDQ + CPCOL*MK - END IF - PNQ = PNQ + ( RRDF - NZC )*MK - END IF - END IF - RNK = RNK + RRNK - RDEF = RDEF + RRDF - NZC - 190 CONTINUE -C - 200 CONTINUE - DWORK(1) = DBLE( WRKOPT ) - DWORK(2) = LTOL1 - DWORK(3) = LTOL2 -C -C *** Last line of MB02JX *** - END diff --git a/slycot/src/MB02KD.f b/slycot/src/MB02KD.f deleted file mode 100644 index c45c7cd6..00000000 --- a/slycot/src/MB02KD.f +++ /dev/null @@ -1,842 +0,0 @@ - SUBROUTINE MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, - $ TC, LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix product -C -C C = alpha*op( T )*B + beta*C, -C -C where alpha and beta are scalars and T is a block Toeplitz matrix -C specified by its first block column TC and first block row TR; -C B and C are general matrices of appropriate dimensions. -C -C ARGUMENTS -C -C Mode Parameters -C -C LDBLK CHARACTER*1 -C Specifies where the (1,1)-block of T is stored, as -C follows: -C = 'C': in the first block of TC; -C = 'R': in the first block of TR. -C -C TRANS CHARACTER*1 -C Specifies the form of op( T ) to be used in the matrix -C multiplication as follows: -C = 'N': op( T ) = T; -C = 'T': op( T ) = T'; -C = 'C': op( T ) = T'. -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of rows in the blocks of T. K >= 0. -C -C L (input) INTEGER -C The number of columns in the blocks of T. L >= 0. -C -C M (input) INTEGER -C The number of blocks in the first block column of T. -C M >= 0. -C -C N (input) INTEGER -C The number of blocks in the first block row of T. N >= 0. -C -C R (input) INTEGER -C The number of columns in B and C. R >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then TC, TR and B -C are not referenced. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then C need not be set -C before entry. -C -C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) -C On entry with LDBLK = 'C', the leading M*K-by-L part of -C this array must contain the first block column of T. -C On entry with LDBLK = 'R', the leading (M-1)*K-by-L part -C of this array must contain the 2nd to the M-th blocks of -C the first block column of T. -C -C LDTC INTEGER -C The leading dimension of the array TC. -C LDTC >= MAX(1,M*K), if LDBLK = 'C'; -C LDTC >= MAX(1,(M-1)*K), if LDBLK = 'R'. -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,k) -C where k is (N-1)*L when LDBLK = 'C' and is N*L when -C LDBLK = 'R'. -C On entry with LDBLK = 'C', the leading K-by-(N-1)*L part -C of this array must contain the 2nd to the N-th blocks of -C the first block row of T. -C On entry with LDBLK = 'R', the leading K-by-N*L part of -C this array must contain the first block row of T. -C -C LDTR INTEGER -C The leading dimension of the array TR. LDTR >= MAX(1,K). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,R) -C On entry with TRANS = 'N', the leading N*L-by-R part of -C this array must contain the matrix B. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C M*K-by-R part of this array must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N*L), if TRANS = 'N'; -C LDB >= MAX(1,M*K), if TRANS = 'T' or TRANS = 'C'. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,R) -C On entry with TRANS = 'N', the leading M*K-by-R part of -C this array must contain the matrix C. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N*L-by-R part of this array must contain the matrix C. -C On exit with TRANS = 'N', the leading M*K-by-R part of -C this array contains the updated matrix C. -C On exit with TRANS = 'T' or TRANS = 'C', the leading -C N*L-by-R part of this array contains the updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= MAX(1,M*K), if TRANS = 'N'; -C LDC >= MAX(1,N*L), if TRANS = 'T' or TRANS = 'C'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C For point Toeplitz matrices or sufficiently large block Toeplitz -C matrices, this algorithm uses convolution algorithms based on -C the fast Hartley transforms [1]. Otherwise, TC is copied in -C reversed order into the workspace such that C can be computed from -C barely M matrix-by-matrix multiplications. -C -C REFERENCES -C -C [1] Van Loan, Charles. -C Computational frameworks for the fast Fourier transform. -C SIAM, 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O( (K*L+R*L+K*R)*(N+M)*log(N+M) + K*L*R ) -C floating point operations. -C -C CONTRIBUTOR -C -C D. Kressner, Technical Univ. Berlin, Germany, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, June 2001, -C March 2004. -C -C KEYWORDS -C -C Convolution, elementary matrix operations, -C fast Hartley transform, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, THOM50 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ THREE = 3.0D0, FOUR = 4.0D0, THOM50 = .95D3 ) -C .. Scalar Arguments .. - CHARACTER LDBLK, TRANS - INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, - $ R - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(*), TC(LDTC,*), - $ TR(LDTR,*) -C .. Local Scalars .. - LOGICAL FULLC, LMULT, LTRAN - CHARACTER*1 WGHT - INTEGER DIMB, DIMC, I, ICP, ICQ, IERR, IR, J, JJ, KK, - $ LEN, LL, LN, METH, MK, NL, P, P1, P2, PB, PC, - $ PDW, PP, PT, Q1, Q2, R1, R2, S1, S2, SHFT, WPOS, - $ WRKOPT - DOUBLE PRECISION CF, COEF, PARAM, SCAL, SF, T1, T2, TH -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DG01OD, DGEMM, DLACPY, DLASET, - $ DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, COS, DBLE, MAX, MIN, SIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - FULLC = LSAME( LDBLK, 'C' ) - LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - LMULT = ALPHA.NE.ZERO - MK = M*K - NL = N*L -C -C Check the scalar input parameters. -C - IF ( .NOT.( FULLC .OR. LSAME( LDBLK, 'R' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( K.LT.0 ) THEN - INFO = -3 - ELSE IF ( L.LT.0 ) THEN - INFO = -4 - ELSE IF ( M.LT.0 ) THEN - INFO = -5 - ELSE IF ( N.LT.0 ) THEN - INFO = -6 - ELSE IF ( R.LT.0 ) THEN - INFO = -7 - ELSE IF ( LMULT .AND. FULLC .AND. LDTC.LT.MAX( 1, MK ) ) THEN - INFO = -11 - ELSE IF ( LMULT .AND. .NOT.FULLC .AND. - $ LDTC.LT.MAX( 1,( M - 1 )*K ) ) THEN - INFO = -11 - ELSE IF ( LMULT .AND. LDTR.LT.MAX( 1, K ) ) THEN - INFO = -13 - ELSE IF ( LMULT .AND. .NOT.LTRAN .AND. LDB.LT.MAX( 1, NL ) ) THEN - INFO = -15 - ELSE IF ( LMULT .AND. LTRAN .AND. LDB.LT.MAX( 1, MK ) ) THEN - INFO = -15 - ELSE IF ( .NOT.LTRAN .AND. LDC.LT.MAX( 1, MK ) ) THEN - INFO = -17 - ELSE IF ( LTRAN .AND. LDC.LT.MAX( 1, NL ) ) THEN - INFO = -17 - ELSE IF ( LDWORK.LT.1 ) THEN - DWORK(1) = ONE - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02KD', -INFO ) - RETURN - END IF -C -C Scale C beforehand. -C - IF ( BETA.EQ.ZERO ) THEN - IF ( LTRAN ) THEN - CALL DLASET( 'All', NL, R, ZERO, ZERO, C, LDC ) - ELSE - CALL DLASET( 'All', MK, R, ZERO, ZERO, C, LDC ) - END IF - ELSE IF ( BETA.NE.ONE ) THEN - IF ( LTRAN ) THEN -C - DO 10 I = 1, R - CALL DSCAL( NL, BETA, C(1,I), 1 ) - 10 CONTINUE -C - ELSE -C - DO 20 I = 1, R - CALL DSCAL( MK, BETA, C(1,I), 1 ) - 20 CONTINUE -C - END IF - END IF -C -C Quick return if possible. -C - IF ( .NOT.LMULT .OR. MIN( MK, NL, R ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C The parameter PARAM is the watershed between conventional -C multiplication and convolution. This is of course depending -C on the used computer architecture. The lower this value is set -C the more likely the routine will use convolution to compute -C op( T )*B. Note that if there is enough workspace available, -C convolution is always used for point Toeplitz matrices. -C - PARAM = THOM50 -C -C Decide which method to choose, based on the block sizes and -C the available workspace. -C - LEN = 1 - P = 0 -C - 30 CONTINUE - IF ( LEN.LT.M+N-1 ) THEN - LEN = LEN*2 - P = P + 1 - GO TO 30 - END IF -C - COEF = THREE*DBLE( M*N )*DBLE( K*L )*DBLE( R ) / - $ DBLE( LEN*( K*L + L*R + K*R ) ) -C - IF ( FULLC ) THEN - P1 = MK*L - SHFT = 0 - ELSE - P1 = ( M - 1 )*K*L - SHFT = 1 - END IF - IF ( K*L.EQ.1 .AND. MIN( M, N ).GT.1 ) THEN - WRKOPT = LEN*( 2 + R ) - P - METH = 3 - ELSE IF ( ( LEN.LT.M*N ) .AND. ( COEF.GE.PARAM ) ) THEN - WRKOPT = LEN*( K*L + K*R + L*R + 1 ) - P - METH = 3 - ELSE - METH = 2 - WRKOPT = P1 - END IF -C - IF ( LDWORK.LT.WRKOPT ) METH = METH - 1 - IF ( LDWORK.LT.P1 ) METH = 1 -C -C Start computations. -C - IF ( METH.EQ.1 .AND. .NOT.LTRAN ) THEN -C -C Method 1 is the most unlucky way to multiply Toeplitz matrices -C with vectors. Due to the memory restrictions it is not -C possible to flip TC. -C - PC = 1 -C - DO 50 I = 1, M - PT = ( I - 1 - SHFT )*K + 1 - PB = 1 -C - DO 40 J = SHFT + 1, I - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, L, - $ ALPHA, TC(PT,1), LDTC, B(PB,1), LDB, ONE, - $ C(PC,1), LDC ) - PT = PT - K - PB = PB + L - 40 CONTINUE -C - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, - $ (N-I+SHFT)*L, ALPHA, TR, LDTR, B(PB,1), LDB, - $ ONE, C(PC,1), LDC ) - END IF - PC = PC + K - 50 CONTINUE -C - ELSE IF ( METH.EQ.1 .AND. LTRAN ) THEN -C - PB = 1 -C - DO 70 I = 1, M - PT = ( I - 1 - SHFT )*K + 1 - PC = 1 -C - DO 60 J = SHFT + 1, I - CALL DGEMM( 'Transpose', 'No Transpose', L, R, K, ALPHA, - $ TC(PT,1), LDTC, B(PB,1), LDB, ONE, C(PC,1), - $ LDC ) - PT = PT - K - PC = PC + L - 60 CONTINUE -C - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, - $ R, K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, - $ C(PC,1), LDC ) - END IF - PB = PB + K - 70 CONTINUE -C - ELSE IF ( METH.EQ.2 .AND. .NOT.LTRAN ) THEN -C -C In method 2 TC is flipped resulting in less calls to the BLAS -C routine DGEMM. Actually this seems often to be the best way to -C multiply with Toeplitz matrices except the point Toeplitz -C case. -C - PT = ( M - 1 - SHFT )*K + 1 -C - DO 80 I = 1, ( M - SHFT )*K*L, K*L - CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) - PT = PT - K - 80 CONTINUE -C - PT = ( M - 1 )*K*L + 1 - PC = 1 -C - DO 90 I = 1, M - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, - $ MIN( I-SHFT, N )*L, ALPHA, DWORK(PT), K, B, LDB, - $ ONE, C(PC,1), LDC ) - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', K, R, - $ (N-I+SHFT)*L, ALPHA, TR, LDTR, - $ B((I-SHFT)*L+1,1), LDB, ONE, C(PC,1), LDC ) - END IF - PC = PC + K - PT = PT - K*L - 90 CONTINUE -C - ELSE IF ( METH.EQ.2 .AND. LTRAN ) THEN -C - PT = ( M - 1 - SHFT )*K + 1 -C - DO 100 I = 1, ( M - SHFT )*K*L, K*L - CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) - PT = PT - K - 100 CONTINUE -C - PT = ( M - 1 )*K*L + 1 - PB = 1 -C - DO 110 I = 1, M - CALL DGEMM( 'Tranpose', 'No Transpose', MIN( I-SHFT, N )*L, - $ R, K, ALPHA, DWORK(PT), K, B(PB,1), LDB, ONE, - $ C, LDC ) - IF ( N.GT.I-SHFT ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, R, - $ K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, - $ C((I-SHFT)*L+1,1), LDC ) - END IF - PB = PB + K - PT = PT - K*L - 110 CONTINUE -C - ELSE IF ( METH.EQ.3 ) THEN -C -C In method 3 the matrix-vector product is computed by a suitable -C block convolution via fast Hartley transforms similar to the -C SLICOT routine DE01PD. -C -C Step 1: Copy input data into the workspace arrays. -C - PDW = 1 - IF ( LTRAN ) THEN - DIMB = K - DIMC = L - ELSE - DIMB = L - DIMC = K - END IF - PB = LEN*K*L - PC = LEN*( K*L + DIMB*R ) - IF ( LTRAN ) THEN - IF ( FULLC ) THEN - CALL DLACPY( 'All', K, L, TC, LDTC, DWORK, LEN*K ) - END IF -C - DO 120 I = 1, N - 1 + SHFT - CALL DLACPY( 'All', K, L, TR(1,(I-1)*L+1), LDTR, - $ DWORK((I-SHFT)*K+1), LEN*K ) - 120 CONTINUE -C - PDW = N*K + 1 - R1 = ( LEN - M - N + 1 )*K - CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) - PDW = PDW + R1 -C - DO 130 I = ( M - 1 - SHFT )*K + 1, K - SHFT*K + 1, -K - CALL DLACPY( 'All', K, L, TC(I,1), LDTC, - $ DWORK(PDW), LEN*K ) - PDW = PDW + K - 130 CONTINUE -C - PDW = PB + 1 - CALL DLACPY( 'All', MK, R, B, LDB, DWORK(PDW), LEN*K ) - PDW = PDW + MK - CALL DLASET( 'All', (LEN-M)*K, R, ZERO, ZERO, DWORK(PDW), - $ LEN*K ) - ELSE - IF ( .NOT.FULLC ) THEN - CALL DLACPY( 'All', K, L, TR, LDTR, DWORK, LEN*K ) - END IF - CALL DLACPY( 'All', (M-SHFT)*K, L, TC, LDTC, - $ DWORK(SHFT*K+1), LEN*K ) - PDW = MK + 1 - R1 = ( LEN - M - N + 1 )*K - CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) - PDW = PDW + R1 -C - DO 140 I = ( N - 2 + SHFT )*L + 1, SHFT*L + 1, -L - CALL DLACPY( 'All', K, L, TR(1,I), LDTR, DWORK(PDW), - $ LEN*K ) - PDW = PDW + K - 140 CONTINUE -C - PDW = PB + 1 - CALL DLACPY( 'All', NL, R, B, LDB, DWORK(PDW), LEN*L ) - PDW = PDW + NL - CALL DLASET( 'All', (LEN-N)*L, R, ZERO, ZERO, DWORK(PDW), - $ LEN*L ) - END IF -C -C Take point Toeplitz matrices into extra consideration. -C - IF ( K*L.EQ.1 ) THEN - WGHT = 'N' - CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK, - $ DWORK(PC+1), IERR ) -C - DO 170 I = PB, PB + LEN*R - 1, LEN - CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK(I+1), - $ DWORK(PC+1), IERR ) - SCAL = ALPHA / DBLE( LEN ) - DWORK(I+1) = SCAL*DWORK(I+1)*DWORK(1) - DWORK(I+2) = SCAL*DWORK(I+2)*DWORK(2) - SCAL = SCAL / TWO -C - LN = 1 -C - DO 160 LL = 1, P - 1 - LN = 2*LN - R1 = 2*LN -C - DO 150 P1 = LN + 1, LN + LN/2 - T1 = DWORK(P1) + DWORK(R1) - T2 = DWORK(P1) - DWORK(R1) - TH = T2*DWORK(I+P1) - DWORK(I+P1) = SCAL*( T1*DWORK(I+P1) - $ + T2*DWORK(I+R1) ) - DWORK(I+R1) = SCAL*( T1*DWORK(I+R1) - TH ) - R1 = R1 - 1 - 150 CONTINUE -C - 160 CONTINUE -C - CALL DG01OD( 'InputScrambled', WGHT, LEN, DWORK(I+1), - $ DWORK(PC+1), IERR ) - 170 CONTINUE -C - PC = PB - GOTO 420 - END IF -C -C Step 2: Compute the weights for the Hartley transforms. -C - PDW = PC - R1 = 1 - LN = 1 - TH = FOUR*ATAN( ONE ) / DBLE( LEN ) -C - DO 190 LL = 1, P - 2 - LN = 2*LN - TH = TWO*TH - CF = COS( TH ) - SF = SIN( TH ) - DWORK(PDW+R1) = CF - DWORK(PDW+R1+1) = SF - R1 = R1 + 2 -C - DO 180 I = 1, LN-2, 2 - DWORK(PDW+R1) = CF*DWORK(PDW+I) - SF*DWORK(PDW+I+1) - DWORK(PDW+R1+1) = SF*DWORK(PDW+I) + CF*DWORK(PDW+I+1) - R1 = R1 + 2 - 180 CONTINUE -C - 190 CONTINUE -C - P1 = 3 - Q1 = R1 - 2 -C - DO 210 LL = P - 2, 1, -1 -C - DO 200 I = P1, Q1, 4 - DWORK(PDW+R1) = DWORK(PDW+I) - DWORK(PDW+R1+1) = DWORK(PDW+I+1) - R1 = R1 + 2 - 200 CONTINUE -C - P1 = Q1 + 4 - Q1 = R1 - 2 - 210 CONTINUE -C -C Step 3: Compute the Hartley transforms with scrambled output. -C - J = 0 - KK = K -C -C WHILE J < (L*LEN*K + R*LEN*DIMB), -C - 220 CONTINUE -C - LN = LEN - WPOS = PDW+1 -C - DO 270 PP = P - 1, 1, -1 - LN = LN / 2 - P2 = 1 - Q2 = LN*KK + 1 - R2 = ( LN/2 )*KK + 1 - S2 = R2 + Q2 - 1 -C - DO 260 I = 0, LEN/( 2*LN ) - 1 -C - DO 230 IR = 0, KK - 1 - T1 = DWORK(Q2+IR+J) - DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 - DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 - T1 = DWORK(S2+IR+J) - DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 - DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 - 230 CONTINUE -C - P1 = P2 + KK - Q1 = P1 + LN*KK - R1 = Q1 - 2*KK - S1 = R1 + LN*KK -C - DO 250 JJ = WPOS, WPOS + LN - 3, 2 - CF = DWORK(JJ) - SF = DWORK(JJ+1) -C - DO 240 IR = 0, KK-1 - T1 = DWORK(P1+IR+J) - DWORK(Q1+IR+J) - T2 = DWORK(R1+IR+J) - DWORK(S1+IR+J) - DWORK(P1+IR+J) = DWORK(P1+IR+J) + - $ DWORK(Q1+IR+J) - DWORK(R1+IR+J) = DWORK(R1+IR+J) + - $ DWORK(S1+IR+J) - DWORK(Q1+IR+J) = CF*T1 + SF*T2 - DWORK(S1+IR+J) = -CF*T2 + SF*T1 - 240 CONTINUE -C - P1 = P1 + KK - Q1 = Q1 + KK - R1 = R1 - KK - S1 = S1 - KK - 250 CONTINUE -C - P2 = P2 + 2*KK*LN - Q2 = Q2 + 2*KK*LN - R2 = R2 + 2*KK*LN - S2 = S2 + 2*KK*LN - 260 CONTINUE -C - WPOS = WPOS + LN - 2 - 270 CONTINUE -C - DO 290 ICP = KK + 1, LEN*KK, 2*KK - ICQ = ICP - KK -C - DO 280 IR = 0, KK - 1 - T1 = DWORK(ICP+IR+J) - DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 - DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 - 280 CONTINUE -C - 290 CONTINUE -C - J = J + LEN*KK - IF ( J.EQ.L*LEN*K ) THEN - KK = DIMB - END IF - IF ( J.LT.PC ) GOTO 220 -C END WHILE 220 -C -C Step 4: Compute a Hadamard like product. -C - CALL DCOPY( LEN-P, DWORK(PDW+1), 1,DWORK(PDW+1+R*LEN*DIMC), 1 ) - PDW = PDW + R*LEN*DIMC - SCAL = ALPHA / DBLE( LEN ) - P1 = 1 - R1 = LEN*K*L + 1 - S1 = R1 + LEN*DIMB*R - IF ( LTRAN ) THEN - KK = L - LL = K - ELSE - KK = K - LL = L - END IF - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), - $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), - $ LEN*DIMC ) - P1 = P1 + K - R1 = R1 + DIMB - S1 = S1 + DIMC - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), - $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), - $ LEN*DIMC ) - SCAL = SCAL / TWO - LN = 1 -C - DO 330 PP = 1, P - 1 - LN = 2*LN - P2 = ( 2*LN - 1 )*K + 1 - R1 = PB + LN*DIMB + 1 - R2 = PB + ( 2*LN - 1 )*DIMB + 1 - S1 = PC + LN*DIMC + 1 - S2 = PC + ( 2*LN - 1 )*DIMC + 1 -C - DO 320 P1 = LN*K + 1, ( LN + LN/2 )*K, K -C - DO 310 J = 0, LEN*K*( L - 1 ), LEN*K -C - DO 300 I = P1, P1 + K - 1 - T1 = DWORK(P2) - DWORK(P2) = DWORK(J+I) - T1 - DWORK(J+I) = DWORK(J+I) + T1 - P2 = P2 + 1 - 300 CONTINUE -C - P2 = P2 + ( LEN - 1 )*K - 310 CONTINUE -C - P2 = P2 - LEN*K*L - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, - $ DWORK(P1), LEN*K, DWORK(R1), LEN*DIMB, - $ ZERO, DWORK(S1), LEN*DIMC ) - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, - $ DWORK(P2), LEN*K, DWORK(R2), LEN*DIMB, ONE, - $ DWORK(S1), LEN*DIMC ) - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, - $ DWORK(P1), LEN*K, DWORK(R2), LEN*DIMB, ZERO, - $ DWORK(S2), LEN*DIMC ) - CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, -SCAL, - $ DWORK(P2), LEN*K, DWORK(R1), LEN*DIMB, ONE, - $ DWORK(S2), LEN*DIMC ) - P2 = P2 - K - R1 = R1 + DIMB - R2 = R2 - DIMB - S1 = S1 + DIMC - S2 = S2 - DIMC - 320 CONTINUE -C - 330 CONTINUE -C -C Step 5: Hartley transform with scrambled input. -C - DO 410 J = PC, PC + LEN*DIMC*R, LEN*DIMC -C - DO 350 ICP = DIMC + 1, LEN*DIMC, 2*DIMC - ICQ = ICP - DIMC -C - DO 340 IR = 0, DIMC - 1 - T1 = DWORK(ICP+IR+J) - DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 - DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 - 340 CONTINUE -C - 350 CONTINUE -C - LN = 1 - WPOS = PDW + LEN - 2*P + 1 -C - DO 400 PP = 1, P - 1 - LN = 2*LN - P2 = 1 - Q2 = LN*DIMC + 1 - R2 = ( LN/2 )*DIMC + 1 - S2 = R2 + Q2 - 1 -C - DO 390 I = 0, LEN/( 2*LN ) - 1 -C - DO 360 IR = 0, DIMC - 1 - T1 = DWORK(Q2+IR +J) - DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 - DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 - T1 = DWORK(S2+IR+J) - DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 - DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 - 360 CONTINUE -C - P1 = P2 + DIMC - Q1 = P1 + LN*DIMC - R1 = Q1 - 2*DIMC - S1 = R1 + LN*DIMC -C - DO 380 JJ = WPOS, WPOS + LN - 3, 2 - CF = DWORK(JJ) - SF = DWORK(JJ+1) -C - DO 370 IR = 0, DIMC - 1 - T1 = CF*DWORK(Q1+IR+J) + SF*DWORK(S1+IR+J) - T2 = -CF*DWORK(S1+IR+J) + SF*DWORK(Q1+IR+J) - DWORK(Q1+IR+J) = DWORK(P1+IR+J) - T1 - DWORK(P1+IR+J) = DWORK(P1+IR+J) + T1 - DWORK(S1+IR+J) = DWORK(R1+IR+J) - T2 - DWORK(R1+IR+J) = DWORK(R1+IR+J) + T2 - 370 CONTINUE -C - P1 = P1 + DIMC - Q1 = Q1 + DIMC - R1 = R1 - DIMC - S1 = S1 - DIMC - 380 CONTINUE -C - P2 = P2 + 2*DIMC*LN - Q2 = Q2 + 2*DIMC*LN - R2 = R2 + 2*DIMC*LN - S2 = S2 + 2*DIMC*LN - 390 CONTINUE -C - WPOS = WPOS - 2*LN + 2 - 400 CONTINUE -C - 410 CONTINUE -C -C Step 6: Copy data from workspace to output. -C - 420 CONTINUE -C - IF ( LTRAN ) THEN - I = NL - ELSE - I = MK - END IF -C - DO 430 J = 0, R - 1 - CALL DAXPY( I, ONE, DWORK(PC+(J*LEN*DIMC) + 1), 1, - $ C(1,J+1), 1 ) - 430 CONTINUE -C - END IF - DWORK(1) = DBLE( MAX( 1, WRKOPT ) ) - RETURN -C -C *** Last line of MB02KD *** - END diff --git a/slycot/src/MB02MD.f b/slycot/src/MB02MD.f deleted file mode 100644 index 28cbdada..00000000 --- a/slycot/src/MB02MD.f +++ /dev/null @@ -1,577 +0,0 @@ - SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the Total Least Squares (TLS) problem using a Singular -C Value Decomposition (SVD) approach. -C The TLS problem assumes an overdetermined set of linear equations -C AX = B, where both the data matrix A as well as the observation -C matrix B are inaccurate. The routine also solves determined and -C underdetermined sets of equations by computing the minimum norm -C solution. -C It is assumed that all preprocessing measures (scaling, coordinate -C transformations, whitening, ... ) of the data have been performed -C in advance. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Determines whether the values of the parameters RANK and -C TOL are to be specified by the user or computed by the -C routine as follows: -C = 'R': Compute RANK only; -C = 'T': Compute TOL only; -C = 'B': Compute both RANK and TOL; -C = 'N': Compute neither RANK nor TOL. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the data matrix A and the -C observation matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns in the data matrix A. N >= 0. -C -C L (input) INTEGER -C The number of columns in the observation matrix B. -C L >= 0. -C -C RANK (input/output) INTEGER -C On entry, if JOB = 'T' or JOB = 'N', then RANK must -C specify r, the rank of the TLS approximation [A+DA|B+DB]. -C RANK <= min(M,N). -C Otherwise, r is computed by the routine. -C On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then -C RANK contains the computed (effective) rank of the TLS -C approximation [A+DA|B+DB]. -C Otherwise, the user-supplied value of RANK may be -C changed by the routine on exit if the RANK-th and the -C (RANK+1)-th singular values of C = [A|B] are considered -C to be equal, or if the upper triangular matrix F (as -C defined in METHOD) is (numerically) singular. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) -C On entry, the leading M-by-(N+L) part of this array must -C contain the matrices A and B. Specifically, the first N -C columns must contain the data matrix A and the last L -C columns the observation matrix B (right-hand sides). -C On exit, the leading (N+L)-by-(N+L) part of this array -C contains the (transformed) right singular vectors, -C including null space vectors, if any, of C = [A|B]. -C Specifically, the leading (N+L)-by-RANK part of this array -C always contains the first RANK right singular vectors, -C corresponding to the largest singular values of C. If -C L = 0, or if RANK = 0 and IWARN <> 2, the remaining -C (N+L)-by-(N+L-RANK) top-right part of this array contains -C the remaining N+L-RANK right singular vectors. Otherwise, -C this part contains the matrix V2 transformed as described -C in Step 3 of the TLS algorithm (see METHOD). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= max(1,M,N+L). -C -C S (output) DOUBLE PRECISION array, dimension (min(M,N+L)) -C If INFO = 0, the singular values of matrix C, ordered -C such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0, -C where p = min(M,N+L). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,L) -C If INFO = 0, the leading N-by-L part of this array -C contains the solution X to the TLS problem specified -C by A and B. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= max(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance used to determine the rank of the TLS -C approximation [A+DA|B+DB] and to check the multiplicity -C of the singular values of matrix C. Specifically, S(i) -C and S(j) (i < j) are considered to be equal if -C SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation -C [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL, -C if TOL specifies sdev (see below)), for i = 1,2,...,r. -C TOL is also used to check the singularity of the upper -C triangular matrix F (as defined in METHOD). -C If JOB = 'R' or JOB = 'N', then TOL must specify the -C desired tolerance. If the user sets TOL to be less than or -C equal to 0, the tolerance is taken as EPS, where EPS is -C the machine precision (see LAPACK Library routine DLAMCH). -C Otherwise, the tolerance is computed by the routine and -C the user must supply the non-negative value sdev, i.e. the -C estimated standard deviation of the error on each element -C of the matrix C, as input value of TOL. -C -C Workspace -C -C IWORK INTEGER array, dimension (L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2) returns the reciprocal of the -C condition number of the matrix F. -C If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged -C non-diagonal elements of the bidiagonal matrix whose -C diagonal is in S (see LAPACK Library routine DGESVD). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max(2, 3*(N+L) + M, 5*(N+L)), if M >= N+L; -C LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L), -C if M < N+L. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warnings; -C = 1: if the rank of matrix C has been lowered because a -C singular value of multiplicity greater than 1 was -C found; -C = 2: if the rank of matrix C has been lowered because the -C upper triangular matrix F is (numerically) singular. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if the SVD algorithm (in LAPACK Library routine -C DBDSQR) has failed to converge. In this case, S(1), -C S(2), ..., S(INFO) may not have been found -C correctly and the remaining singular values may -C not be the smallest. This failure is not likely -C to occur. -C -C METHOD -C -C The method used is an extension (see [3,4,5]) of the classical -C TLS algorithm proposed by Golub and Van Loan [1]. -C -C Let [A|B] denote the matrix formed by adjoining the columns of B -C to the columns of A on the right. -C -C Total Least Squares (TLS) definition: -C ------------------------------------- -C -C Given matrices A and B, find a matrix X satisfying -C -C (A + DA) X = B + DB, -C -C where A and DA are M-by-N matrices, B and DB are M-by-L matrices -C and X is an N-by-L matrix. -C The solution X must be such that the Frobenius norm of [DA|DB] -C is a minimum and each column of B + DB is in the range of -C A + DA. Whenever the solution is not unique, the routine singles -C out the minimum norm solution X. -C -C Define matrix C = [A|B] and s(i) as its i-th singular value for -C i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0 -C for j = M+1,...,NL. -C -C The Classical TLS algorithm proceeds as follows (see [3,4,5]): -C -C Step 1: Compute part of the singular value decomposition (SVD) -C USV' of C = [A|B], namely compute S and V'. (An initial -C QR factorization of C is used when M is larger enough -C than NL.) -C -C Step 2: If not fixed by the user, compute the rank r0 of the data -C [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N', -C -C s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL). -C -C Otherwise, using [2], TOL can be computed from the -C standard deviation sdev of the errors on [A|B]: -C -C TOL = SQRT(2 * max(M,NL)) * sdev, -C -C and the rank r0 is determined (if JOB = 'R' or 'B') using -C -C s(1) >= ... >= s(r0) > TOL >= ... >= s(NL). -C -C The rank r of the approximation [A+DA|B+DB] is then equal -C to the minimum of N and r0. -C -C Step 3: Let V2 be the matrix of the columns of V corresponding to -C the (NL - r) smallest singular values of C, i.e. the last -C (NL - r) columns of V. -C Compute with Householder transformations the orthogonal -C matrix Q such that: -C -C |VH Y| -C V2 x Q = | | -C |0 F| -C -C where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix -C and F is an L-by-L upper triangular matrix. -C If F is singular, then lower the rank r with the -C multiplicity of s(r) and repeat this step. -C -C Step 4: If F is nonsingular then the solution X is obtained by -C solving the following equations by forward elimination: -C -C X F = -Y. -C -C Notes : -C The TLS solution is unique if r = N, F is nonsingular and -C s(N) > s(N+1). -C If F is singular, however, then the computed solution is infinite -C and hence does not satisfy the second TLS criterion (see TLS -C definition). For these cases, Golub and Van Loan [1] claim that -C the TLS problem has no solution. The properties of these so-called -C nongeneric problems are described in [4] and the TLS computations -C are generalized in order to solve them. As proven in [4], the -C proposed generalization satisfies the TLS criteria for any -C number L of observation vectors in B provided that, in addition, -C the solution | X| is constrained to be orthogonal to all vectors -C |-I| -C of the form |w| which belong to the space generated by the columns -C |0| -C of the submatrix |Y|. -C |F| -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C An Analysis of the Total Least-Squares Problem. -C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. -C -C [2] Staar, J., Vandewalle, J. and Wemans, M. -C Realization of Truncated Impulse Response Sequences with -C Prescribed Uncertainty. -C Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981. -C -C [3] Van Huffel, S. -C Analysis of the Total Least Squares Problem and its Use in -C Parameter Estimation. -C Doctoral dissertation, Dept. of Electr. Eng., Katholieke -C Universiteit Leuven, Belgium, June 1987. -C -C [4] Van Huffel, S. and Vandewalle, J. -C Analysis and Solution of the Nongeneric Total Least Squares -C Problem. -C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. -C -C [5] Van Huffel, S. and Vandewalle, J. -C The Total Least Squares Problem: Computational Aspects and -C Analysis. -C Series "Frontiers in Applied Mathematics", Vol. 9, -C SIAM, Philadelphia, 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm consists in (backward) stable steps. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB02AD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 24, 1997, Feb. 27, 2000, Oct. 19, 2003, Feb. 21, 2004. -C -C KEYWORDS -C -C Least-squares approximation, singular subspace, singular value -C decomposition, singular values, total least-squares. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION C(LDC,*), DWORK(*), S(*), X(LDX,*) -C .. Local Scalars .. - LOGICAL CRANK, CTOL, LJOBN, LJOBR, LJOBT - INTEGER ITAU, J, JWORK, LDW, K, MINMNL, N1, NL, P, R1, - $ WRKOPT - DOUBLE PRECISION FNORM, RCOND, SMAX, TOLTMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL DLAMCH, DLANGE, DLANTR, LSAME -C .. External Subroutines .. - EXTERNAL DGERQF, DGESVD, DLACPY, DLASET, DORMRQ, DSWAP, - $ DTRCON, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - NL = N + L - K = MAX( M, NL ) - P = MIN( M, N ) - MINMNL = MIN( M, NL ) - LDW = MAX( 3*MINMNL + K, 5*MINMNL ) - LJOBR = LSAME( JOB, 'R' ) - LJOBT = LSAME( JOB, 'T' ) - LJOBN = LSAME( JOB, 'N' ) -C -C Determine whether RANK or/and TOL is/are to be computed. -C - CRANK = .NOT.LJOBT .AND. .NOT.LJOBN - CTOL = .NOT.LJOBR .AND. .NOT.LJOBN -C -C Test the input scalar arguments. -C - IF( CTOL .AND. CRANK .AND. .NOT.LSAME( JOB, 'B' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( .NOT.CRANK .AND. RANK.GT.P ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( CTOL .AND. TOL.LT.ZERO ) THEN - INFO = -11 - ELSE IF( ( M.GE.NL .AND. LDWORK.LT.MAX( 2, LDW ) ).OR. - $ ( M.LT.NL .AND. LDWORK.LT.MAX( 2, M*NL + LDW, 3*L ) ) ) - $ THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB02MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( CRANK ) - $ RANK = P - IF ( MIN( M, NL ).EQ.0 ) THEN - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) - CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) - END IF - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C -C Subroutine MB02MD solves a set of linear equations by a Total -C Least Squares Approximation. -C -C Step 1: Compute part of the singular value decomposition (SVD) -C USV' of C = [A |B ], namely compute S and V'. -C M,N M,L -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( M.GE.NL ) THEN -C -C M >= N + L: Overwrite V' on C. -C Workspace: need max(3*min(M,N+L) + max(M,N+L), 5*min(M,N+L)). -C - JWORK = 1 - CALL DGESVD( 'No left vectors', 'Overwritten on C', M, NL, C, - $ LDC, S, DWORK, 1, DWORK, 1, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - ELSE -C -C M < N + L: Save C in the workspace and compute V' in C. -C Note that the previous DGESVD call cannot be used in this case. -C Workspace: need M*(N+L) + max(3*min(M,N+L) + max(M,N+L), -C 5*min(M,N+L)). -C - CALL DLACPY( 'Full', M, NL, C, LDC, DWORK, M ) - JWORK = M*NL + 1 - CALL DGESVD( 'No left vectors', 'All right vectors', M, NL, - $ DWORK, M, S, DWORK, 1, C, LDC, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - END IF -C - IF ( INFO.GT.0 ) THEN -C -C Save the unconverged non-diagonal elements of the bidiagonal -C matrix and exit. -C - DO 10 J = 1, MINMNL - 1 - DWORK(J) = DWORK(JWORK+J) - 10 CONTINUE -C - RETURN - END IF - WRKOPT = MAX( 2, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Transpose V' in-situ (in C). -C - DO 20 J = 2, NL - CALL DSWAP( J-1, C(J,1), LDC, C(1,J), 1 ) - 20 CONTINUE -C -C Step 2: Compute the rank of the approximation [A+DA|B+DB]. -C - IF ( CTOL ) THEN - TOLTMP = SQRT( TWO*DBLE( K ) )*TOL - SMAX = TOLTMP - ELSE - TOLTMP = TOL - IF ( TOLTMP.LE.ZERO ) TOLTMP = DLAMCH( 'Precision' ) - SMAX = MAX( TOLTMP*S(1), DLAMCH( 'Safe minimum' ) ) - END IF -C - IF ( CRANK ) THEN -C WHILE ( RANK .GT. 0 ) .AND. ( S(RANK) .LE. SMAX ) DO - 40 IF ( RANK.GT.0 ) THEN - IF ( S(RANK).LE.SMAX ) THEN - RANK = RANK - 1 - GO TO 40 - END IF - END IF -C END WHILE 40 - END IF -C - IF ( L.EQ.0 ) THEN - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C - N1 = N + 1 - ITAU = 1 - JWORK = ITAU + L -C -C Step 3: Compute the orthogonal matrix Q and matrices F and Y -C such that F is nonsingular. -C -C REPEAT -C -C Adjust the rank if S(RANK) has multiplicity greater than 1. -C - 60 CONTINUE - R1 = RANK + 1 - IF ( RANK.LT.MINMNL ) THEN -C WHILE RANK.GT.0 .AND. S(RANK)**2 - S(R1)**2.LE.TOL**2 DO - 80 IF ( RANK.GT.0 ) THEN - IF ( ONE - ( S(R1)/S(RANK) )**2.LE.( TOLTMP/S(RANK) )**2 - $ ) THEN - RANK = RANK - 1 - IWARN = 1 - GO TO 80 - END IF - END IF -C END WHILE 80 - END IF -C - IF ( RANK.EQ.0 ) THEN -C -C Return zero solution. -C - CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C -C Compute the orthogonal matrix Q (in factorized form) and the -C matrices F and Y using RQ factorization. It is assumed that, -C generically, the last L rows of V2 matrix have full rank. -C The code could not be the most efficient one when RANK has been -C lowered, because the already created zero pattern of the last -C L rows of V2 matrix is not exploited. -C Workspace: need 2*L; prefer L + L*NB. -C - R1 = RANK + 1 - CALL DGERQF( L, NL-RANK, C(N1,R1), LDC, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need N+L; prefer L + N*NB. -C - CALL DORMRQ( 'Right', 'Transpose', N, NL-RANK, L, C(N1,R1), - $ LDC, DWORK(ITAU), C(1,R1), LDC, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - CALL DLASET( 'Full', L, N-RANK, ZERO, ZERO, C(N1,R1), LDC ) - IF ( L.GT.1 ) - $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, C(N1+1,N1), - $ LDC ) -C -C Estimate the reciprocal condition number of the matrix F, -C and lower the rank if F can be considered as singular. -C Workspace: need 3*L. -C - CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, C(N1,N1), LDC, - $ RCOND, DWORK, IWORK, INFO ) - WRKOPT = MAX( WRKOPT, 3*L ) -C - FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, C(N1,N1), - $ LDC, DWORK ) - IF ( RCOND.LE.TOLTMP*FNORM ) THEN - RANK = RANK - 1 - IWARN = 2 - GO TO 60 - ELSE IF ( FNORM.LE.TOLTMP*DLANGE( '1-norm', N, L, C(1,N1), LDC, - $ DWORK ) ) THEN - RANK = RANK - L - IWARN = 2 - GO TO 60 - END IF -C UNTIL ( F nonsingular, i.e., RCOND.GT.TOL*FNORM or -C FNORM.GT.TOL*norm(Y) ) -C -C Step 4: Solve X F = -Y by forward elimination, -C (F is upper triangular). -C - CALL DLACPY( 'Full', N, L, C(1,N1), LDC, X, LDX ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, - $ -ONE, C(N1,N1), LDC, X, LDX ) -C -C Set the optimal workspace and reciprocal condition number of F. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of MB02MD *** - END diff --git a/slycot/src/MB02ND.f b/slycot/src/MB02ND.f deleted file mode 100644 index 04729602..00000000 --- a/slycot/src/MB02ND.f +++ /dev/null @@ -1,889 +0,0 @@ - SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, - $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the Total Least Squares (TLS) problem using a Partial -C Singular Value Decomposition (PSVD) approach. -C The TLS problem assumes an overdetermined set of linear equations -C AX = B, where both the data matrix A as well as the observation -C matrix B are inaccurate. The routine also solves determined and -C underdetermined sets of equations by computing the minimum norm -C solution. -C It is assumed that all preprocessing measures (scaling, coordinate -C transformations, whitening, ... ) of the data have been performed -C in advance. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the data matrix A and the -C observation matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns in the data matrix A. N >= 0. -C -C L (input) INTEGER -C The number of columns in the observation matrix B. -C L >= 0. -C -C RANK (input/output) INTEGER -C On entry, if RANK < 0, then the rank of the TLS -C approximation [A+DA|B+DB] (r say) is computed by the -C routine. -C Otherwise, RANK must specify the value of r. -C RANK <= min(M,N). -C On exit, if RANK < 0 on entry and INFO = 0, then RANK -C contains the computed rank of the TLS approximation -C [A+DA|B+DB]. -C Otherwise, the user-supplied value of RANK may be -C changed by the routine on exit if the RANK-th and the -C (RANK+1)-th singular values of C = [A|B] are considered -C to be equal, or if the upper triangular matrix F (as -C defined in METHOD) is (numerically) singular. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, if RANK < 0, then the rank of the TLS -C approximation [A+DA|B+DB] is computed using THETA as -C (min(M,N+L) - d), where d is the number of singular -C values of [A|B] <= THETA. THETA >= 0.0. -C Otherwise, THETA is an initial estimate (t say) for -C computing a lower bound on the RANK largest singular -C values of [A|B]. If THETA < 0.0 on entry however, then -C t is computed by the routine. -C On exit, if RANK >= 0 on entry, then THETA contains the -C computed bound such that precisely RANK singular values -C of C = [A|B] are greater than THETA + TOL. -C Otherwise, THETA is unchanged. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) -C On entry, the leading M-by-(N+L) part of this array must -C contain the matrices A and B. Specifically, the first N -C columns must contain the data matrix A and the last L -C columns the observation matrix B (right-hand sides). -C On exit, if INFO = 0, the first N+L components of the -C columns of this array whose index i corresponds with -C INUL(i) = .TRUE., are the possibly transformed (N+L-RANK) -C base vectors of the right singular subspace corresponding -C to the singular values of C = [A|B] which are less than or -C equal to THETA. Specifically, if L = 0, or if RANK = 0 and -C IWARN <> 2, these vectors are indeed the base vectors -C above. Otherwise, these vectors form the matrix V2, -C transformed as described in Step 4 of the PTLS algorithm -C (see METHOD). The TLS solution is computed from these -C vectors. The other columns of array C contain no useful -C information. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= max(1,M,N+L). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,L) -C If INFO = 0, the leading N-by-L part of this array -C contains the solution X to the TLS problem specified by -C A and B. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= max(1,N). -C -C Q (output) DOUBLE PRECISION array, dimension -C (max(1,2*min(M,N+L)-1)) -C This array contains the partially diagonalized bidiagonal -C matrix J computed from C, at the moment that the desired -C singular subspace has been found. Specifically, the -C leading p = min(M,N+L) entries of Q contain the diagonal -C elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2), -C ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2), -C ...,e(p-1) of J. -C -C INUL (output) LOGICAL array, dimension (N+L) -C The indices of the elements of this array with value -C .TRUE. indicate the columns in C containing the base -C vectors of the right singular subspace of C from which -C the TLS solution has been computed. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL is also taken -C as an absolute tolerance for negligible elements in the -C QR/QL iterations. If the user sets TOL to be less than or -C equal to 0, then the tolerance is taken as specified in -C SLICOT Library routine MB04YD document. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. If the user sets RELTOL to be less than -C BASE * EPS, where BASE is machine radix and EPS is machine -C precision (see LAPACK Library routine DLAMCH), then the -C tolerance is taken as BASE * EPS. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+2*L) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2) returns the reciprocal of the -C condition number of the matrix F. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max(2, max(M,N+L) + 2*min(M,N+L), -C min(M,N+L) + LW + max(6*(N+L)-5, -C L*L+max(N+L,3*L)), -C where -C LW = (N+L)*(N+L-1)/2, if M >= N+L, -C LW = M*(N+L-(M-1)/2), if M < N+L. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (N+L) -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warnings; -C = 1: if the rank of matrix C has been lowered because a -C singular value of multiplicity greater than 1 was -C found; -C = 2: if the rank of matrix C has been lowered because the -C upper triangular matrix F is (numerically) singular. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the maximum number of QR/QL iteration steps -C (30*MIN(M,N)) has been exceeded; -C = 2: if the computed rank of the TLS approximation -C [A+DA|B+DB] exceeds MIN(M,N). Try increasing the -C value of THETA or set the value of RANK to min(M,N). -C -C METHOD -C -C The method used is the Partial Total Least Squares (PTLS) approach -C proposed by Van Huffel and Vandewalle [5]. -C -C Let C = [A|B] denote the matrix formed by adjoining the columns of -C B to the columns of A on the right. -C -C Total Least Squares (TLS) definition: -C ------------------------------------- -C -C Given matrices A and B, find a matrix X satisfying -C -C (A + DA) X = B + DB, -C -C where A and DA are M-by-N matrices, B and DB are M-by-L matrices -C and X is an N-by-L matrix. -C The solution X must be such that the Frobenius norm of [DA|DB] -C is a minimum and each column of B + DB is in the range of -C A + DA. Whenever the solution is not unique, the routine singles -C out the minimum norm solution X. -C -C Let V denote the right singular subspace of C. Since the TLS -C solution can be computed from any orthogonal basis of the subspace -C of V corresponding to the smallest singular values of C, the -C Partial Singular Value Decomposition (PSVD) can be used instead of -C the classical SVD. The dimension of this subspace of V may be -C determined by the rank of C or by an upper bound for those -C smallest singular values. -C -C The PTLS algorithm proceeds as follows (see [2 - 5]): -C -C Step 1: Bidiagonalization phase -C ----------------------- -C (a) If M is large enough than N + L, transform C into upper -C triangular form R by Householder transformations. -C (b) Transform C (or R) into upper bidiagonal form -C (p = min(M,N+L)): -C -C |q(1) e(1) 0 ... 0 | -C (0) | 0 q(2) e(2) . | -C J = | . . | -C | . e(p-1)| -C | 0 ... q(p) | -C -C if M >= N + L, or lower bidiagonal form: -C -C |q(1) 0 0 ... 0 0 | -C (0) |e(1) q(2) 0 . . | -C J = | . . . | -C | . q(p) . | -C | 0 ... e(p-1) q(p)| -C -C if M < N + L, using Householder transformations. -C In the second case, transform the matrix to the upper -C bidiagonal form by applying Givens rotations. -C (c) Initialize the right singular base matrix with the identity -C matrix. -C -C Step 2: Partial diagonalization phase -C ----------------------------- -C If the upper bound THETA is not given, then compute THETA such -C that precisely p - RANK singular values (p=min(M,N+L)) of the -C bidiagonal matrix are less than or equal to THETA, using a -C bisection method [5]. Diagonalize the given bidiagonal matrix J -C partially, using either QL iterations (if the upper left diagonal -C element of the considered bidiagonal submatrix is smaller than the -C lower right diagonal element) or QR iterations, such that J is -C split into unreduced bidiagonal submatrices whose singular values -C are either all larger than THETA or are all less than or equal -C to THETA. Accumulate the Givens rotations in V. -C -C Step 3: Back transformation phase -C ------------------------- -C Apply the Householder transformations of Step 1(b) onto the base -C vectors of V associated with the bidiagonal submatrices with all -C singular values less than or equal to THETA. -C -C Step 4: Computation of F and Y -C ---------------------- -C Let V2 be the matrix of the columns of V corresponding to the -C (N + L - RANK) smallest singular values of C. -C Compute with Householder transformations the matrices F and Y -C such that: -C -C |VH Y| -C V2 x Q = | | -C |0 F| -C -C where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix, -C Y is an N-by-L matrix and F is an L-by-L upper triangular matrix. -C If F is singular, then reduce the value of RANK by one and repeat -C Steps 2, 3 and 4. -C -C Step 5: Computation of the TLS solution -C ------------------------------- -C If F is non-singular then the solution X is obtained by solving -C the following equations by forward elimination: -C -C X F = -Y. -C -C Notes: -C If RANK is lowered in Step 4, some additional base vectors must -C be computed in Step 2. The additional computations are kept to -C a minimum. -C If RANK is lowered in Step 4 but the multiplicity of the RANK-th -C singular value is larger than 1, then the value of RANK is further -C lowered with its multiplicity defined by the parameter TOL. This -C is done at the beginning of Step 2 by calling SLICOT Library -C routine MB03MD (from MB04YD), which estimates THETA using a -C bisection method. If F in Step 4 is singular, then the computed -C solution is infinite and hence does not satisfy the second TLS -C criterion (see TLS definition). For these cases, Golub and -C Van Loan [1] claim that the TLS problem has no solution. The -C properties of these so-called nongeneric problems are described -C in [6] and the TLS computations are generalized in order to solve -C them. As proven in [6], the proposed generalization satisfies the -C TLS criteria for any number L of observation vectors in B provided -C that, in addition, the solution | X| is constrained to be -C |-I| -C orthogonal to all vectors of the form |w| which belong to the -C |0| -C space generated by the columns of the submatrix |Y|. -C |F| -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C An Analysis of the Total Least-Squares Problem. -C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. -C -C [2] Van Huffel, S., Vandewalle, J. and Haegemans, A. -C An Efficient and Reliable Algorithm for Computing the -C Singular Subspace of a Matrix Associated with its Smallest -C Singular Values. -C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. -C -C [3] Van Huffel, S. -C Analysis of the Total Least Squares Problem and its Use in -C Parameter Estimation. -C Doctoral dissertation, Dept. of Electr. Eng., Katholieke -C Universiteit Leuven, Belgium, June 1987. -C -C [4] Chan, T.F. -C An Improved Algorithm for Computing the Singular Value -C Decomposition. -C ACM TOMS, 8, pp. 72-83, 1982. -C -C [5] Van Huffel, S. and Vandewalle, J. -C The Partial Total Least Squares Algorithm. -C J. Comput. Appl. Math., 21, pp. 333-341, 1988. -C -C [6] Van Huffel, S. and Vandewalle, J. -C Analysis and Solution of the Nongeneric Total Least Squares -C Problem. -C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. -C -C NUMERICAL ASPECTS -C -C The computational efficiency of the PTLS algorithm compared with -C the classical TLS algorithm (see [2 - 5]) is obtained by making -C use of PSVD (see [1]) instead of performing the entire SVD. -C Depending on the gap between the RANK-th and the (RANK+1)-th -C singular values of C, the number (N + L - RANK) of base vectors to -C be computed with respect to the column dimension (N + L) of C and -C the desired accuracy RELTOL, the algorithm used by this routine is -C approximately twice as fast as the classical TLS algorithm at the -C expense of extra storage requirements, namely: -C (N + L) x (N + L - 1)/2 if M >= N + L or -C M x (N + L - (M - 1)/2) if M < N + L. -C This is because the Householder transformations performed on the -C rows of C in the bidiagonalization phase (see Step 1) must be kept -C until the end (Step 5). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB02BD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 30, 1997, Oct. 19, 2003, Feb. 15, 2004. -C -C KEYWORDS -C -C Least-squares approximation, singular subspace, singular value -C decomposition, singular values, total least-squares. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK - DOUBLE PRECISION RELTOL, THETA, TOL -C .. Array Arguments .. - LOGICAL BWORK(*), INUL(*) - INTEGER IWORK(*) - DOUBLE PRECISION C(LDC,*), DWORK(*), Q(*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LFIRST, SUFWRK - INTEGER I, I1, IFAIL, IHOUSH, IJ, IOFF, ITAUP, ITAUQ, - $ IWARM, J, J1, JF, JV, JWORK, K, KF, KJ, LDF, LW, - $ MC, MJ, MNL, N1, NJ, NL, P, WRKOPT - DOUBLE PRECISION CS, EPS, FIRST, FNORM, HH, INPROD, RCOND, SN, - $ TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL DLAMCH, DLANGE, DLANTR, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBRD, DGEQRF, DGERQF, DLARF, DLARFG, - $ DLARTG, DLASET, DORMBR, DORMRQ, DTRCON, DTRSM, - $ MB04YD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - NL = N + L - K = MAX( M, NL ) - P = MIN( M, NL ) - IF ( M.GE.NL ) THEN - LW = ( NL*( NL - 1 ) )/2 - ELSE - LW = M*NL - ( M*( M - 1 ) )/2 - END IF - JV = P + LW + MAX( 6*NL - 5, L*L + MAX( NL, 3*L ) ) -C -C Test the input scalar arguments. -C - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( L.LT.0 ) THEN - INFO = -3 - ELSE IF( RANK.GT.MIN( M, N ) ) THEN - INFO = -4 - ELSE IF( ( RANK.LT.0 ) .AND. ( THETA.LT.ZERO ) ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDWORK.LT.MAX( 2, K + 2*P, JV ) ) THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB02ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, NL ).EQ.0 ) THEN - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) - CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) -C - DO 10 I = 1, NL - INUL(I) = .TRUE. - 10 CONTINUE -C - END IF - IF ( RANK.GE.0 ) - $ THETA = ZERO - RANK = 0 - DWORK(1) = TWO - DWORK(2) = ONE - RETURN - END IF -C - WRKOPT = 2 - N1 = N + 1 -C - EPS = DLAMCH( 'Precision' ) - LFIRST = .TRUE. -C -C Initializations. -C - DO 20 I = 1, P - INUL(I) = .FALSE. - BWORK(I) = .FALSE. - 20 CONTINUE -C - DO 40 I = P + 1, NL - INUL(I) = .TRUE. - BWORK(I) = .FALSE. - 40 CONTINUE -C -C Subroutine MB02ND solves a set of linear equations by a Total -C Least Squares Approximation, based on the Partial SVD. -C -C Step 1: Bidiagonalization phase -C ----------------------- -C 1.a): If M is large enough than N+L, transform C into upper -C triangular form R by Householder transformations. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( M.GE.MAX( NL, - $ ILAENV( 6, 'DGESVD', 'N' // 'N', M, NL, 0, 0 ) ) ) - $ THEN -C -C Workspace: need 2*(N+L), -C prefer N+L + (N+L)*NB. -C - ITAUQ = 1 - JWORK = ITAUQ + NL - CALL DGEQRF( M, NL, C, LDC, DWORK(ITAUQ), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - IF ( NL.GT.1 ) - $ CALL DLASET( 'Lower', NL-1, NL-1, ZERO, ZERO, C(2,1), LDC ) - MNL = NL - ELSE - MNL = M - END IF -C -C 1.b): Transform C (or R) into bidiagonal form Q using Householder -C transformations. -C Workspace: need 2*min(M,N+L) + max(M,N+L), -C prefer 2*min(M,N+L) + (M+N+L)*NB. -C - ITAUP = 1 - ITAUQ = ITAUP + P - JWORK = ITAUQ + P - CALL DGEBRD( MNL, NL, C, LDC, Q, Q(P+1), DWORK(ITAUQ), - $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C If the matrix is lower bidiagonal, rotate to be upper bidiagonal -C by applying Givens rotations on the left. -C - IF ( M.LT.NL ) THEN - IOFF = 0 -C - DO 60 I = 1, P - 1 - CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) - Q(I) = TEMP - Q(P+I) = SN*Q(I+1) - Q(I+1) = CS*Q(I+1) - 60 CONTINUE -C - ELSE - IOFF = 1 - END IF -C -C Store the Householder transformations performed onto the rows of C -C in the extra storage locations DWORK(IHOUSH). -C Workspace: need LDW = min(M,N+L) + (N+L)*(N+L-1)/2, if M >= N+L, -C LDW = min(M,N+L) + M*(N+L-(M-1)/2), if M < N+L; -C prefer LDW = min(M,N+L) + (N+L)**2, if M >= N+L, -C LDW = min(M,N+L) + M*(N+L), if M < N+L. -C - IHOUSH = ITAUQ - MC = NL - IOFF - KF = IHOUSH + P*NL - SUFWRK = LDWORK.GE.( KF + MAX( 6*(N+L)-5, - $ NL**2 + MAX( NL, 3*L ) - 1 ) ) - IF ( SUFWRK ) THEN -C -C Enough workspace for a fast algorithm. -C - CALL DLACPY( 'Upper', P, NL, C, LDC, DWORK(IHOUSH), P ) - KJ = KF - WRKOPT = MAX( WRKOPT, KF - 1 ) - ELSE -C -C Not enough workspace for a fast algorithm. -C - KJ = IHOUSH -C - DO 80 NJ = 1, MIN( P, MC ) - J = MC - NJ + 1 - CALL DCOPY( J, C(NJ,NJ+IOFF), LDC, DWORK(KJ), 1 ) - KJ = KJ + J - 80 CONTINUE -C - END IF -C -C 1.c): Initialize the right singular base matrix V with the -C identity matrix (V overwrites C). -C - CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) - JV = KJ - IWARM = 0 -C -C REPEAT -C -C Compute the Householder matrix Q and matrices F and Y such that -C F is nonsingular. -C -C Step 2: Partial diagonalization phase. -C ----------------------------- -C Diagonalize the bidiagonal Q partially until convergence to -C the desired right singular subspace. -C Workspace: LDW + 6*(N+L)-5. -C - 100 CONTINUE - JWORK = JV - CALL MB04YD( 'No U', 'Update V', P, NL, RANK, THETA, Q, Q(P+1), - $ DUMMY, 1, C, LDC, INUL, TOL, RELTOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARN, INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 6*NL - 6 ) -C - IWARN = MAX( IWARN, IWARM ) - IF ( INFO.GT.0 ) - $ RETURN -C -C Set pointers to the selected base vectors in the right singular -C matrix of C. -C - K = 0 -C - DO 120 I = 1, NL - IF ( INUL(I) ) THEN - K = K + 1 - IWORK(K) = I - END IF - 120 CONTINUE -C - IF ( K.LT.L ) THEN -C -C Rank of the TLS approximation is larger than min(M,N). -C - INFO = 2 - RETURN - END IF -C -C Step 3: Back transformation phase. -C ------------------------- -C Apply in backward order the Householder transformations (stored -C in DWORK(IHOUSH)) performed onto the rows of C during the -C bidiagonalization phase, to the selected base vectors (specified -C by INUL(I) = .TRUE.). Already transformed vectors are those for -C which BWORK(I) = .TRUE.. -C - KF = K - IF ( SUFWRK.AND.LFIRST ) THEN -C -C Enough workspace for a fast algorithm and first pass. -C - IJ = JV -C - DO 140 J = 1, K - CALL DCOPY (NL, C(1,IWORK(J)), 1, DWORK(IJ), 1 ) - IJ = IJ + NL - 140 CONTINUE -C -C Workspace: need LDW + (N+L)*K + K, -C prefer LDW + (N+L)*K + K*NB. -C - IJ = JV - JWORK = IJ + NL*K - CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, K, - $ MNL, DWORK(IHOUSH), P, DWORK(ITAUP), DWORK(IJ), - $ NL, DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - DO 160 I = 1, NL - IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) - $ BWORK(I) = .TRUE. - 160 CONTINUE -C - ELSE -C -C Not enough workspace for a fast algorithm or subsequent passes. -C - DO 180 I = 1, NL - IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) THEN - KJ = JV -C - DO 170 NJ = MIN( P, MC ), 1, -1 - J = MC - NJ + 1 - KJ = KJ - J - FIRST = DWORK(KJ) - DWORK(KJ) = ONE - CALL DLARF( 'Left', J, 1, DWORK(KJ), 1, - $ DWORK(ITAUP+NJ-1), C(NJ+IOFF,I), LDC, - $ DWORK(JWORK) ) - DWORK(KJ) = FIRST - 170 CONTINUE -C - BWORK(I) = .TRUE. - END IF - 180 CONTINUE - END IF -C - IF ( RANK.LE.0 ) - $ RANK = 0 - IF ( MIN( RANK, L ).EQ.0 ) THEN - IF ( SUFWRK.AND.LFIRST ) - $ CALL DLACPY( 'Full', NL, K, DWORK(JV), NL, C, LDC ) - DWORK(1) = WRKOPT - DWORK(2) = ONE - RETURN - END IF -C -C Step 4: Compute matrices F and Y -C ------------------------ -C using Householder transformation Q. -C -C Compute the orthogonal matrix Q (in factorized form) and the -C matrices F and Y using RQ factorization. It is assumed that, -C generically, the last L rows of V2 matrix have full rank. -C The code could not be the most efficient when RANK has been -C lowered, because the already created zero pattern of the last -C L rows of V2 matrix is not exploited. -C - IF ( SUFWRK.AND.LFIRST ) THEN -C -C Enough workspace for a fast algorithm and first pass. -C Workspace: need LDW1 + 2*L, -C prefer LDW1 + L + L*NB, where -C LDW1 = LDW + (N+L)*K; -C - ITAUQ = JWORK - JWORK = ITAUQ + L - CALL DGERQF( L, K, DWORK(JV+N), NL, DWORK(ITAUQ), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need LDW1 + N+L, -C prefer LDW1 + L + N*NB. -C - CALL DORMRQ( 'Right', 'Transpose', N, K, L, DWORK(JV+N), NL, - $ DWORK(ITAUQ), DWORK(JV), NL, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - JF = JV + NL*(K-L) + N - LDF = NL - JWORK = JF + LDF*L - N - CALL DLASET( 'Full', L, K-L, ZERO, ZERO, DWORK(JV+N), LDF ) - IF ( L.GT.1 ) - $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, DWORK(JF+1), - $ LDF ) - IJ = JV -C - DO 200 J = 1, K - CALL DCOPY( NL, DWORK(IJ), 1, C(1,IWORK(J)), 1 ) - IJ = IJ + NL - 200 CONTINUE -C - ELSE -C -C Not enough workspace for a fast algorithm or subsequent passes. -C Workspace: LDW2 + N+L, where LDW2 = LDW + L*L. -C - I = NL - JF = JV - LDF = L - JWORK = JF + LDF*L - WRKOPT = MAX( WRKOPT, JWORK+NL-1 ) -C -C WHILE ( ( K >= 1 ) .AND. ( I > N ) ) DO - 220 CONTINUE - IF ( ( K.GE.1 ) .AND. ( I.GT.N ) ) THEN -C - DO 240 J = 1, K - DWORK(JWORK+J-1) = C(I,IWORK(J)) - 240 CONTINUE -C -C Compute Householder transformation. -C - CALL DLARFG( K, DWORK(JWORK+K-1), DWORK(JWORK), 1, TEMP ) - C(I,IWORK(K)) = DWORK(JWORK+K-1) - IF ( TEMP.NE.ZERO ) THEN -C -C Apply Householder transformation onto the selected base -C vectors. -C - DO 300 I1 = 1, I - 1 - INPROD = C(I1,IWORK(K)) -C - DO 260 J = 1, K - 1 - INPROD = INPROD + DWORK(JWORK+J-1)*C(I1,IWORK(J)) - 260 CONTINUE -C - HH = INPROD*TEMP - C(I1,IWORK(K)) = C(I1,IWORK(K)) - HH -C - DO 280 J = 1, K - 1 - J1 = IWORK(J) - C(I1,J1) = C(I1,J1) - DWORK(JWORK+J-1)*HH - C(I,J1) = ZERO - 280 CONTINUE -C - 300 CONTINUE -C - END IF - CALL DCOPY( I-N, C(N1,IWORK(K)), 1, DWORK(JF+(I-N-1)*L), 1 ) - K = K - 1 - I = I - 1 - GO TO 220 - END IF -C END WHILE 220 - END IF -C -C Estimate the reciprocal condition number of the matrix F. -C If F singular, lower the rank of the TLS approximation. -C Workspace: LDW1 + 3*L or -C LDW2 + 3*L. -C - CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, DWORK(JF), LDF, - $ RCOND, DWORK(JWORK), IWORK(KF+1), INFO ) - WRKOPT = MAX( WRKOPT, JWORK + 3*L - 1 ) -C - DO 320 J = 1, L - CALL DCOPY( N, C(1,IWORK(KF-L+J)), 1, X(1,J), 1 ) - 320 CONTINUE -C - FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, DWORK(JF), - $ LDF, DWORK(JWORK) ) - IF ( RCOND.LE.EPS*FNORM ) THEN - RANK = RANK - 1 - GO TO 340 - END IF - IF ( FNORM.LE.EPS*DLANGE( '1-norm', N, L, X, LDX, - $ DWORK(JWORK) ) ) THEN - RANK = RANK - L - GO TO 340 - ELSE - GO TO 400 - END IF -C - 340 CONTINUE - IWARM = 2 - THETA = -ONE - IF ( SUFWRK.AND.LFIRST ) THEN -C -C Rearrange the stored Householder transformations for -C subsequent passes, taking care to avoid overwriting. -C - IF ( P.LT.NL ) THEN - KJ = IHOUSH + NL*(NL - 1) - MJ = IHOUSH + P*(NL - 1) -C - DO 360 NJ = 1, NL - DO 350 J = P - 1, 0, -1 - DWORK(KJ+J) = DWORK(MJ+J) - 350 CONTINUE - KJ = KJ - NL - MJ = MJ - P - 360 CONTINUE -C - END IF - KJ = IHOUSH - MJ = IHOUSH + NL*IOFF -C - DO 380 NJ = 1, MIN( P, MC ) - DO 370 J = 0, MC - NJ - DWORK(KJ) = DWORK(MJ+J*P) - KJ = KJ + 1 - 370 CONTINUE - MJ = MJ + NL + 1 - 380 CONTINUE -C - JV = KJ - LFIRST = .FALSE. - END IF - GO TO 100 -C UNTIL ( F nonsingular, i.e., RCOND.GT.EPS*FNORM or -C FNORM.GT.EPS*norm(Y) ) - 400 CONTINUE -C -C Step 5: Compute TLS solution. -C -------------------- -C Solve X F = -Y by forward elimination (F is upper triangular). -C - CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, - $ -ONE, DWORK(JF), LDF, X, LDX ) -C -C Set the optimal workspace and reciprocal condition number of F. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of MB02ND *** - END diff --git a/slycot/src/MB02NY.f b/slycot/src/MB02NY.f deleted file mode 100644 index acf0bce5..00000000 --- a/slycot/src/MB02NY.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V, - $ LDV, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate a zero singular value of a bidiagonal submatrix of -C order k, k <= p, of the bidiagonal matrix -C -C |Q(1) E(1) 0 ... 0 | -C | 0 Q(2) E(2) . | -C J = | . . | -C | . E(p-1)| -C | 0 ... ... ... Q(p) | -C -C with p = MIN(M,N), by annihilating one or two superdiagonal -C elements E(i-1) (if i > 1) and/or E(i) (if i < k). -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATU LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix U the left-hand Givens rotations S, as follows: -C = .FALSE.: Do not form U; -C = .TRUE. : The given matrix U is updated (postmultiplied) -C by the left-hand Givens rotations S. -C -C UPDATV LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix V the right-hand Givens rotations T, as follows: -C = .FALSE.: Do not form V; -C = .TRUE. : The given matrix V is updated (postmultiplied) -C by the right-hand Givens rotations T. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix U. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix V. N >= 0. -C -C I (input) INTEGER -C The index of the negligible diagonal entry Q(I) of the -C bidiagonal matrix J, I <= p. -C -C K (input) INTEGER -C The index of the last diagonal entry of the considered -C bidiagonal submatrix of J, i.e., E(K-1) is considered -C negligible, K <= p. -C -C Q (input/output) DOUBLE PRECISION array, dimension (p) -C where p = MIN(M,N). -C On entry, Q must contain the diagonal entries of the -C bidiagonal matrix J. -C On exit, Q contains the diagonal entries of the -C transformed bidiagonal matrix S' J T. -C -C E (input/output) DOUBLE PRECISION array, dimension (p-1) -C On entry, E must contain the superdiagonal entries of J. -C On exit, E contains the superdiagonal entries of the -C transformed bidiagonal matrix S' J T. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) -C On entry, if UPDATU = .TRUE., U must contain the M-by-p -C left transformation matrix. -C On exit, if UPDATU = .TRUE., the Givens rotations S on the -C left, annihilating E(i) if i < k, have been postmultiplied -C into U. -C U is not referenced if UPDATU = .FALSE.. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= max(1,M) if UPDATU = .TRUE.; -C LDU >= 1 if UPDATU = .FALSE.. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) -C On entry, if UPDATV = .TRUE., V must contain the N-by-p -C right transformation matrix. -C On exit, if UPDATV = .TRUE., the Givens rotations T on the -C right, annihilating E(i-1) if i > 1, have been -C postmultiplied into V. -C V is not referenced if UPDATV = .FALSE.. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= max(1,N) if UPDATV = .TRUE.; -C LDV >= 1 if UPDATV = .FALSE.. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) -C LDWORK >= 2*MAX(K-I,I-1), if UPDATV = UPDATU = .TRUE.; -C LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.; -C LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.; -C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. -C -C METHOD -C -C Let the considered bidiagonal submatrix be -C -C |Q(1) E(1) 0 ... 0 | -C | 0 Q(2) E(2) . | -C | . . | -C | . Q(i-1) E(i-1) . | -C Jk = | . Q(i) E(i) . |. -C | . Q(i+1) . . | -C | . .. . | -C | . E(k-1)| -C | 0 ... ... Q(k) | -C -C A zero singular value of Jk manifests itself by a zero diagonal -C entry Q(i) or in practice, a negligible value of Q(i). -C When a negligible diagonal element Q(i) in Jk is present, the -C bidiagonal submatrix Jk is split by the routine into 2 or 3 -C unreduced bidiagonal submatrices by annihilating E(i) (if i < k) -C using Givens rotations S on the left and by annihilating E(i-1) -C (if i > 1) using Givens rotations T on the right until Jk is -C reduced to the form: -C -C |Q(1) E(1) 0 ... 0 | -C | 0 . ... . | -C | . ... . | -C | . Q(i-1) 0 . | -C S' Jk T = | . 0 0 . |. -C | . Q(i+1) . . | -C | . .. . | -C | . E(k-1)| -C | 0 ... ... Q(k) | -C -C For more details, see [1, pp.11.12-11.14]. -C -C REFERENCES -C -C [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W. -C LINPACK User's Guide. -C SIAM, Philadelphia, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bidiagonal matrix, orthogonal transformation, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATU, UPDATV - INTEGER I, K, LDU, LDV, M, N -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - INTEGER I1, IROT, L, L1, NROT - DOUBLE PRECISION C, F, G, R, S -C .. External Subroutines .. - EXTERNAL DLARTG, DLASR -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C For speed, no tests of the input scalar arguments are done. -C -C Quick return if possible. -C - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C - IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO -C -C Annihilate E(I) (if I < K). -C - IF ( I.LT.K ) THEN - C = ZERO - S = ONE - IROT = 0 - NROT = K - I -C - DO 20 L = I, K-1 - G = E(L) - E(L) = C*G - CALL DLARTG( Q(L+1), S*G, C, S, R ) - Q(L+1) = R - IF ( UPDATU ) THEN - IROT = IROT + 1 - DWORK(IROT) = C - DWORK(IROT+NROT) = S - END IF - 20 CONTINUE -C - IF ( UPDATU ) - $ CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1), - $ DWORK(NROT+1), U(1,I), LDU ) - END IF -C -C Annihilate E(I-1) (if I > 1). -C - IF ( I.GT.1 ) THEN - I1 = I - 1 - F = E(I1) - E(I1) = ZERO -C - DO 40 L1 = 1, I1 - 1 - L = I - L1 - CALL DLARTG( Q(L), F, C, S, R ) - Q(L) = R - IF ( UPDATV ) THEN - DWORK(L) = C - DWORK(L+I1) = S - END IF - G = E(L-1) - F = -S*G - E(L-1) = C*G - 40 CONTINUE -C - CALL DLARTG( Q(1), F, C, S, R ) - Q(1) = R - IF ( UPDATV ) THEN - DWORK(1) = C - DWORK(I) = S - CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1), - $ DWORK(I), V(1,1), LDV ) - END IF - END IF -C - RETURN -C *** Last line of MB02NY *** - END diff --git a/slycot/src/MB02OD.f b/slycot/src/MB02OD.f deleted file mode 100644 index 0a692995..00000000 --- a/slycot/src/MB02OD.f +++ /dev/null @@ -1,267 +0,0 @@ - SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A, - $ LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve (if well-conditioned) one of the matrix equations -C -C op( A )*X = alpha*B, or X*op( A ) = alpha*B, -C -C where alpha is a scalar, X and B are m-by-n matrices, A is a unit, -C or non-unit, upper or lower triangular matrix and op( A ) is one -C of -C -C op( A ) = A or op( A ) = A'. -C -C An estimate of the reciprocal of the condition number of the -C triangular matrix A, in either the 1-norm or the infinity-norm, is -C also computed as -C -C RCOND = 1 / ( norm(A) * norm(inv(A)) ). -C -C and the specified matrix equation is solved only if RCOND is -C larger than a given tolerance TOL. In that case, the matrix X is -C overwritten on B. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether op( A ) appears on the left or right -C of X as follows: -C = 'L': op( A )*X = alpha*B; -C = 'R': X*op( A ) = alpha*B. -C -C UPLO CHARACTER*1 -C Specifies whether the matrix A is an upper or lower -C triangular matrix as follows: -C = 'U': A is an upper triangular matrix; -C = 'L': A is a lower triangular matrix. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C DIAG CHARACTER*1 -C Specifies whether or not A is unit triangular as follows: -C = 'U': A is assumed to be unit triangular; -C = 'N': A is not assumed to be unit triangular. -C -C NORM CHARACTER*1 -C Specifies whether the 1-norm condition number or the -C infinity-norm condition number is required: -C = '1' or 'O': 1-norm; -C = 'I': Infinity-norm. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of B. M >= 0. -C -C N (input) INTEGER -C The number of columns of B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then A is not -C referenced and B need not be set before entry. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with UPLO = 'U', the leading k-by-k upper -C triangular part of this array must contain the upper -C triangular matrix and the strictly lower triangular part -C of A is not referenced. -C On entry with UPLO = 'L', the leading k-by-k lower -C triangular part of this array must contain the lower -C triangular matrix and the strictly upper triangular part -C of A is not referenced. -C Note that when DIAG = 'U', the diagonal elements of A are -C not referenced either, but are assumed to be unity. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= max(1,M) when SIDE = 'L'; -C LDA >= max(1,N) when SIDE = 'R'. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand side matrix B. -C On exit, if INFO = 0, the leading M-by-N part of this -C array contains the solution matrix X. -C Otherwise, this array is not modified by the routine. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal of the condition number of the matrix A, -C computed as RCOND = 1/(norm(A) * norm(inv(A))). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the matrix A. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the reciprocal -C condition number of that matrix; a matrix whose estimated -C condition number is less than 1/TOL is considered to be -C nonsingular. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by TOLDEF = k*k*EPS, -C is used instead, where EPS is the machine precision (see -C LAPACK Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (k) -C -C DWORK DOUBLE PRECISION array, dimension (3*k) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix A is numerically singular, i.e. the -C condition number estimate of A (in the specified -C norm) exceeds 1/TOL. -C -C METHOD -C -C An estimate of the reciprocal of the condition number of the -C triangular matrix A (in the specified norm) is computed, and if -C this estimate is larger then the given (or default) tolerance, -C the specified matrix equation is solved using Level 3 BLAS -C routine DTRSM. -C -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires k N/2 operations. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C February 20, 1998. -C -C KEYWORDS -C -C Condition number, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DIAG, NORM, SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDB, M, N - DOUBLE PRECISION ALPHA, RCOND, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LSIDE, ONENRM - INTEGER NROWA - DOUBLE PRECISION TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DTRCON, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C - LSIDE = LSAME( SIDE, 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) -C -C Test the input scalar arguments. -C - INFO = 0 - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LSAME( UPLO, 'U' ) ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = -3 - ELSE IF( ( .NOT.LSAME( DIAG, 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG, 'N' ) ) )THEN - INFO = -4 - ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -5 - ELSE IF( M.LT.0 )THEN - INFO = -6 - ELSE IF( N.LT.0 )THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = -12 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( NROWA.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' ) -C - CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK, - $ IWORK, INFO ) -C - IF ( RCOND.GT.TOLDEF ) THEN - CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B, - $ LDB ) - ELSE - INFO = 1 - END IF -C *** Last line of MB02OD *** - END diff --git a/slycot/src/MB02PD.f b/slycot/src/MB02PD.f deleted file mode 100644 index e8fb4a9a..00000000 --- a/slycot/src/MB02PD.f +++ /dev/null @@ -1,553 +0,0 @@ - SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, - $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, - $ IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve (if well-conditioned) the matrix equations -C -C op( A )*X = B, -C -C where X and B are N-by-NRHS matrices, A is an N-by-N matrix and -C op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C Error bounds on the solution and a condition estimate are also -C provided. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether or not the factored form of the matrix A -C is supplied on entry, and if not, whether the matrix A -C should be equilibrated before it is factored. -C = 'F': On entry, AF and IPIV contain the factored form -C of A. If EQUED is not 'N', the matrix A has been -C equilibrated with scaling factors given by R -C and C. A, AF, and IPIV are not modified. -C = 'N': The matrix A will be copied to AF and factored. -C = 'E': The matrix A will be equilibrated if necessary, -C then copied to AF and factored. -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations as follows: -C = 'N': A * X = B (No transpose); -C = 'T': A**T * X = B (Transpose); -C = 'C': A**H * X = B (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of linear equations, i.e., the order of the -C matrix A. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrices B and X. NRHS >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F' and EQUED is not 'N', -C then A must have been equilibrated by the scaling factors -C in R and/or C. A is not modified if FACT = 'F' or 'N', -C or if FACT = 'E' and EQUED = 'N' on exit. -C On exit, if EQUED .NE. 'N', the leading N-by-N part of -C this array contains the matrix A scaled as follows: -C EQUED = 'R': A := diag(R) * A; -C EQUED = 'C': A := A * diag(C); -C EQUED = 'B': A := diag(R) * A * diag(C). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C AF (input or output) DOUBLE PRECISION array, dimension -C (LDAF,N) -C If FACT = 'F', then AF is an input argument and on entry -C the leading N-by-N part of this array must contain the -C factors L and U from the factorization A = P*L*U as -C computed by DGETRF. If EQUED .NE. 'N', then AF is the -C factored form of the equilibrated matrix A. -C If FACT = 'N', then AF is an output argument and on exit -C the leading N-by-N part of this array contains the factors -C L and U from the factorization A = P*L*U of the original -C matrix A. -C If FACT = 'E', then AF is an output argument and on exit -C the leading N-by-N part of this array contains the factors -C L and U from the factorization A = P*L*U of the -C equilibrated matrix A (see the description of A for the -C form of the equilibrated matrix). -C -C LDAF (input) INTEGER -C The leading dimension of the array AF. LDAF >= max(1,N). -C -C IPIV (input or output) INTEGER array, dimension (N) -C If FACT = 'F', then IPIV is an input argument and on entry -C it must contain the pivot indices from the factorization -C A = P*L*U as computed by DGETRF; row i of the matrix was -C interchanged with row IPIV(i). -C If FACT = 'N', then IPIV is an output argument and on exit -C it contains the pivot indices from the factorization -C A = P*L*U of the original matrix A. -C If FACT = 'E', then IPIV is an output argument and on exit -C it contains the pivot indices from the factorization -C A = P*L*U of the equilibrated matrix A. -C -C EQUED (input or output) CHARACTER*1 -C Specifies the form of equilibration that was done as -C follows: -C = 'N': No equilibration (always true if FACT = 'N'); -C = 'R': Row equilibration, i.e., A has been premultiplied -C by diag(R); -C = 'C': Column equilibration, i.e., A has been -C postmultiplied by diag(C); -C = 'B': Both row and column equilibration, i.e., A has -C been replaced by diag(R) * A * diag(C). -C EQUED is an input argument if FACT = 'F'; otherwise, it is -C an output argument. -C -C R (input or output) DOUBLE PRECISION array, dimension (N) -C The row scale factors for A. If EQUED = 'R' or 'B', A is -C multiplied on the left by diag(R); if EQUED = 'N' or 'C', -C R is not accessed. R is an input argument if FACT = 'F'; -C otherwise, R is an output argument. If FACT = 'F' and -C EQUED = 'R' or 'B', each element of R must be positive. -C -C C (input or output) DOUBLE PRECISION array, dimension (N) -C The column scale factors for A. If EQUED = 'C' or 'B', -C A is multiplied on the right by diag(C); if EQUED = 'N' -C or 'R', C is not accessed. C is an input argument if -C FACT = 'F'; otherwise, C is an output argument. If -C FACT = 'F' and EQUED = 'C' or 'B', each element of C must -C be positive. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,NRHS) -C On entry, the leading N-by-NRHS part of this array must -C contain the right-hand side matrix B. -C On exit, -C if EQUED = 'N', B is not modified; -C if TRANS = 'N' and EQUED = 'R' or 'B', the leading -C N-by-NRHS part of this array contains diag(R)*B; -C if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading -C N-by-NRHS part of this array contains diag(C)*B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) -C If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of -C this array contains the solution matrix X to the original -C system of equations. Note that A and B are modified on -C exit if EQUED .NE. 'N', and the solution to the -C equilibrated system is inv(diag(C))*X if TRANS = 'N' and -C EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or -C 'C' and EQUED = 'R' or 'B'. -C -C LDX (input) INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION -C The estimate of the reciprocal condition number of the -C matrix A after equilibration (if done). If RCOND is less -C than the machine precision (in particular, if RCOND = 0), -C the matrix is singular to working precision. This -C condition is indicated by a return code of INFO > 0. -C For efficiency reasons, RCOND is computed only when the -C matrix A is factored, i.e., for FACT = 'N' or 'E'. For -C FACT = 'F', RCOND is not used, but it is assumed that it -C has been computed and checked before the routine call. -C -C FERR (output) DOUBLE PRECISION array, dimension (NRHS) -C The estimated forward error bound for each solution vector -C X(j) (the j-th column of the solution matrix X). -C If XTRUE is the true solution corresponding to X(j), -C FERR(j) is an estimated upper bound for the magnitude of -C the largest element in (X(j) - XTRUE) divided by the -C magnitude of the largest element in X(j). The estimate -C is as reliable as the estimate for RCOND, and is almost -C always a slight overestimate of the true error. -C -C BERR (output) DOUBLE PRECISION array, dimension (NRHS) -C The componentwise relative backward error of each solution -C vector X(j) (i.e., the smallest relative change in -C any element of A or B that makes X(j) an exact solution). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (4*N) -C On exit, DWORK(1) contains the reciprocal pivot growth -C factor norm(A)/norm(U). The "max absolute element" norm is -C used. If DWORK(1) is much less than 1, then the stability -C of the LU factorization of the (equilibrated) matrix A -C could be poor. This also means that the solution X, -C condition estimator RCOND, and forward error bound FERR -C could be unreliable. If factorization fails with -C 0 < INFO <= N, then DWORK(1) contains the reciprocal pivot -C growth factor for the leading INFO columns of A. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, and i is -C <= N: U(i,i) is exactly zero. The factorization -C has been completed, but the factor U is -C exactly singular, so the solution and error -C bounds could not be computed. RCOND = 0 is -C returned. -C = N+1: U is nonsingular, but RCOND is less than -C machine precision, meaning that the matrix is -C singular to working precision. Nevertheless, -C the solution and error bounds are computed -C because there are a number of situations -C where the computed solution can be more -C accurate than the value of RCOND would -C suggest. -C The positive values for INFO are set only when the -C matrix A is factored, i.e., for FACT = 'N' or 'E'. -C -C METHOD -C -C The following steps are performed: -C -C 1. If FACT = 'E', real scaling factors are computed to equilibrate -C the system: -C -C TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B -C TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B -C TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B -C -C Whether or not the system will be equilibrated depends on the -C scaling of the matrix A, but if equilibration is used, A is -C overwritten by diag(R)*A*diag(C) and B by diag(R)*B -C (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C'). -C -C 2. If FACT = 'N' or 'E', the LU decomposition is used to factor -C the matrix A (after equilibration if FACT = 'E') as -C A = P * L * U, -C where P is a permutation matrix, L is a unit lower triangular -C matrix, and U is upper triangular. -C -C 3. If some U(i,i)=0, so that U is exactly singular, then the -C routine returns with INFO = i. Otherwise, the factored form -C of A is used to estimate the condition number of the matrix A. -C If the reciprocal of the condition number is less than machine -C precision, INFO = N+1 is returned as a warning, but the routine -C still goes on to solve for X and compute error bounds as -C described below. -C -C 4. The system of equations is solved for X using the factored form -C of A. -C -C 5. Iterative refinement is applied to improve the computed -C solution matrix and calculate error bounds and backward error -C estimates for it. -C -C 6. If equilibration was used, the matrix X is premultiplied by -C diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so -C that it solves the original system before equilibration. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., Sorensen, D. -C LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995. -C -C FURTHER COMMENTS -C -C This is a simplified version of the LAPACK Library routine DGESVX, -C useful when several sets of matrix equations with the same -C coefficient matrix A and/or A' should be solved. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Condition number, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUED, FACT, TRANS - INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS - DOUBLE PRECISION RCOND -C .. -C .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), - $ BERR( * ), C( * ), DWORK( * ), FERR( * ), - $ R( * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU - CHARACTER NORM - INTEGER I, INFEQU, J - DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, - $ ROWCND, RPVGRW, SMLNUM -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, - $ DLAQGE, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Save Statement .. - SAVE RPVGRW -C .. -C .. Executable Statements .. -C - INFO = 0 - NOFACT = LSAME( FACT, 'N' ) - EQUIL = LSAME( FACT, 'E' ) - NOTRAN = LSAME( TRANS, 'N' ) - IF( NOFACT .OR. EQUIL ) THEN - EQUED = 'N' - ROWEQU = .FALSE. - COLEQU = .FALSE. - ELSE - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - SMLNUM = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - END IF -C -C Test the input parameters. -C - IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) - $ THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. - $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN - INFO = -10 - ELSE - IF( ROWEQU ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 10 J = 1, N - RCMIN = MIN( RCMIN, R( J ) ) - RCMAX = MAX( RCMAX, R( J ) ) - 10 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -11 - ELSE IF( N.GT.0 ) THEN - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - ROWCND = ONE - END IF - END IF - IF( COLEQU .AND. INFO.EQ.0 ) THEN - RCMIN = BIGNUM - RCMAX = ZERO - DO 20 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 20 CONTINUE - IF( RCMIN.LE.ZERO ) THEN - INFO = -12 - ELSE IF( N.GT.0 ) THEN - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - ELSE - COLCND = ONE - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -16 - END IF - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02PD', -INFO ) - RETURN - END IF -C - IF( EQUIL ) THEN -C -C Compute row and column scalings to equilibrate the matrix A. -C - CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) - IF( INFEQU.EQ.0 ) THEN -C -C Equilibrate the matrix. -C - CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, - $ EQUED ) - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) - END IF - END IF -C -C Scale the right hand side. -C - IF( NOTRAN ) THEN - IF( ROWEQU ) THEN - DO 40 J = 1, NRHS - DO 30 I = 1, N - B( I, J ) = R( I )*B( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE IF( COLEQU ) THEN - DO 60 J = 1, NRHS - DO 50 I = 1, N - B( I, J ) = C( I )*B( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -C - IF( NOFACT .OR. EQUIL ) THEN -C -C Compute the LU factorization of A. -C - CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) - CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) -C -C Return if INFO is non-zero. -C - IF( INFO.NE.0 ) THEN - IF( INFO.GT.0 ) THEN -C -C Compute the reciprocal pivot growth factor of the -C leading rank-deficient INFO columns of A. -C - RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, - $ DWORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGE( 'M', N, INFO, A, LDA, DWORK ) / - $ RPVGRW - END IF - DWORK( 1 ) = RPVGRW - RCOND = ZERO - END IF - RETURN - END IF -C -C Compute the norm of the matrix A and the -C reciprocal pivot growth factor RPVGRW. -C - IF( NOTRAN ) THEN - NORM = '1' - ELSE - NORM = 'I' - END IF - ANORM = DLANGE( NORM, N, N, A, LDA, DWORK ) - RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, DWORK ) - IF( RPVGRW.EQ.ZERO ) THEN - RPVGRW = ONE - ELSE - RPVGRW = DLANGE( 'M', N, N, A, LDA, DWORK ) / RPVGRW - END IF -C -C Compute the reciprocal of the condition number of A. -C - CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, DWORK, IWORK, - $ INFO ) -C -C Set INFO = N+1 if the matrix is singular to working precision. -C - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) - $ INFO = N + 1 - END IF -C -C Compute the solution matrix X. -C - CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) - CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) -C -C Use iterative refinement to improve the computed solution and -C compute error bounds and backward error estimates for it. -C - CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, - $ LDX, FERR, BERR, DWORK, IWORK, INFO ) -C -C Transform the solution matrix X to a solution of the original -C system. -C - IF( NOTRAN ) THEN - IF( COLEQU ) THEN - DO 80 J = 1, NRHS - DO 70 I = 1, N - X( I, J ) = C( I )*X( I, J ) - 70 CONTINUE - 80 CONTINUE - DO 90 J = 1, NRHS - FERR( J ) = FERR( J ) / COLCND - 90 CONTINUE - END IF - ELSE IF( ROWEQU ) THEN - DO 110 J = 1, NRHS - DO 100 I = 1, N - X( I, J ) = R( I )*X( I, J ) - 100 CONTINUE - 110 CONTINUE - DO 120 J = 1, NRHS - FERR( J ) = FERR( J ) / ROWCND - 120 CONTINUE - END IF -C - DWORK( 1 ) = RPVGRW - RETURN -C -C *** Last line of MB02PD *** - END diff --git a/slycot/src/MB02QD.f b/slycot/src/MB02QD.f deleted file mode 100644 index 610c2504..00000000 --- a/slycot/src/MB02QD.f +++ /dev/null @@ -1,502 +0,0 @@ - SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA, - $ B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a solution, optionally corresponding to specified free -C elements, to a real linear least squares problem: -C -C minimize || A * X - B || -C -C using a complete orthogonal factorization of the M-by-N matrix A, -C which may be rank-deficient. -C -C Several right hand side vectors b and solution vectors x can be -C handled in a single call; they are stored as the columns of the -C M-by-NRHS right hand side matrix B and the N-by-NRHS solution -C matrix X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies whether or not a standard least squares solution -C must be computed, as follows: -C = 'L': Compute a standard least squares solution (Y = 0); -C = 'F': Compute a solution with specified free elements -C (given in Y). -C -C INIPER CHARACTER*1 -C Specifies whether an initial column permutation, defined -C by JPVT, must be performed, as follows: -C = 'P': Perform an initial column permutation; -C = 'N': Do not perform an initial column permutation. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrices B and X. NRHS >= 0. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix C, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of C -C (for instance, the Frobenius norm of C). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the leading M-by-N part of this array contains -C details of its complete orthogonal factorization: -C the leading RANK-by-RANK upper triangular part contains -C the upper triangular factor T11 (see METHOD); -C the elements below the diagonal, with the entries 2 to -C min(M,N)+1 of the array DWORK, represent the orthogonal -C matrix Q as a product of min(M,N) elementary reflectors -C (see METHOD); -C the elements of the subarray A(1:RANK,RANK+1:N), with the -C next RANK entries of the array DWORK, represent the -C orthogonal matrix Z as a product of RANK elementary -C reflectors (see METHOD). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,NRHS) -C On entry, the leading M-by-NRHS part of this array must -C contain the right hand side matrix B. -C On exit, the leading N-by-NRHS part of this array contains -C the solution matrix X. -C If M >= N and RANK = N, the residual sum-of-squares for -C the solution in the i-th column is given by the sum of -C squares of elements N+1:M in that column. -C If NRHS = 0, this array is not referenced, and the routine -C returns the effective rank of A, and its QR factorization. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,M,N). -C -C Y (input) DOUBLE PRECISION array, dimension ( N*NRHS ) -C If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as -C free elements in computing the solution (see METHOD). -C The remaining elements are not referenced. -C If JOB = 'L', or NRHS = 0, this array is not referenced. -C -C JPVT (input/output) INTEGER array, dimension (N) -C On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th -C column of A is an initial column, otherwise it is a free -C column. Before the QR factorization of A, all initial -C columns are permuted to the leading positions; only the -C remaining free columns are moved as a result of column -C pivoting during the factorization. -C If INIPER = 'N', JPVT need not be set on entry. -C On exit, if JPVT(i) = k, then the i-th column of A*P -C was the k-th column of A. -C -C RANK (output) INTEGER -C The effective rank of A, i.e., the order of the submatrix -C R11. This is the same as the order of the submatrix T11 -C in the complete orthogonal factorization of A. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R11: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension LDWORK -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and the entries 2 to min(M,N) + RANK + 1 -C contain the scalar factors of the elementary reflectors -C used in the complete orthogonal factorization of A. -C Among the entries 2 to min(M,N) + 1, only the first RANK -C elements are useful, if INIPER = 'N'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS ) -C For optimum performance LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If INIPER = 'P', the routine first computes a QR factorization -C with column pivoting: -C A * P = Q * [ R11 R12 ] -C [ 0 R22 ] -C with R11 defined as the largest leading submatrix whose estimated -C condition number is less than 1/RCOND. The order of R11, RANK, -C is the effective rank of A. -C If INIPER = 'N', the effective rank is estimated during a -C truncated QR factorization (with column pivoting) process, and -C the submatrix R22 is not upper triangular, but full and of small -C norm. (See SLICOT Library routines MB03OD or MB03OY, respectively, -C for further details.) -C -C Then, R22 is considered to be negligible, and R12 is annihilated -C by orthogonal transformations from the right, arriving at the -C complete orthogonal factorization: -C A * P = Q * [ T11 0 ] * Z -C [ 0 0 ] -C The solution is then -C X = P * Z' [ inv(T11)*Q1'*B ] -C [ Y ] -C where Q1 consists of the first RANK columns of Q, and Y contains -C free elements (if JOB = 'F'), or is zero (if JOB = 'L'). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C FURTHER COMMENTS -C -C Significant gain in efficiency is possible for small-rank problems -C using truncated QR factorization (option INIPER = 'N'). -C -C CONTRIBUTORS -C -C P.Hr. Petkov, Technical University of Sofia, Oct. 1998, -C modification of the LAPACK routine DGELSX. -C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library -C version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Least squares problems, QR factorization. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE, DONE, NTDONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, - $ NTDONE = ONE ) -C .. -C .. Scalar Arguments .. - CHARACTER INIPER, JOB - INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), - $ SVAL( 3 ), Y ( * ) -C .. -C .. Local Scalars .. - LOGICAL LEASTS, PERMUT - INTEGER I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN - DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, T1, T2 -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ, - $ DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. -C .. Executable Statements .. -C - MN = MIN( M, N ) - LEASTS = LSAME( JOB, 'L' ) - PERMUT = LSAME( INIPER, 'P' ) -C -C Test the input scalar arguments. -C - INFO = 0 - MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS ) - IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -6 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -17 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MN.EQ.0 ) THEN - RANK = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'M', M, N, A, LDA, DWORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -C -C Matrix all zero. Return zero solution. -C - IF( NRHS.GT.0 ) - $ CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - RANK = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( NRHS.GT.0 ) THEN - BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 2 - END IF - END IF -C -C Compute a rank-revealing QR factorization of A and estimate its -C effective rank using incremental condition estimation: -C A * P = Q * R. -C Workspace need min(M,N)+3*N+1; -C prefer min(M,N)+2*N+N*NB. -C Details of Householder transformations stored in DWORK(1:MN). -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MAXWRK = MINWRK - IF( PERMUT ) THEN - CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX, - $ DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN, - $ INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN ) - ELSE - CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ DWORK( 1 ), DWORK( MN+1 ), INFO ) - END IF -C -C Logically partition R = [ R11 R12 ] -C [ 0 R22 ], -C where R11 = R(1:RANK,1:RANK). -C -C [R11,R12] = [ T11, 0 ] * Z. -C -C Details of Householder transformations stored in DWORK(MN+1:2*MN). -C Workspace need 3*min(M,N); -C prefer 2*min(M,N)+min(M,N)*NB. -C - IF( RANK.LT.N ) THEN - CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ), - $ LDWORK-2*MN, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) - END IF -C - IF( NRHS.GT.0 ) THEN -C -C B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS). -C -C Workspace: need 2*min(M,N)+NRHS; -C prefer min(M,N)+NRHS*NB. -C - CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, - $ DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN, - $ INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) -C -C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, - $ NRHS, ONE, A, LDA, B, LDB ) -C - IF( RANK.LT.N ) THEN -C -C Set B(RANK+1:N,1:NRHS). -C - IF( LEASTS ) THEN - CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, - $ B(RANK+1,1), LDB ) - ELSE - CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK, - $ B(RANK+1,1), LDB ) - END IF -C -C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). -C -C Workspace need 2*min(M,N)+NRHS; -C prefer 2*min(M,N)+NRHS*NB. -C - CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, - $ LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ), - $ LDWORK-2*MN, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) - END IF -C -C Additional workspace: NRHS. -C -C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). -C - DO 50 J = 1, NRHS - DO 20 I = 1, N - DWORK( 2*MN+I ) = NTDONE - 20 CONTINUE - DO 40 I = 1, N - IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN - IF( JPVT( I ).NE.I ) THEN - K = I - T1 = B( K, J ) - T2 = B( JPVT( K ), J ) - 30 CONTINUE - B( JPVT( K ), J ) = T1 - DWORK( 2*MN+K ) = DONE - T1 = T2 - K = JPVT( K ) - T2 = B( JPVT( K ), J ) - IF( JPVT( K ).NE.I ) - $ GO TO 30 - B( I, J ) = T1 - DWORK( 2*MN+K ) = DONE - END IF - END IF - 40 CONTINUE - 50 CONTINUE -C -C Undo scaling for B. -C - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - END IF - END IF -C -C Undo scaling for A. -C - IF( IASCL.EQ.1 ) THEN - IF( NRHS.GT.0 ) - $ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - IF( NRHS.GT.0 ) - $ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, - $ INFO ) - END IF -C - DO 60 I = MN + RANK, 1, -1 - DWORK( I+1 ) = DWORK( I ) - 60 CONTINUE -C - DWORK( 1 ) = MAXWRK - RETURN -C *** Last line of MB02QD *** - END diff --git a/slycot/src/MB02QY.f b/slycot/src/MB02QY.f deleted file mode 100644 index 329f54d4..00000000 --- a/slycot/src/MB02QY.f +++ /dev/null @@ -1,339 +0,0 @@ - SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine the minimum-norm solution to a real linear least -C squares problem: -C -C minimize || A * X - B ||, -C -C using the rank-revealing QR factorization of a real general -C M-by-N matrix A, computed by SLICOT Library routine MB03OD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C NRHS (input) INTEGER -C The number of columns of the matrix B. NRHS >= 0. -C -C RANK (input) INTEGER -C The effective rank of A, as returned by SLICOT Library -C routine MB03OD. min(M,N) >= RANK >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry, the leading min(M,N)-by-N upper trapezoidal -C part of this array contains the triangular factor R, as -C returned by SLICOT Library routine MB03OD. The strict -C lower trapezoidal part of A is not referenced. -C On exit, if RANK < N, the leading RANK-by-RANK upper -C triangular part of this array contains the upper -C triangular matrix R of the complete orthogonal -C factorization of A, and the submatrix (1:RANK,RANK+1:N) -C of this array, with the array TAU, represent the -C orthogonal matrix Z (of the complete orthogonal -C factorization of A), as a product of RANK elementary -C reflectors. -C On exit, if RANK = N, this array is unchanged. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input) INTEGER array, dimension ( N ) -C The recorded permutations performed by SLICOT Library -C routine MB03OD; if JPVT(i) = k, then the i-th column -C of A*P was the k-th column of the original matrix A. -C -C B (input/output) DOUBLE PRECISION array, dimension -C ( LDB, NRHS ) -C On entry, if NRHS > 0, the leading M-by-NRHS part of -C this array must contain the matrix B (corresponding to -C the transformed matrix A, returned by SLICOT Library -C routine MB03OD). -C On exit, if NRHS > 0, the leading N-by-NRHS part of this -C array contains the solution matrix X. -C If M >= N and RANK = N, the residual sum-of-squares -C for the solution in the i-th column is given by the sum -C of squares of elements N+1:M in that column. -C If NRHS = 0, the array B is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= max(1,M,N), if NRHS > 0. -C LDB >= 1, if NRHS = 0. -C -C TAU (output) DOUBLE PRECISION array, dimension ( min(M,N) ) -C The scalar factors of the elementary reflectors. -C If RANK = N, the array TAU is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 1, N, NRHS ). -C For good performance, LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses a QR factorization with column pivoting: -C -C A * P = Q * R = Q * [ R11 R12 ], -C [ 0 R22 ] -C -C where R11 is an upper triangular submatrix of estimated rank -C RANK, the effective rank of A. The submatrix R22 can be -C considered as negligible. -C -C If RANK < N, then R12 is annihilated by orthogonal -C transformations from the right, arriving at the complete -C orthogonal factorization: -C -C A * P = Q * [ T11 0 ] * Z. -C [ 0 0 ] -C -C The minimum-norm solution is then -C -C X = P * Z' [ inv(T11)*Q1'*B ], -C [ 0 ] -C -C where Q1 consists of the first RANK columns of Q. -C -C The input data for MB02QY are the transformed matrices Q' * A -C (returned by SLICOT Library routine MB03OD) and Q' * B. -C Matrix Q is not needed. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Least squares solutions; QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * ) -C .. Local Scalars .. - INTEGER I, IASCL, IBSCL, J, MN - DOUBLE PRECISION ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLANTR - EXTERNAL DLAMCH, DLANGE, DLANTR -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM, - $ DTZRZF, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C - MN = MIN( M, N ) -C -C Test the input scalar arguments. -C - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) ) - $ THEN - INFO = -9 - ELSE IF( LDWORK.LT.MAX( 1, N, NRHS ) ) THEN - INFO = -12 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02QY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( MN, NRHS ).EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Logically partition R = [ R11 R12 ], -C [ 0 R22 ] -C -C where R11 = R(1:RANK,1:RANK). If RANK = N, let T11 = R11. -C - MAXWRK = DBLE( N ) - IF( RANK.LT.N ) THEN -C -C Get machine parameters. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA, - $ DWORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA, - $ INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA, - $ INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -C -C Matrix all zero. Return zero solution. -C - CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB ) - DWORK( 1 ) = ONE - RETURN - END IF -C - BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -C -C Scale matrix norm up to SMLNUM. -C - CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -C -C Scale matrix norm down to BIGNUM. -C - CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, - $ INFO ) - IBSCL = 2 - END IF -C -C [R11,R12] = [ T11, 0 ] * Z. -C Details of Householder rotations are stored in TAU. -C Workspace need RANK, prefer RANK*NB. -C - CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO ) - MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) - END IF -C -C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, - $ NRHS, ONE, A, LDA, B, LDB ) -C - IF( RANK.LT.N ) THEN -C - CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ), - $ LDB ) -C -C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). -C Workspace need NRHS, prefer NRHS*NB. -C - CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, - $ LDA, TAU, B, LDB, DWORK, LDWORK, INFO ) - MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) -C -C Undo scaling. -C - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A, - $ LDA, INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, - $ INFO ) - CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A, - $ LDA, INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, - $ INFO ) - END IF - END IF -C -C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). -C Workspace N. -C - DO 20 J = 1, NRHS -C - DO 10 I = 1, N - DWORK( JPVT( I ) ) = B( I, J ) - 10 CONTINUE -C - CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 ) - 20 CONTINUE -C - DWORK( 1 ) = MAXWRK - RETURN -C -C *** Last line of MB02QY *** - END diff --git a/slycot/src/MB02RD.f b/slycot/src/MB02RD.f deleted file mode 100644 index d524e7f9..00000000 --- a/slycot/src/MB02RD.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of linear equations -C H * X = B or H' * X = B -C with an upper Hessenberg N-by-N matrix H using the LU -C factorization computed by MB02SD. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations: -C = 'N': H * X = B (No transpose) -C = 'T': H'* X = B (Transpose) -C = 'C': H'* X = B (Conjugate transpose = Transpose) -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrix B. NRHS >= 0. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SD. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices from MB02SD; for 1<=i<=N, row i of the -C matrix was interchanged with row IPIV(i). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,NRHS) -C On entry, the right hand side matrix B. -C On exit, the solution matrix X. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses the factorization -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N x NRHS ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, LDH, N, NRHS -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION B( LDB, * ), H( LDH, * ) -C .. Local Scalars .. - LOGICAL NOTRAN - INTEGER J, JP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DSWAP, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -C - IF( NOTRAN ) THEN -C -C Solve H * X = B. -C -C Solve L * X = B, overwriting B with X. -C -C L is represented as a product of permutations and unit lower -C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -C where each transformation L(i) is a rank-one modification of -C the identity matrix. -C - DO 10 J = 1, N - 1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - CALL DAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), - $ LDB ) - 10 CONTINUE -C -C Solve U * X = B, overwriting B with X. -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, H, LDH, B, LDB ) -C - ELSE -C -C Solve H' * X = B. -C -C Solve U' * X = B, overwriting B with X. -C - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, H, LDH, B, LDB ) -C -C Solve L' * X = B, overwriting B with X. -C - DO 20 J = N - 1, 1, -1 - CALL DAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), - $ LDB ) - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - 20 CONTINUE - END IF -C - RETURN -C *** Last line of MB02RD *** - END diff --git a/slycot/src/MB02RZ.f b/slycot/src/MB02RZ.f deleted file mode 100644 index a82be52b..00000000 --- a/slycot/src/MB02RZ.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of linear equations -C H * X = B, H' * X = B or H**H * X = B -C with a complex upper Hessenberg N-by-N matrix H using the LU -C factorization computed by MB02SZ. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations: -C = 'N': H * X = B (No transpose) -C = 'T': H'* X = B (Transpose) -C = 'C': H**H * X = B (Conjugate transpose) -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C NRHS (input) INTEGER -C The number of right hand sides, i.e., the number of -C columns of the matrix B. NRHS >= 0. -C -C H (input) COMPLEX*16 array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SZ. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices from MB02SZ; for 1<=i<=N, row i of the -C matrix was interchanged with row IPIV(i). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -C On entry, the right hand side matrix B. -C On exit, the solution matrix X. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses the factorization -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N x NRHS ) complex operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FW by A.J. Laub, University of -C Southern California, United States of America, May 1980. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDB, LDH, N, NRHS -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 B( LDB, * ), H( LDH, * ) -C .. Local Scalars .. - LOGICAL NOTRAN - INTEGER J, JP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZSWAP, ZTRSM -C .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02RZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -C - IF( NOTRAN ) THEN -C -C Solve H * X = B. -C -C Solve L * X = B, overwriting B with X. -C -C L is represented as a product of permutations and unit lower -C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -C where each transformation L(i) is a rank-one modification of -C the identity matrix. -C - DO 10 J = 1, N - 1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - CALL ZAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), - $ LDB ) - 10 CONTINUE -C -C Solve U * X = B, overwriting B with X. -C - CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, H, LDH, B, LDB ) -C - ELSE IF( LSAME( TRANS, 'T' ) ) THEN -C -C Solve H' * X = B. -C -C Solve U' * X = B, overwriting B with X. -C - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ H, LDH, B, LDB ) -C -C Solve L' * X = B, overwriting B with X. -C - DO 20 J = N - 1, 1, -1 - CALL ZAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), - $ LDB ) - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - 20 CONTINUE -C - ELSE -C -C Solve H**H * X = B. -C -C Solve U**H * X = B, overwriting B with X. -C - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ H, LDH, B, LDB ) -C -C Solve L**H * X = B, overwriting B with X. -C - DO 30 J = N - 1, 1, -1 - CALL ZAXPY( NRHS, -DCONJG( H( J+1, J ) ), B( J+1, 1 ), LDB, - $ B( J, 1 ), LDB ) - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB02RZ *** - END diff --git a/slycot/src/MB02SD.f b/slycot/src/MB02SD.f deleted file mode 100644 index 2c72554e..00000000 --- a/slycot/src/MB02SD.f +++ /dev/null @@ -1,164 +0,0 @@ - SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LU factorization of an n-by-n upper Hessenberg -C matrix H using partial pivoting with row interchanges. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) -C On entry, the n-by-n upper Hessenberg matrix to be -C factored. -C On exit, the factors L and U from the factorization -C H = P*L*U; the unit diagonal elements of L are not stored, -C and L is lower bidiagonal. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero. The -C factorization has been completed, but the factor U -C is exactly singular, and division by zero will occur -C if it is used to solve a system of equations. -C -C METHOD -C -C The factorization has the form -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C This is the right-looking Level 1 BLAS version of the algorithm -C (adapted after DGETF2). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Jan. 2005. -C -C KEYWORDS -C -C Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDH, N -C .. Array Arguments .. - INTEGER IPIV(*) - DOUBLE PRECISION H(LDH,*) -C .. Local Scalars .. - INTEGER J, JP -C .. External Subroutines .. - EXTERNAL DAXPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - DO 10 J = 1, N -C -C Find pivot and test for singularity. -C - JP = J - IF ( J.LT.N ) THEN - IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) ) - $ JP = J + 1 - END IF - IPIV( J ) = JP - IF( H( JP, J ).NE.ZERO ) THEN -C -C Apply the interchange to columns J:N. -C - IF( JP.NE.J ) - $ CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) -C -C Compute element J+1 of J-th column. -C - IF( J.LT.N ) - $ H( J+1, J ) = H( J+1, J )/H( J, J ) -C - ELSE IF( INFO.EQ.0 ) THEN -C - INFO = J - END IF -C - IF( J.LT.N ) THEN -C -C Update trailing submatrix. -C - CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, - $ H( J+1, J+1 ), LDH ) - END IF - 10 CONTINUE - RETURN -C *** Last line of MB02SD *** - END diff --git a/slycot/src/MB02SZ.f b/slycot/src/MB02SZ.f deleted file mode 100644 index 4643a918..00000000 --- a/slycot/src/MB02SZ.f +++ /dev/null @@ -1,169 +0,0 @@ - SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LU factorization of a complex n-by-n upper -C Hessenberg matrix H using partial pivoting with row interchanges. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C H (input/output) COMPLEX*16 array, dimension (LDH,N) -C On entry, the n-by-n upper Hessenberg matrix to be -C factored. -C On exit, the factors L and U from the factorization -C H = P*L*U; the unit diagonal elements of L are not stored, -C and L is lower bidiagonal. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero. The -C factorization has been completed, but the factor U -C is exactly singular, and division by zero will occur -C if it is used to solve a system of equations. -C -C METHOD -C -C The factorization has the form -C H = P * L * U -C where P is a permutation matrix, L is lower triangular with unit -C diagonal elements (and one nonzero subdiagonal), and U is upper -C triangular. -C -C This is the right-looking Level 2 BLAS version of the algorithm -C (adapted after ZGETF2). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) complex operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FX by A.J. Laub, University of -C Southern California, United States of America, May 1980. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Jan. 2005. -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LDH, N -C .. Array Arguments .. - INTEGER IPIV(*) - COMPLEX*16 H(LDH,*) -C .. Local Scalars .. - INTEGER J, JP -C .. External Functions .. - DOUBLE PRECISION DCABS1 - EXTERNAL DCABS1 -C .. External Subroutines .. - EXTERNAL XERBLA, ZAXPY, ZSWAP -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -3 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02SZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - DO 10 J = 1, N -C -C Find pivot and test for singularity. -C - JP = J - IF ( J.LT.N ) THEN - IF ( DCABS1( H( J+1, J ) ).GT.DCABS1( H( J, J ) ) ) - $ JP = J + 1 - END IF - IPIV( J ) = JP - IF( H( JP, J ).NE.ZERO ) THEN -C -C Apply the interchange to columns J:N. -C - IF( JP.NE.J ) - $ CALL ZSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) -C -C Compute element J+1 of J-th column. -C - IF( J.LT.N ) - $ H( J+1, J ) = H( J+1, J )/H( J, J ) -C - ELSE IF( INFO.EQ.0 ) THEN -C - INFO = J - END IF -C - IF( J.LT.N ) THEN -C -C Update trailing submatrix. -C - CALL ZAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, - $ H( J+1, J+1 ), LDH ) - END IF - 10 CONTINUE - RETURN -C *** Last line of MB02SZ *** - END diff --git a/slycot/src/MB02TD.f b/slycot/src/MB02TD.f deleted file mode 100644 index 865ffbf3..00000000 --- a/slycot/src/MB02TD.f +++ /dev/null @@ -1,236 +0,0 @@ - SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the reciprocal of the condition number of an upper -C Hessenberg matrix H, in either the 1-norm or the infinity-norm, -C using the LU factorization computed by MB02SD. -C -C ARGUMENTS -C -C Mode Parameters -C -C NORM CHARACTER*1 -C Specifies whether the 1-norm condition number or the -C infinity-norm condition number is required: -C = '1' or 'O': 1-norm; -C = 'I': Infinity-norm. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C HNORM (input) DOUBLE PRECISION -C If NORM = '1' or 'O', the 1-norm of the original matrix H. -C If NORM = 'I', the infinity-norm of the original matrix H. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SD. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal of the condition number of the matrix H, -C computed as RCOND = 1/(norm(H) * norm(inv(H))). -C -C Workspace -C -C IWORK DOUBLE PRECISION array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (3*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C An estimate is obtained for norm(inv(H)), and the reciprocal of -C the condition number is computed as -C RCOND = 1 / ( norm(H) * norm(inv(H)) ). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDH, N - DOUBLE PRECISION HNORM, RCOND -C .. -C .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION DWORK( * ), H( LDH, * ) -C .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, J, JP, KASE, KASE1 -C - DOUBLE PRECISION HINVNM, SCALE, SMLNUM, T -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Test the input parameters. -C - 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( HNORM.LT.ZERO ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( HNORM.EQ.ZERO ) THEN - RETURN - END IF -C - SMLNUM = DLAMCH( 'Safe minimum' ) -C -C Estimate the norm of inv(H). -C - HINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL DLACON( N, DWORK( N+1 ), DWORK, IWORK, HINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -C -C Multiply by inv(L). -C - DO 20 J = 1, N - 1 - JP = IPIV( J ) - T = DWORK( JP ) - IF( JP.NE.J ) THEN - DWORK( JP ) = DWORK( J ) - DWORK( J ) = T - END IF - DWORK( J+1 ) = DWORK( J+1 ) - T * H( J+1, J ) - 20 CONTINUE -C -C Multiply by inv(U). -C - CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ H, LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) - ELSE -C -C Multiply by inv(U'). -C - CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, H, - $ LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) -C -C Multiply by inv(L'). -C - DO 30 J = N - 1, 1, -1 - DWORK( J ) = DWORK( J ) - H( J+1, J ) * DWORK( J+1 ) - JP = IPIV( J ) - IF( JP.NE.J ) THEN - T = DWORK( JP ) - DWORK( JP ) = DWORK( J ) - DWORK( J ) = T - END IF - 30 CONTINUE - END IF -C -C Divide X by 1/SCALE if doing so will not cause overflow. -C - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, DWORK, 1 ) - IF( SCALE.LT.ABS( DWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO - $ ) GO TO 40 - CALL DRSCL( N, SCALE, DWORK, 1 ) - END IF - GO TO 10 - END IF -C -C Compute the estimate of the reciprocal condition number. -C - IF( HINVNM.NE.ZERO ) - $ RCOND = ( ONE / HINVNM ) / HNORM -C - 40 CONTINUE - RETURN -C *** Last line of MB02TD *** - END diff --git a/slycot/src/MB02TZ.f b/slycot/src/MB02TZ.f deleted file mode 100644 index 8cc434d7..00000000 --- a/slycot/src/MB02TZ.f +++ /dev/null @@ -1,247 +0,0 @@ - SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK, - $ ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the reciprocal of the condition number of a complex -C upper Hessenberg matrix H, in either the 1-norm or the -C infinity-norm, using the LU factorization computed by MB02SZ. -C -C ARGUMENTS -C -C Mode Parameters -C -C NORM CHARACTER*1 -C Specifies whether the 1-norm condition number or the -C infinity-norm condition number is required: -C = '1' or 'O': 1-norm; -C = 'I': Infinity-norm. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C HNORM (input) DOUBLE PRECISION -C If NORM = '1' or 'O', the 1-norm of the original matrix H. -C If NORM = 'I', the infinity-norm of the original matrix H. -C -C H (input) COMPLEX*16 array, dimension (LDH,N) -C The factors L and U from the factorization H = P*L*U -C as computed by MB02SZ. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the matrix -C was interchanged with row IPIV(i). -C -C RCOND (output) DOUBLE PRECISION -C The reciprocal of the condition number of the matrix H, -C computed as RCOND = 1/(norm(H) * norm(inv(H))). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C ZWORK COMPLEX*16 array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C An estimate is obtained for norm(inv(H)), and the reciprocal of -C the condition number is computed as -C RCOND = 1 / ( norm(H) * norm(inv(H)) ). -C -C REFERENCES -C -C - -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0( N ) complex operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FY by A.J. Laub, University of -C Southern California, United States of America, May 1980. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2005. -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDH, N - DOUBLE PRECISION HNORM, RCOND -C .. -C .. Array Arguments .. - INTEGER IPIV(*) - DOUBLE PRECISION DWORK( * ) - COMPLEX*16 H( LDH, * ), ZWORK( * ) -C .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, J, JP, KASE, KASE1 -C - DOUBLE PRECISION HINVNM, SCALE, SMLNUM - COMPLEX*16 T, ZDUM -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IZAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX -C .. -C .. Statement Functions .. - DOUBLE PRECISION CABS1 -C .. -C .. Statement Function definitions .. - CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) -C .. -C .. Executable Statements .. -C -C Test the input parameters. -C - 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( HNORM.LT.ZERO ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02TZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( HNORM.EQ.ZERO ) THEN - RETURN - END IF -C - SMLNUM = DLAMCH( 'Safe minimum' ) -C -C Estimate the norm of inv(H). -C - HINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL ZLACON( N, ZWORK( N+1 ), ZWORK, HINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -C -C Multiply by inv(L). -C - DO 20 J = 1, N - 1 - JP = IPIV( J ) - T = ZWORK( JP ) - IF( JP.NE.J ) THEN - ZWORK( JP ) = ZWORK( J ) - ZWORK( J ) = T - END IF - ZWORK( J+1 ) = ZWORK( J+1 ) - T * H( J+1, J ) - 20 CONTINUE -C -C Multiply by inv(U). -C - CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ H, LDH, ZWORK, SCALE, DWORK, INFO ) - ELSE -C -C Multiply by inv(U'). -C - CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', - $ NORMIN, N, H, LDH, ZWORK, SCALE, DWORK, INFO ) -C -C Multiply by inv(L'). -C - DO 30 J = N - 1, 1, -1 - ZWORK( J ) = ZWORK( J ) - - $ DCONJG( H( J+1, J ) ) * ZWORK( J+1 ) - JP = IPIV( J ) - IF( JP.NE.J ) THEN - T = ZWORK( JP ) - ZWORK( JP ) = ZWORK( J ) - ZWORK( J ) = T - END IF - 30 CONTINUE - END IF -C -C Divide X by 1/SCALE if doing so will not cause overflow. -C - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IZAMAX( N, ZWORK, 1 ) - IF( SCALE.LT.CABS1( ZWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO - $ ) GO TO 40 - CALL ZDRSCL( N, SCALE, ZWORK, 1 ) - END IF - GO TO 10 - END IF -C -C Compute the estimate of the reciprocal condition number. -C - IF( HINVNM.NE.ZERO ) - $ RCOND = ( ONE / HINVNM ) / HNORM -C - 40 CONTINUE - RETURN -C *** Last line of MB02TZ *** - END diff --git a/slycot/src/MB02UD.f b/slycot/src/MB02UD.f deleted file mode 100644 index 101c7426..00000000 --- a/slycot/src/MB02UD.f +++ /dev/null @@ -1,624 +0,0 @@ - SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND, - $ RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the minimum norm least squares solution of one of the -C following linear systems -C -C op(R)*X = alpha*B, (1) -C X*op(R) = alpha*B, (2) -C -C where alpha is a real scalar, op(R) is either R or its transpose, -C R', R is an L-by-L real upper triangular matrix, B is an M-by-N -C real matrix, and L = M for (1), or L = N for (2). Singular value -C decomposition, R = Q*S*P', is used, assuming that R is rank -C deficient. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether R has been previously factored or not, -C as follows: -C = 'F': R has been factored and its rank and singular -C value decomposition, R = Q*S*P', are available; -C = 'N': R has not been factored and its singular value -C decomposition, R = Q*S*P', should be computed. -C -C SIDE CHARACTER*1 -C Specifies whether op(R) appears on the left or right -C of X as follows: -C = 'L': Solve op(R)*X = alpha*B (op(R) is on the left); -C = 'R': Solve X*op(R) = alpha*B (op(R) is on the right). -C -C TRANS CHARACTER*1 -C Specifies the form of op(R) to be used as follows: -C = 'N': op(R) = R; -C = 'T': op(R) = R'; -C = 'C': op(R) = R'. -C -C JOBP CHARACTER*1 -C Specifies whether or not the pseudoinverse of R is to be -C computed or it is available as follows: -C = 'P': Compute pinv(R), if FACT = 'N', or -C use pinv(R), if FACT = 'F'; -C = 'N': Do not compute or use pinv(R). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then B need not be -C set before entry. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of R. -C Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are -C treated as zero. If RCOND <= 0, then EPS is used instead, -C where EPS is the relative machine precision (see LAPACK -C Library routine DLAMCH). RCOND <= 1. -C RCOND is not used if FACT = 'F'. -C -C RANK (input or output) INTEGER -C The rank of matrix R. -C RANK is an input parameter when FACT = 'F', and an output -C parameter when FACT = 'N'. L >= RANK >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) -C On entry, if FACT = 'F', the leading L-by-L part of this -C array must contain the L-by-L orthogonal matrix P' from -C singular value decomposition, R = Q*S*P', of the matrix R; -C if JOBP = 'P', the first RANK rows of P' are assumed to be -C scaled by inv(S(1:RANK,1:RANK)). -C On entry, if FACT = 'N', the leading L-by-L upper -C triangular part of this array must contain the upper -C triangular matrix R. -C On exit, if INFO = 0, the leading L-by-L part of this -C array contains the L-by-L orthogonal matrix P', with its -C first RANK rows scaled by inv(S(1:RANK,1:RANK)), when -C JOBP = 'P'. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,L). -C -C Q (input or output) DOUBLE PRECISION array, dimension -C (LDQ,L) -C On entry, if FACT = 'F', the leading L-by-L part of this -C array must contain the L-by-L orthogonal matrix Q from -C singular value decomposition, R = Q*S*P', of the matrix R. -C If FACT = 'N', this array need not be set on entry, and -C on exit, if INFO = 0, the leading L-by-L part of this -C array contains the orthogonal matrix Q. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,L). -C -C SV (input or output) DOUBLE PRECISION array, dimension (L) -C On entry, if FACT = 'F', the first RANK entries of this -C array must contain the reciprocal of the largest RANK -C singular values of the matrix R, and the last L-RANK -C entries of this array must contain the remaining singular -C values of R sorted in descending order. -C If FACT = 'N', this array need not be set on input, and -C on exit, if INFO = 0, the first RANK entries of this array -C contain the reciprocal of the largest RANK singular values -C of the matrix R, and the last L-RANK entries of this array -C contain the remaining singular values of R sorted in -C descending order. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, if ALPHA <> 0, the leading M-by-N part of this -C array must contain the matrix B. -C On exit, if INFO = 0 and RANK > 0, the leading M-by-N part -C of this array contains the M-by-N solution matrix X. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C RP (input or output) DOUBLE PRECISION array, dimension -C (LDRP,L) -C On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the -C leading L-by-L part of this array must contain the L-by-L -C matrix pinv(R), the Moore-Penrose pseudoinverse of R. -C On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the -C leading L-by-L part of this array contains the L-by-L -C matrix pinv(R), the Moore-Penrose pseudoinverse of R. -C If JOBP = 'N', this array is not referenced. -C -C LDRP INTEGER -C The leading dimension of array RP. -C LDRP >= MAX(1,L), if JOBP = 'P'. -C LDRP >= 1, if JOBP = 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; -C if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the -C unconverged superdiagonal elements of an upper bidiagonal -C matrix D whose diagonal is in SV (not necessarily sorted). -C D satisfies R = Q*D*P', so it has the same singular -C values as R, and singular vectors related by Q and P'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,L), if FACT = 'F'; -C LDWORK >= MAX(1,5*L), if FACT = 'N'. -C For optimum performance LDWORK should be larger than -C MAX(1,L,M*N), if FACT = 'F'; -C MAX(1,5*L,M*N), if FACT = 'N'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i = 1:L, the SVD algorithm has failed -C to converge. In this case INFO specifies how many -C superdiagonals did not converge (see the description -C of DWORK); this failure is not likely to occur. -C -C METHOD -C -C The L-by-L upper triangular matrix R is factored as R = Q*S*P', -C if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P -C are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix -C with non-negative diagonal elements, SV(1), SV(2), ..., SV(L), -C ordered decreasingly. Then, the effective rank of R is estimated, -C and matrix (or matrix-vector) products and scalings are used to -C compute X. If FACT = 'F', only matrix (or matrix-vector) products -C and scalings are performed. -C -C FURTHER COMMENTS -C -C Option JOBP = 'P' should be used only if the pseudoinverse is -C really needed. Usually, it is possible to avoid the use of -C pseudoinverse, by computing least squares solutions. -C The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2 -C calculations, otherwise. No advantage of any additional workspace -C larger than L is taken for matrix products, but the routine can -C be called repeatedly for chunks of columns of B, if LDWORK < M*N. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999. -C -C REVISIONS -C -C V. Sima, Feb. 2000. -C -C KEYWORDS -C -C Bidiagonalization, orthogonal transformation, singular value -C decomposition, singular values, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER FACT, JOBP, SIDE, TRANS - INTEGER INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK - DOUBLE PRECISION ALPHA, RCOND -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*), - $ RP(LDRP,*), SV(*) -C .. Local Scalars .. - LOGICAL LEFT, NFCT, PINV, TRAN - CHARACTER*1 NTRAN - INTEGER I, L, MAXWRK, MINWRK, MN - DOUBLE PRECISION TOLL -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD, - $ MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - INFO = 0 - NFCT = LSAME( FACT, 'N' ) - LEFT = LSAME( SIDE, 'L' ) - PINV = LSAME( JOBP, 'P' ) - TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - IF( LEFT ) THEN - L = M - ELSE - L = N - END IF - MN = M*N - IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -3 - ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN - INFO = -8 - ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN - INFO = -9 - ELSE IF( LDR.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN - INFO = -13 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN - INFO = -18 - END IF -C -C Compute workspace -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately following -C subroutine, as returned by ILAENV.) -C - MINWRK = 1 - IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. L.GT.0 ) THEN - MINWRK = MAX( 1, L ) - MAXWRK = MAX( MINWRK, MN ) - IF( NFCT ) THEN - MAXWRK = MAX( MAXWRK, 3*L+2*L* - $ ILAENV( 1, 'DGEBRD', ' ', L, L, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*L+L* - $ ILAENV( 1, 'DORGBR', 'Q', L, L, L, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*L+L* - $ ILAENV( 1, 'DORGBR', 'P', L, L, L, -1 ) ) - MINWRK = MAX( 1, 5*L ) - MAXWRK = MAX( MAXWRK, MINWRK ) - END IF - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -20 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 ) THEN - IF( NFCT ) - $ RANK = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( NFCT ) THEN -C -C Compute the SVD of R, R = Q*S*P'. -C Matrix Q is computed in the array Q, and P' overwrites R. -C Workspace: need 5*L; -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, - $ DWORK, LDWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN -C -C Use the default tolerance, if required. -C - TOLL = RCOND - IF( TOLL.LE.ZERO ) - $ TOLL = DLAMCH( 'Precision' ) - TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) ) -C -C Estimate the rank of R. -C - DO 10 I = 1, L - IF ( TOLL.GT.SV(I) ) - $ GO TO 20 - 10 CONTINUE -C - I = L + 1 - 20 CONTINUE - RANK = I - 1 -C - DO 30 I = 1, RANK - SV(I) = ONE / SV(I) - 30 CONTINUE -C - IF( PINV .AND. RANK.GT.0 ) THEN -C -C Compute pinv(S)'*P' in R. -C - CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV ) -C -C Compute pinv(R) = P*pinv(S)*Q' in RP. -C - CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R, - $ LDR, Q, LDQ, ZERO, RP, LDRP ) - END IF - END IF -C -C Return if min(M,N) = 0 or RANK = 0. -C - IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN - DWORK(1) = MAXWRK - RETURN - END IF -C -C Set X = 0 if alpha = 0. -C - IF( ALPHA.EQ.ZERO ) THEN - CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) - DWORK(1) = MAXWRK - RETURN - END IF -C - IF( PINV ) THEN -C - IF( LEFT ) THEN -C -C Compute alpha*op(pinv(R))*B in workspace and save it in B. -C Workspace: need M (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA, - $ RP, LDRP, B, LDB, ZERO, DWORK, M ) - CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) - ELSE -C - DO 40 I = 1, N - CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1, - $ ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 40 CONTINUE -C - END IF - ELSE -C -C Compute alpha*B*op(pinv(R)) in workspace and save it in B. -C Workspace: need N (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB, - $ RP, LDRP, ZERO, DWORK, M ) - CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) - ELSE -C - IF( TRAN ) THEN - NTRAN = 'N' - ELSE - NTRAN = 'T' - END IF -C - DO 50 I = 1, M - CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB, - $ ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 50 CONTINUE -C - END IF - END IF -C - ELSE -C - IF( LEFT ) THEN -C -C Compute alpha*P*pinv(S)*Q'*B or alpha*Q*pinv(S)'*P'*B. -C Workspace: need M (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - IF( TRAN ) THEN -C -C Compute alpha*P'*B in workspace. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, - $ ALPHA, R, LDR, B, LDB, ZERO, DWORK, M ) -C -C Compute alpha*pinv(S)'*P'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, - $ SV ) -C -C Compute alpha*Q*pinv(S)'*P'*B. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, - $ ONE, Q, LDQ, DWORK, M, ZERO, B, LDB ) - ELSE -C -C Compute alpha*Q'*B in workspace. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, - $ ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M ) -C -C Compute alpha*pinv(S)*Q'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, - $ SV ) -C -C Compute alpha*P*pinv(S)*Q'*B. -C - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK, - $ ONE, R, LDR, DWORK, M, ZERO, B, LDB ) - END IF - ELSE - IF( TRAN ) THEN -C -C Compute alpha*P'*B in B using workspace. -C - DO 60 I = 1, N - CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 60 CONTINUE -C -C Compute alpha*pinv(S)'*P'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) -C -C Compute alpha*Q*pinv(S)'*P'*B in B using workspace. -C - DO 70 I = 1, N - CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 70 CONTINUE - ELSE -C -C Compute alpha*Q'*B in B using workspace. -C - DO 80 I = 1, N - CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 80 CONTINUE -C -C Compute alpha*pinv(S)*Q'*B. -C - CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) -C -C Compute alpha*P*pinv(S)*Q'*B in B using workspace. -C - DO 90 I = 1, N - CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR, - $ B(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) - 90 CONTINUE - END IF - END IF - ELSE -C -C Compute alpha*B*P*pinv(S)*Q' or alpha*B*Q*pinv(S)'*P'. -C Workspace: need N (BLAS 2); -C prefer M*N (BLAS 3). -C - IF( LDWORK.GE.MN ) THEN - IF( TRAN ) THEN -C -C Compute alpha*B*Q in workspace. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, - $ ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M ) -C -C Compute alpha*B*Q*pinv(S)'. -C - CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, - $ SV ) -C -C Compute alpha*B*Q*pinv(S)'*P' in B. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, - $ ONE, DWORK, M, R, LDR, ZERO, B, LDB ) - ELSE -C -C Compute alpha*B*P in workspace. -C - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, - $ ALPHA, B, LDB, R, LDR, ZERO, DWORK, M ) -C -C Compute alpha*B*P*pinv(S). -C - CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, - $ SV ) -C -C Compute alpha*B*P*pinv(S)*Q' in B. -C - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK, - $ ONE, DWORK, M, Q, LDQ, ZERO, B, LDB ) - END IF - ELSE - IF( TRAN ) THEN -C -C Compute alpha*B*Q in B using workspace. -C - DO 100 I = 1, M - CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 100 CONTINUE -C -C Compute alpha*B*Q*pinv(S)'. -C - CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, - $ SV ) -C -C Compute alpha*B*Q*pinv(S)'*P' in B using workspace. -C - DO 110 I = 1, M - CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 110 CONTINUE -C - ELSE -C -C Compute alpha*B*P in B using workspace. -C - DO 120 I = 1, M - CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 120 CONTINUE -C -C Compute alpha*B*P*pinv(S). -C - CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, - $ SV ) -C -C Compute alpha*B*P*pinv(S)*Q' in B using workspace. -C - DO 130 I = 1, M - CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ, - $ B(I,1), LDB, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) - 130 CONTINUE - END IF - END IF - END IF - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK(1) = MAXWRK -C - RETURN -C *** Last line of MB02UD *** - END diff --git a/slycot/src/MB02UU.f b/slycot/src/MB02UU.f deleted file mode 100644 index 649cc513..00000000 --- a/slycot/src/MB02UU.f +++ /dev/null @@ -1,162 +0,0 @@ - SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for x in A * x = scale * RHS, using the LU factorization -C of the N-by-N matrix A computed by SLICOT Library routine MB02UV. -C The factorization has the form A = P * L * U * Q, where P and Q -C are permutation matrices, L is unit lower triangular and U is -C upper triangular. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. -C -C A (input) DOUBLE PRECISION array, dimension (LDA, N) -C The leading N-by-N part of this array must contain -C the LU part of the factorization of the matrix A computed -C by SLICOT Library routine MB02UV: A = P * L * U * Q. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1, N). -C -C RHS (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the right hand side -C of the system. -C On exit, this array contains the solution of the system. -C -C IPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the -C matrix has been interchanged with row IPIV(i). -C -C JPIV (input) INTEGER array, dimension (N) -C The pivot indices; for 1 <= j <= N, column j of the -C matrix has been interchanged with column JPIV(j). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, chosen 0 < SCALE <= 1 to prevent -C overflow in the solution. -C -C FURTHER COMMENTS -C -C In the interest of speed, this routine does not check the input -C for errors. It should only be used if the order of the matrix A -C is very small. -C -C CONTRIBUTOR -C -C Bo Kagstrom and P. Poromaa, Univ. of Umea, Sweden, Nov. 1993. -C -C REVISIONS -C -C April 1998 (T. Penzl). -C Sep. 1998 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) -C .. Scalar Arguments .. - INTEGER LDA, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - INTEGER IPIV( * ), JPIV( * ) - DOUBLE PRECISION A( LDA, * ), RHS( * ) -C .. Local Scalars .. - INTEGER I, IP, J - DOUBLE PRECISION BIGNUM, EPS, FACTOR, SMLNUM, TEMP -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. External Subroutines .. - EXTERNAL DAXPY, DLABAD, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C -C Set constants to control owerflow. -C - EPS = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Apply permutations IPIV to RHS. -C - DO 20 I = 1, N - 1 - IP = IPIV(I) - IF ( IP.NE.I ) THEN - TEMP = RHS(I) - RHS(I) = RHS(IP) - RHS(IP) = TEMP - ENDIF - 20 CONTINUE -C -C Solve for L part. -C - DO 40 I = 1, N - 1 - CALL DAXPY( N-I, -RHS(I), A(I+1, I), 1, RHS(I+1), 1 ) - 40 CONTINUE -C -C Solve for U part. -C -C Check for scaling. -C - FACTOR = TWO * DBLE( N ) - I = 1 - 60 CONTINUE - IF ( ( FACTOR * SMLNUM ) * ABS( RHS(I) ) .LE. ABS( A(I, I) ) ) - $ THEN - I = I + 1 - IF ( I .LE. N ) GO TO 60 - SCALE = ONE - ELSE - SCALE = ( ONE / FACTOR ) / ABS( RHS( IDAMAX( N, RHS, 1 ) ) ) - CALL DSCAL( N, SCALE, RHS, 1 ) - END IF -C - DO 100 I = N, 1, -1 - TEMP = ONE / A(I, I) - RHS(I) = RHS(I) * TEMP - DO 80 J = I + 1, N - RHS(I) = RHS(I) - RHS(J) * ( A(I, J) * TEMP ) - 80 CONTINUE - 100 CONTINUE -C -C Apply permutations JPIV to the solution (RHS). -C - DO 120 I = N - 1, 1, -1 - IP = JPIV(I) - IF ( IP.NE.I ) THEN - TEMP = RHS(I) - RHS(I) = RHS(IP) - RHS(IP) = TEMP - ENDIF - 120 CONTINUE -C - RETURN -C *** Last line of MB02UU *** - END diff --git a/slycot/src/MB02UV.f b/slycot/src/MB02UV.f deleted file mode 100644 index 61e5bbc7..00000000 --- a/slycot/src/MB02UV.f +++ /dev/null @@ -1,195 +0,0 @@ - SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LU factorization, using complete pivoting, of the -C N-by-N matrix A. The factorization has the form A = P * L * U * Q, -C where P and Q are permutation matrices, L is lower triangular with -C unit diagonal elements and U is upper triangular. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A to be factored. -C On exit, the leading N-by-N part of this array contains -C the factors L and U from the factorization A = P*L*U*Q; -C the unit diagonal elements of L are not stored. If U(k, k) -C appears to be less than SMIN, U(k, k) is given the value -C of SMIN, giving a nonsingular perturbed system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1, N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= i <= N, row i of the -C matrix has been interchanged with row IPIV(i). -C -C JPIV (output) INTEGER array, dimension (N) -C The pivot indices; for 1 <= j <= N, column j of the -C matrix has been interchanged with column JPIV(j). -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C = k: U(k, k) is likely to produce owerflow if one tries -C to solve for x in Ax = b. So U is perturbed to get -C a nonsingular system. This is a warning. -C -C FURTHER COMMENTS -C -C In the interests of speed, this routine does not check the input -C for errors. It should only be used to factorize matrices A of -C very small order. -C -C CONTRIBUTOR -C -C Bo Kagstrom and Peter Poromaa, Univ. of Umea, Sweden, Nov. 1993. -C -C REVISIONS -C -C April 1998 (T. Penzl). -C Sep. 1998 (V. Sima). -C March 1999 (V. Sima). -C March 2004 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, N -C .. Array Arguments .. - INTEGER IPIV( * ), JPIV( * ) - DOUBLE PRECISION A( LDA, * ) -C .. Local Scalars .. - INTEGER I, IP, IPV, JP, JPV - DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL DGER, DLABAD, DSCAL, DSWAP -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. Executable Statements .. -C -C Set constants to control owerflow. - - INFO = 0 - EPS = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Find max element in matrix A. -C - IPV = 1 - JPV = 1 - XMAX = ZERO - DO 40 JP = 1, N - DO 20 IP = 1, N - IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN - XMAX = ABS( A(IP, JP) ) - IPV = IP - JPV = JP - ENDIF - 20 CONTINUE - 40 CONTINUE - SMIN = MAX( EPS * XMAX, SMLNUM ) -C -C Swap rows. -C - IF ( IPV .NE. 1 ) CALL DSWAP( N, A(IPV, 1), LDA, A(1, 1), LDA ) - IPIV(1) = IPV -C -C Swap columns. -C - IF ( JPV .NE. 1 ) CALL DSWAP( N, A(1, JPV), 1, A(1, 1), 1 ) - JPIV(1) = JPV -C -C Check for singularity. -C - IF ( ABS( A(1, 1) ) .LT. SMIN ) THEN - INFO = 1 - A(1, 1) = SMIN - ENDIF - IF ( N.GT.1 ) THEN - CALL DSCAL( N - 1, ONE / A(1, 1), A(2, 1), 1 ) - CALL DGER( N - 1, N - 1, -ONE, A(2, 1), 1, A(1, 2), LDA, - $ A(2, 2), LDA ) - ENDIF -C -C Factorize the rest of A with complete pivoting. -C Set pivots less than SMIN to SMIN. -C - DO 100 I = 2, N - 1 -C -C Find max element in remaining matrix. -C - IPV = I - JPV = I - XMAX = ZERO - DO 80 JP = I, N - DO 60 IP = I, N - IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN - XMAX = ABS( A(IP, JP) ) - IPV = IP - JPV = JP - ENDIF - 60 CONTINUE - 80 CONTINUE -C -C Swap rows. -C - IF ( IPV .NE. I ) CALL DSWAP( N, A(IPV, 1), LDA, A(I, 1), LDA ) - IPIV(I) = IPV -C -C Swap columns. -C - IF ( JPV .NE. I ) CALL DSWAP( N, A(1, JPV), 1, A(1, I), 1 ) - JPIV(I) = JPV -C -C Check for almost singularity. -C - IF ( ABS( A(I, I) ) .LT. SMIN ) THEN - INFO = I - A(I, I) = SMIN - ENDIF - CALL DSCAL( N - I, ONE / A(I, I), A(I + 1, I), 1 ) - CALL DGER( N - I, N - I, -ONE, A(I + 1, I), 1, A(I, I + 1), - $ LDA, A(I + 1, I + 1), LDA ) - 100 CONTINUE - IF ( ABS( A(N, N) ) .LT. SMIN ) THEN - INFO = N - A(N, N) = SMIN - ENDIF -C - RETURN -C *** Last line of MB02UV *** - END diff --git a/slycot/src/MB02VD.f b/slycot/src/MB02VD.f deleted file mode 100644 index 5896d234..00000000 --- a/slycot/src/MB02VD.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the solution to a real system of linear equations -C X * op(A) = B, -C where op(A) is either A or its transpose, A is an N-by-N matrix, -C and X and B are M-by-N matrices. -C The LU decomposition with partial pivoting and row interchanges, -C A = P * L * U, is used, where P is a permutation matrix, L is unit -C lower triangular, and U is upper triangular. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies the form of op(A) to be used as follows: -C = 'N': op(A) = A; -C = 'T': op(A) = A'; -C = 'C': op(A) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix B, and the order of -C the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A. -C On exit, the leading N-by-N part of this array contains -C the factors L and U from the factorization A = P*L*U; -C the unit diagonal elements of L are not stored. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C IPIV (output) INTEGER array, dimension (N) -C The pivot indices that define the permutation matrix P; -C row i of the matrix was interchanged with row IPIV(i). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix B. -C On exit, if INFO = 0, the leading M-by-N part of this -C array contains the solution matrix X. -C -C LDB (input) INTEGER -C The leading dimension of the array B. LDB >= max(1,M). -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, U(i,i) is exactly zero. The -C factorization has been completed, but the factor U -C is exactly singular, so the solution could not be -C computed. -C -C METHOD -C -C The LU decomposition with partial pivoting and row interchanges is -C used to factor A as -C A = P * L * U, -C where P is a permutation matrix, L is unit lower triangular, and -C U is upper triangular. The factored form of A is then used to -C solve the system of equations X * A = B or X * A' = B. -C -C FURTHER COMMENTS -C -C This routine enables to solve the system X * A = B or X * A' = B -C as easily and efficiently as possible; it is similar to the LAPACK -C Library routine DGESV, which solves A * X = B. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, linear algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, M, N -C .. -C .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -C .. -C .. Local Scalars .. - LOGICAL TRAN -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGETRF, DTRSM, MA02GD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Test the scalar input parameters. -C - INFO = 0 - TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -1 - ELSE IF( M.LT.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, M ) ) THEN - INFO = -8 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02VD', -INFO ) - RETURN - END IF -C -C Compute the LU factorization of A. -C - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) -C - IF( INFO.EQ.0 ) THEN - IF( TRAN ) THEN -C -C Compute X = B * A**(-T). -C - CALL MA02GD( M, B, LDB, 1, N, IPIV, 1 ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Unit', M, N, - $ ONE, A, LDA, B, LDB ) - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M, - $ N, ONE, A, LDA, B, LDB ) - ELSE -C -C Compute X = B * A**(-1). -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M, - $ N, ONE, A, LDA, B, LDB ) - CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', M, N, - $ ONE, A, LDA, B, LDB ) - CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) - END IF - END IF - RETURN -C -C *** Last line of MB02VD *** - END diff --git a/slycot/src/MB02WD.f b/slycot/src/MB02WD.f deleted file mode 100644 index 59816e03..00000000 --- a/slycot/src/MB02WD.f +++ /dev/null @@ -1,458 +0,0 @@ - SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX, - $ A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the system of linear equations Ax = b, with A symmetric, -C positive definite, or, in the implicit form, f(A, x) = b, where -C y = f(A, x) is a symmetric positive definite linear mapping -C from x to y, using the conjugate gradient (CG) algorithm without -C preconditioning. -C -C ARGUMENTS -C -C Mode Parameters -C -C FORM CHARACTER*1 -C Specifies the form of the system of equations, as -C follows: -C = 'U' : Ax = b, the upper triagular part of A is used; -C = 'L' : Ax = b, the lower triagular part of A is used; -C = 'F' : the implicit, function form, f(A, x) = b. -C -C Function Parameters -C -C F EXTERNAL -C If FORM = 'F', then F is a subroutine which calculates the -C value of f(A, x), for given A and x. -C If FORM <> 'F', then F is not called. -C -C F must have the following interface: -C -C SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X, -C $ INCX, DWORK, LDWORK, INFO ) -C -C where -C -C N (input) INTEGER -C The dimension of the vector x. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the matrix A. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the -C problem. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C A (input) DOUBLE PRECISION array, dimension -C (LDA, NC), where NC is the number of columns. -C The leading NR-by-NC part of this array must -C contain the (compressed) representation of the -C matrix A, where NR is the number of rows of A -C (function of IPAR entries). -C -C LDA (input) INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,NR). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value -C of the function f, y = f(A, x). -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX > 0. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine F. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine F). -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input scalar argument is erroneous, and to -C positive values for other possible errors in the -C subroutine F. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the vector x. N >= 0. -C If FORM = 'U' or FORM = 'L', N is also the number of rows -C and columns of the matrix A. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C If FORM = 'F', the integer parameters describing the -C structure of the matrix A. -C This parameter is ignored if FORM = 'U' or FORM = 'L'. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C If FORM = 'F', the real parameters needed for solving -C the problem. -C This parameter is ignored if FORM = 'U' or FORM = 'L'. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C ITMAX (input) INTEGER -C The maximal number of iterations to do. ITMAX >= 0. -C -C A (input) DOUBLE PRECISION array, -C dimension (LDA, NC), if FORM = 'F', -C dimension (LDA, N), otherwise. -C If FORM = 'F', the leading NR-by-NC part of this array -C must contain the (compressed) representation of the -C matrix A, where NR and NC are the number of rows and -C columns, respectively, of the matrix A. The array A is -C not referenced by this routine itself, except in the -C calls to the routine F. -C If FORM <> 'F', the leading N-by-N part of this array -C must contain the matrix A, assumed to be symmetric; -C only the triangular part specified by FORM is referenced. -C -C LDA (input) INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,NR), if FORM = 'F'; -C LDA >= MAX(1,N), if FORM = 'U' or FORM = 'L'. -C -C B (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB) -C The incremented vector b. -C -C INCB (input) INTEGER -C The increment for the elements of B. INCB > 0. -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain an initial -C approximation of the solution. If an approximation is not -C known, setting all elements of x to zero is recommended. -C On exit, this incremented array contains the computed -C solution x of the system of linear equations. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX > 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If TOL > 0, absolute tolerance for the iterative process. -C The algorithm will stop if || Ax - b ||_2 <= TOL. Since -C it is advisable to use a relative tolerance, say TOLER, -C TOL should be chosen as TOLER*|| b ||_2. -C If TOL <= 0, a default relative tolerance, -C TOLDEF = N*EPS*|| b ||_2, is used, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the number of -C iterations performed and DWORK(2) returns the remaining -C residual, || Ax - b ||_2. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(2,3*N + DWORK(F)), if FORM = 'F', -C where DWORK(F) is the workspace needed by F; -C LDWORK >= MAX(2,3*N), if FORM = 'U' or FORM = 'L'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the algorithm finished after ITMAX > 0 iterations, -C without achieving the desired precision TOL; -C = 2: ITMAX is zero; in this case, DWORK(2) is not set. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then F returned with INFO = i. -C -C METHOD -C -C The following CG iteration is used for solving Ax = b: -C -C Start: q(0) = r(0) = Ax - b -C -C < q(k), r(k) > -C ALPHA(k) = - ---------------- -C < q(k), Aq(k) > -C x(k+1) = x(k) - ALPHA(k) * q(k) -C r(k+1) = r(k) - ALPHA(k) * Aq(k) -C < r(k+1), r(k+1) > -C BETA(k) = -------------------- -C < r(k) , r(k) > -C q(k+1) = r(k+1) + BETA(k) * q(k) -C -C where <.,.> denotes the scalar product. -C -C REFERENCES -C -C [1] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, -C 1996. -C -C [2] Luenberger, G. -C Introduction to Linear and Nonlinear Programming. -C Addison-Wesley, Reading, MA, p.187, York, 1973. -C -C NUMERICAL ASPECTS -C -C Since the residuals are orthogonal in the scalar product -C = y'Ax, the algorithm is theoretically finite. But rounding -C errors cause a loss of orthogonality, so a finite termination -C cannot be guaranteed. However, one can prove [2] that -C -C || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) ) -C -C sqrt( kappa_2(A) ) - 1 -C <= 2 || x-x_0 ||_A * ------------------------ , -C sqrt( kappa_2(A) ) + 1 -C -C where kappa_2 is the condition number. -C -C The approximate number of floating point operations is -C (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F', -C k*(f + 7*N) + f, if FORM = 'F', -C where k is the number of CG iterations performed, and f is the -C number of floating point operations required by the subroutine F. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C March, 2002. -C -C KEYWORDS -C -C Conjugate gradients, convergence, linear system of equations, -C matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FORM - INTEGER INCB, INCX, INFO, ITMAX, IWARN, LDA, LDPAR, - $ LDWORK, LIPAR, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), DPAR(*), DWORK(*), X(*) - INTEGER IPAR(*) -C .. Local Scalars .. - DOUBLE PRECISION ALPHA, BETA, RES, RESOLD, TOLDEF - INTEGER AQ, DWLEFT, K, R - LOGICAL MAT -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, DSYMV, F, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MAT = LSAME( FORM, 'U' ) .OR. LSAME( FORM, 'L' ) -C -C Check the scalar input parameters. -C - IWARN = 0 - INFO = 0 - IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN - INFO = -1 - ELSEIF ( N.LT.0 ) THEN - INFO = -3 - ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN - INFO = -5 - ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN - INFO = -7 - ELSEIF ( ITMAX.LT.0 ) THEN - INFO = -8 - ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.N ) ) THEN - INFO = -10 - ELSEIF ( INCB.LE.0 ) THEN - INFO = -12 - ELSEIF ( INCX.LE.0 ) THEN - INFO = -14 - ELSEIF ( LDWORK.LT.MAX( 2, 3*N ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02WD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ZERO - DWORK(2) = ZERO - RETURN - ENDIF -C - IF ( ITMAX.EQ.0 ) THEN - DWORK(1) = ZERO - IWARN = 2 - RETURN - ENDIF -C -C Set default tolerance, if needed. -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )*DNRM2( N, B, INCB ) -C -C Initialize local variables. -C - K = 0 -C -C Vector q is stored in DWORK(1), A*q or f(A, q) in DWORK(AQ), -C and r in DWORK(R). The workspace for F starts in DWORK(DWLEFT). -C - AQ = N + 1 - R = N + AQ - DWLEFT = N + R -C -C Prepare the first iteration, initialize r and q. -C - IF ( MAT ) THEN - CALL DCOPY( N, B, INCB, DWORK(R), 1 ) - CALL DSYMV( FORM, N, ONE, A, LDA, X, INCX, -ONE, DWORK(R), 1 ) - ELSE - CALL DCOPY( N, X, INCX, DWORK(R), 1 ) - CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(R), 1, - $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - CALL DAXPY( N, -ONE, B, INCB, DWORK(R), 1 ) - ENDIF - CALL DCOPY( N, DWORK(R), 1, DWORK, 1 ) -C - RES = DNRM2( N, DWORK(R), 1 ) -C -C Do nothing if x is already the solution. -C - IF ( RES.LE.TOLDEF ) GOTO 20 -C -C Begin of the iteration loop. -C -C WHILE ( RES.GT.TOLDEF .AND. K.LE.ITMAX ) DO - 10 CONTINUE -C -C Calculate A*q or f(A, q). -C - IF ( MAT ) THEN - CALL DSYMV( FORM, N, ONE, A, LDA, DWORK, 1, ZERO, DWORK(AQ), - $ 1 ) - ELSE - CALL DCOPY( N, DWORK, 1, DWORK(AQ), 1 ) - CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(AQ), 1, - $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - ENDIF -C -C Calculate ALPHA(k). -C - ALPHA = DDOT( N, DWORK, 1, DWORK(R), 1 ) / - $ DDOT( N, DWORK, 1, DWORK(AQ), 1 ) -C -C x(k+1) = x(k) - ALPHA(k)*q(k). -C - CALL DAXPY( N, -ALPHA, DWORK, 1, X, INCX ) -C -C r(k+1) = r(k) - ALPHA(k)*(A*q(k)). -C - CALL DAXPY( N, -ALPHA, DWORK(AQ), 1, DWORK(R), 1 ) -C -C Save RES and calculate a new RES. -C - RESOLD = RES - RES = DNRM2( N, DWORK(R), 1 ) -C -C Exit if tolerance is reached. -C - IF ( RES.LE.TOLDEF ) GOTO 20 -C -C Calculate BETA(k). -C - BETA = ( RES/RESOLD )**2 -C -C q(k+1) = r(k+1) + BETA(k)*q(k). -C - CALL DSCAL( N, BETA, DWORK, 1 ) - CALL DAXPY( N, ONE, DWORK(R), 1, DWORK, 1 ) -C -C End of the iteration loop. -C - K = K + 1 - IF ( K.LT.ITMAX ) GOTO 10 -C END WHILE 10 -C -C Tolerance was not reached! -C - IWARN = 1 -C - 20 CONTINUE -C - DWORK(1) = K - DWORK(2) = RES -C -C *** Last line of MB02WD *** - END diff --git a/slycot/src/MB02XD.f b/slycot/src/MB02XD.f deleted file mode 100644 index 0575a907..00000000 --- a/slycot/src/MB02XD.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR, - $ DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a set of systems of linear equations, A'*A*X = B, or, -C in the implicit form, f(A)*X = B, with A'*A or f(A) positive -C definite, using symmetric Gaussian elimination. -C -C ARGUMENTS -C -C Mode Parameters -C -C FORM CHARACTER*1 -C Specifies the form in which the matrix A is provided, as -C follows: -C = 'S' : standard form, the matrix A is given; -C = 'F' : the implicit, function form f(A) is provided. -C If FORM = 'F', then the routine F is called to compute the -C matrix A'*A. -C -C STOR CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix A'*A, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix A'*A is stored, as -C follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C Function Parameters -C -C F EXTERNAL -C If FORM = 'F', then F is a subroutine which calculates the -C value of f(A) = A'*A, for given A. -C If FORM = 'S', then F is not called. -C -C F must have the following interface: -C -C SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, -C $ LDA, ATA, LDATA, DWORK, LDWORK, INFO ) -C -C where -C -C STOR (input) CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix A'*A, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO (input) CHARACTER*1 -C Specifies which part of the matrix A'*A is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C N (input) INTEGER -C The order of the matrix A'*A. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the matrix A. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the -C problem. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C A (input) DOUBLE PRECISION array, dimension -C (LDA, NC), where NC is the number of columns. -C The leading NR-by-NC part of this array must -C contain the (compressed) representation of the -C matrix A, where NR is the number of rows of A -C (function of IPAR entries). -C -C LDA (input) INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,NR). -C -C ATA (output) DOUBLE PRECISION array, -C dimension (LDATA,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 -C (if STOR = 'P') part of this array contains the -C upper or lower triangle of the matrix A'*A, -C depending on UPLO = 'U', or UPLO = 'L', -C respectively, stored either as a two-dimensional, -C or one-dimensional array, depending on STOR. -C -C LDATA (input) INTEGER -C The leading dimension of the array ATA. -C LDATA >= MAX(1,N), if STOR = 'F'. -C LDATA >= 1, if STOR = 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine F. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine F). -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input scalar argument is erroneous, and to -C positive values for other possible errors in the -C subroutine F. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The order of the matrix A'*A, the number of columns of the -C matrix A, and the number of rows of the matrix X. N >= 0. -C -C NRHS (input) INTEGER -C The number of columns of the matrices B and X. NRHS >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C If FORM = 'F', the integer parameters describing the -C structure of the matrix A. -C This parameter is ignored if FORM = 'S'. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C If FORM = 'F', the real parameters needed for solving -C the problem. -C This parameter is ignored if FORM = 'S'. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 0. -C -C A (input) DOUBLE PRECISION array, -C dimension (LDA, N), if FORM = 'S', -C dimension (LDA, NC), if FORM = 'F', where NC is -C the number of columns. -C If FORM = 'S', the leading M-by-N part of this array -C must contain the matrix A. -C If FORM = 'F', the leading NR-by-NC part of this array -C must contain an appropriate representation of matrix A, -C where NR is the number of rows. -C If FORM = 'F', this array is not referenced by this -C routine itself, except in the call to the routine F. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,M), if FORM = 'S'; -C LDA >= MAX(1,NR), if FORM = 'F'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB, NRHS) -C On entry, the leading N-by-NRHS part of this array must -C contain the right hand side matrix B. -C On exit, if INFO = 0 and M (or NR) is nonzero, the leading -C N-by-NRHS part of this array contains the solution X of -C the set of systems of linear equations A'*A*X = B or -C f(A)*X = B. If M (or NR) is zero, then B is unchanged. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C ATA (output) DOUBLE PRECISION array, -C dimension (LDATA,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if -C STOR = 'P') part of this array contains the upper or lower -C triangular Cholesky factor of the matrix A'*A, depending -C on UPLO = 'U', or UPLO = 'L', respectively, stored either -C as a two-dimensional, or one-dimensional array, depending -C on STOR. -C -C LDATA INTEGER -C The leading dimension of the array ATA. -C LDATA >= MAX(1,N), if STOR = 'F'. -C LDATA >= 1, if STOR = 'P'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then the (i,i) element of the -C triangular factor of the matrix A'*A is exactly -C zero (the matrix A'*A is exactly singular); -C if INFO = j > n, then F returned with INFO = j-n. -C -C METHOD -C -C The matrix A'*A is built either directly (if FORM = 'S'), or -C implicitly, by calling the routine F. Then, A'*A is Cholesky -C factored and its factor is used to solve the set of systems of -C linear equations, A'*A*X = B. -C -C REFERENCES -C -C [1] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, 1996. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J., -C Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., -C McKenney, A., Sorensen, D. -C LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999. -C -C NUMERICAL ASPECTS -C -C For speed, this routine does not check for near singularity of the -C matrix A'*A. If the matrix A is nearly rank deficient, then the -C computed X could be inaccurate. Estimates of the reciprocal -C condition numbers of the matrices A and A'*A can be obtained -C using LAPACK routines DGECON and DPOCON (DPPCON), respectively. -C -C The approximate number of floating point operations is -C (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S', -C f + N**3/6 + NRHS*N**2, if FORM = 'F', -C where M is the number of rows of A, and f is the number of -C floating point operations required by the subroutine F. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C V. Sima, Mar. 2002. -C -C KEYWORDS -C -C Linear system of equations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FORM, STOR, UPLO - INTEGER INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M, - $ N, NRHS -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*) - INTEGER IPAR(*) -C .. Local Scalars .. - INTEGER IERR, J, J1 - LOGICAL FULL, MAT, UPPER -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - MAT = LSAME( FORM, 'S' ) - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C -C Check the scalar input parameters. -C - INFO = 0 - IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -2 - ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -3 - ELSEIF ( M.LT.0 ) THEN - INFO = -5 - ELSEIF ( N.LT.0 ) THEN - INFO = -6 - ELSEIF ( NRHS.LT.0 ) THEN - INFO = -7 - ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN - INFO = -9 - ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN - INFO = -11 - ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN - INFO = -13 - ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02XD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) ) - $ RETURN -C -C Build a triangle of the matrix A'*A. -C - IF ( MAT ) THEN -C -C Matrix A is given in the usual form. -C - IF ( FULL ) THEN - CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO, - $ ATA, LDATA ) - ELSEIF ( UPPER ) THEN - J1 = 1 -C - DO 10 J = 1, N - CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1, - $ ZERO, ATA(J1), 1 ) - J1 = J1 + J - 10 CONTINUE -C - ELSE - J1 = 1 -C - DO 20 J = 1, N - CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA, - $ A(1,J), 1, ZERO, ATA(J1), 1 ) - J1 = J1 + N - J + 1 - 20 CONTINUE -C - ENDIF -C - ELSE -C -C Implicit form, A'*A = f(A). -C - CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA, - $ LDATA, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = N + IERR - RETURN - ENDIF -C - ENDIF -C -C Factor the matrix A'*A. -C - IF ( FULL ) THEN - CALL DPOTRF( UPLO, N, ATA, LDATA, IERR ) - ELSE - CALL DPPTRF( UPLO, N, ATA, IERR ) - ENDIF -C - IF ( IERR.NE.0 ) THEN - INFO = IERR - RETURN - ENDIF -C -C Solve the set of linear systems. -C - IF ( FULL ) THEN - CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR ) - ELSE - CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR ) - ENDIF -C -C *** Last line of MB02XD *** - END diff --git a/slycot/src/MB02YD.f b/slycot/src/MB02YD.f deleted file mode 100644 index 981af1f0..00000000 --- a/slycot/src/MB02YD.f +++ /dev/null @@ -1,371 +0,0 @@ - SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a vector x which solves the system of linear -C equations -C -C A*x = b , D*x = 0 , -C -C in the least squares sense, where A is an m-by-n matrix, -C D is an n-by-n diagonal matrix, and b is an m-vector. -C It is assumed that a QR factorization, with column pivoting, of A -C is available, that is, A*P = Q*R, where P is a permutation matrix, -C Q has orthogonal columns, and R is an upper triangular matrix -C with diagonal elements of nonincreasing magnitude. -C The routine needs the full upper triangle of R, the permutation -C matrix P, and the first n components of Q'*b (' denotes the -C transpose). The system A*x = b, D*x = 0, is then equivalent to -C -C R*z = Q'*b , P'*D*P*z = 0 , (1) -C -C where x = P*z. If this system does not have full rank, then a -C least squares solution is obtained. On output, MB02YD also -C provides an upper triangular matrix S such that -C -C P'*(A'*A + D*D)*P = S'*S . -C -C The system (1) is equivalent to S*z = c , where c contains the -C first n components of the vector obtained by applying to -C [ (Q'*b)' 0 ]' the transformations which triangularized -C [ R' P'*D*P ]', getting S. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrix S should be -C estimated, as follows: -C = 'E' : use incremental condition estimation and store -C the numerical rank of S in RANK; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of S for zero values; -C = 'U' : use the rank already stored in RANK. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C A*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C RANK (input or output) INTEGER -C On entry, if COND = 'U', this parameter must contain the -C (numerical) rank of the matrix S. -C On exit, if COND = 'E' or 'N', this parameter contains -C the numerical rank of the matrix S, estimated according -C to the value of COND. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system A*x = b, D*x = 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C rank of the matrix S. If the user sets TOL > 0, then the -C given value of TOL is used as a lower bound for the -C reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S, and -C the next N elements contain the solution z. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 4*N, if COND = 'E'; -C LDWORK >= 2*N, if COND <> 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Standard plane rotations are used to annihilate the elements of -C the diagonal matrix D, updating the upper triangular matrix R -C and the first n elements of the vector Q'*b. A basic least squares -C solution is computed. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C This routine is a LAPACK-based modification of QRSOLV from the -C MINPACK package [1], and with optional condition estimation. -C The option COND = 'U' is useful when dealing with several -C right-hand side vectors. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, SVLMAX - PARAMETER ( ZERO = 0.0D0, SVLMAX = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, N, RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) -C .. Local Scalars .. - DOUBLE PRECISION CS, QTBPJ, SN, TEMP, TOLDEF - INTEGER I, J, K, L - LOGICAL ECOND, NCOND, UCOND -C .. Local Arrays .. - DOUBLE PRECISION DUM(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DROT, DSWAP, MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - UCOND = LSAME( COND, 'U' ) - INFO = 0 - IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN - INFO = -8 - ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN - INFO = -12 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB02YD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( .NOT.UCOND ) - $ RANK = 0 - RETURN - END IF -C -C Copy R and Q'*b to preserve input and initialize S. -C In particular, save the diagonal elements of R in X. -C - DO 20 J = 1, N - X(J) = R(J,J) - DO 10 I = J, N - R(I,J) = R(J,I) - 10 CONTINUE - 20 CONTINUE -C - CALL DCOPY( N, QTB, 1, DWORK(N+1), 1 ) -C -C Eliminate the diagonal matrix D using Givens rotations. -C - DO 50 J = 1, N -C -C Prepare the row of D to be eliminated, locating the -C diagonal element using P from the QR factorization. -C - L = IPVT(J) - IF ( DIAG(L).NE.ZERO ) THEN - QTBPJ = ZERO - DWORK(J) = DIAG(L) -C - DO 30 K = J + 1, N - DWORK(K) = ZERO - 30 CONTINUE -C -C The transformations to eliminate the row of D modify only -C a single element of Q'*b beyond the first n, which is -C initially zero. -C - DO 40 K = J, N -C -C Determine a Givens rotation which eliminates the -C appropriate element in the current row of D. -C - IF ( DWORK(K).NE.ZERO ) THEN -C - CALL DLARTG( R(K,K), DWORK(K), CS, SN, TEMP ) -C -C Compute the modified diagonal element of R and -C the modified elements of (Q'*b,0). -C Accumulate the tranformation in the row of S. -C - TEMP = CS*DWORK(N+K) + SN*QTBPJ - QTBPJ = -SN*DWORK(N+K) + CS*QTBPJ - DWORK(N+K) = TEMP - CALL DROT( N-K+1, R(K,K), 1, DWORK(K), 1, CS, SN ) -C - END IF - 40 CONTINUE -C - END IF -C -C Store the diagonal element of S and, if COND <> 'E', restore -C the corresponding diagonal element of R. -C - DWORK(J) = R(J,J) - IF ( .NOT.ECOND ) - $ R(J,J) = X(J) - 50 CONTINUE -C -C Solve the triangular system for z. If the system is singular, -C then obtain a least squares solution. -C - IF ( ECOND ) THEN - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - END IF -C -C Interchange the strict upper and lower triangular parts of R. -C - DO 60 J = 2, N - CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) - 60 CONTINUE -C -C Estimate the reciprocal condition number of S and set the rank. -C Additional workspace: 2*N. -C - CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TOLDEF, SVLMAX, - $ DWORK, RANK, DUM, DWORK(2*N+1), LDWORK-2*N, - $ INFO ) - R(1,1) = X(1) -C -C Restore the strict upper and lower triangular parts of R. -C - DO 70 J = 2, N - CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) - R(J,J) = X(J) - 70 CONTINUE -C - ELSEIF ( NCOND ) THEN -C -C Determine rank(S) by checking zero diagonal entries. -C - RANK = N -C - DO 80 J = 1, N - IF ( DWORK(J).EQ.ZERO .AND. RANK.EQ.N ) - $ RANK = J - 1 - 80 CONTINUE -C - END IF -C - DUM(1) = ZERO - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, DWORK(N+RANK+1), 1 ) -C -C Solve S*z = c using back substitution. -C - DO 100 J = RANK, 1, -1 - TEMP = ZERO -C - DO 90 I = J + 1, RANK - TEMP = TEMP + R(I,J)*DWORK(N+I) - 90 CONTINUE -C - DWORK(N+J) = ( DWORK(N+J) - TEMP )/DWORK(J) - 100 CONTINUE -C -C Permute the components of z back to components of x. -C - DO 110 J = 1, N - L = IPVT(J) - X(L) = DWORK(N+J) - 110 CONTINUE -C - RETURN -C -C *** Last line of MB02YD *** - END diff --git a/slycot/src/MB03MD.f b/slycot/src/MB03MD.f deleted file mode 100644 index 7f47657f..00000000 --- a/slycot/src/MB03MD.f +++ /dev/null @@ -1,343 +0,0 @@ - SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an upper bound THETA using a bisection method such that -C the bidiagonal matrix -C -C |q(1) e(1) 0 ... 0 | -C | 0 q(2) e(2) . | -C J = | . . | -C | . e(N-1)| -C | 0 ... ... q(N) | -C -C has precisely L singular values less than or equal to THETA plus -C a given tolerance TOL. -C -C This routine is mainly intended to be called only by other SLICOT -C routines. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the bidiagonal matrix J. N >= 0. -C -C L (input/output) INTEGER -C On entry, L must contain the number of singular values -C of J which must be less than or equal to the upper bound -C computed by the routine. 0 <= L <= N. -C On exit, L may be increased if the L-th smallest singular -C value of J has multiplicity greater than 1. In this case, -C L is increased by the number of singular values of J which -C are larger than its L-th smallest one and approach the -C L-th smallest singular value of J within a distance less -C than TOL. -C If L has been increased, then the routine returns with -C IWARN set to 1. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, THETA must contain an initial estimate for the -C upper bound to be computed. If THETA < 0.0 on entry, then -C one of the following default values is used. -C If L = 0, THETA is set to 0.0 irrespective of the input -C value of THETA; if L = 1, then THETA is taken as -C MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is -C taken as ABS(Q(N-L+1)). -C On exit, THETA contains the computed upper bound such that -C the bidiagonal matrix J has precisely L singular values -C less than or equal to THETA + TOL. -C -C Q (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements q(1), -C q(2),...,q(N) of the bidiagonal matrix J. That is, -C Q(i) = J(i,i) for i = 1,2,...,N. -C -C E (input) DOUBLE PRECISION array, dimension (N-1) -C This array must contain the superdiagonal elements -C e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is, -C E(k) = J(k,k+1) for k = 1,2,...,N-1. -C -C Q2 (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the squares of the diagonal -C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. -C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. -C -C E2 (input) DOUBLE PRECISION array, dimension (N-1) -C This array must contain the squares of the superdiagonal -C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. -C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. -C -C PIVMIN (input) DOUBLE PRECISION -C The minimum absolute value of a "pivot" in the Sturm -C sequence loop. -C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), -C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at -C least the smallest number that can divide one without -C overflow (see LAPACK Library routine DLAMCH). -C Note that this condition is not checked by the routine. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL >= 0. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. -C RELTOL >= BASE * EPS, where BASE is machine radix and EPS -C is machine precision (see LAPACK Library routine DLAMCH). -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warnings; -C = 1: if the value of L has been increased as the L-th -C smallest singular value of J coincides with the -C (L+1)-th smallest one. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let s(i), i = 1,2,...,N, be the N non-negative singular values of -C the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0. -C The routine then computes an upper bound T such that s(N-L) > T >= -C s(N-L+1) as follows (see [2]). -C First, if the initial estimate of THETA is not specified by the -C user then the routine initialises THETA to be an estimate which -C is close to the requested value of THETA if s(N-L) >> s(N-L+1). -C Second, a bisection method (see [1, 8.5]) is used which generates -C a sequence of shrinking intervals [Y,Z] such that either THETA in -C [Y,Z] was found (so that J has L singular values less than or -C equal to THETA), or -C -C (number of s(i) <= Y) < L < (number of s(i) <= Z). -C -C This bisection method is applied to an associated 2N-by-2N -C symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are -C given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the -C starting values for the bisection method is the initial value of -C THETA. If this value is an upper bound, then the initial lower -C bound is set to zero, else the initial upper bound is computed -C from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to -C T". The computation of the "number of s(i) <= Y (or Z)" is -C achieved by calling SLICOT Library routine MB03ND, which applies -C Sylvester's Law of Inertia or equivalently Sturm sequences -C [1, 8.5] to the associated matrix T". If -C -C Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) -C -C at some stage of the bisection method, then at least two singular -C values of J lie in the interval [Y,Z] within a distance less than -C TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed -C to coincide, the upper bound T is set to the value of Z, the value -C of L is increased and IWARN is set to 1. -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C Matrix Computations. -C The Johns Hopkins University Press, Baltimore, Maryland, 1983. -C -C [2] Van Huffel, S. and Vandewalle, J. -C The Partial Total Least Squares Algorithm. -C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB03AD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 16, 1997, Oct. 26, 2003. -C -C KEYWORDS -C -C Bidiagonal matrix, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, TWO - PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0 ) - DOUBLE PRECISION FUDGE - PARAMETER ( FUDGE = TWO ) -C .. Scalar Arguments .. - INTEGER INFO, IWARN, L, N - DOUBLE PRECISION PIVMIN, RELTOL, THETA, TOL -C .. Array Arguments .. - DOUBLE PRECISION E(*), E2(*), Q(*), Q2(*) -C .. Local Scalars .. - INTEGER I, NUM, NUMZ - DOUBLE PRECISION H, TH, Y, Z -C .. External Functions .. - INTEGER MB03ND - DOUBLE PRECISION DLAMCH, MB03MY - EXTERNAL DLAMCH, MB03MY, MB03ND -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C -C Test some input scalar arguments. -C - IWARN = 0 - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( L.LT.0 .OR. L.GT.N ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C -C Step 1: initialisation of THETA. -C ----------------------- - IF ( L.EQ.0 ) THETA = ZERO - IF ( THETA.LT.ZERO ) THEN - IF ( L.EQ.1 ) THEN -C -C An upper bound which is close if S(N-1) >> S(N): -C - THETA = MB03MY( N, Q, 1 ) - IF ( N.EQ.1 ) - $ RETURN - ELSE -C -C An experimentally established estimate which is good if -C S(N-L) >> S(N-L+1): -C - THETA = ABS( Q(N-L+1) ) - END IF - END IF -C -C Step 2: Check quality of initial estimate THETA. -C --------------------------------------- - NUM = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) - IF ( NUM.EQ.L ) - $ RETURN -C -C Step 3: initialisation starting values for bisection method. -C --------------------------------------------------- -C Let S(i), i=1,...,N, be the singular values of J in decreasing -C order. Then, the computed Y and Z will be such that -C (number of S(i) <= Y) < L < (number of S(i) <= Z). -C - IF ( NUM.LT.L ) THEN - TH = ABS( Q(1) ) - Z = ZERO - Y = THETA - NUMZ = N -C - DO 20 I = 1, N - 1 - H = ABS( Q(I+1) ) - Z = MAX( MAX( TH, H ) + ABS( E(I) ), Z ) - TH = H - 20 CONTINUE -C -C Widen the Gershgorin interval a bit for machines with sloppy -C arithmetic. -C - Z = Z + FUDGE*ABS( Z )*DLAMCH( 'Epsilon' )*DBLE( N ) - $ + FUDGE*PIVMIN - ELSE - Z = THETA - Y = ZERO - NUMZ = NUM - END IF -C -C Step 4: Bisection method for finding the upper bound on the L -C smallest singular values of the bidiagonal. -C ------------------------------------------ -C A sequence of subintervals [Y,Z] is produced such that -C (number of S(i) <= Y) < L < (number of S(i) <= Z). -C NUM : number of S(i) <= TH, -C NUMZ: number of S(i) <= Z. -C -C WHILE ( ( NUM .NE. L ) .AND. -C ( ( Z-Y ) .GT. MAX( TOL, PIVMIN, RELTOL*ABS( Z ) ) ) ) DO - 40 IF ( ( NUM.NE.L ) .AND. - $ ( ABS( Z-Y ).GT.MAX( TOL, PIVMIN, - $ RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) ) ) - $ THEN - TH = ( Y + Z )/TWO - NUM = MB03ND( N, TH, Q2, E2, PIVMIN, INFO ) - IF ( NUM.LT.L ) THEN - Y = TH - ELSE - Z = TH - NUMZ = NUM - END IF - GO TO 40 - END IF -C END WHILE 40 -C -C If NUM <> L and ( Z - Y ) <= TOL, then at least two singular -C values of J lie in the interval [Y,Z] within a distance less than -C TOL from each other. S(N-L) and S(N-L+1) are then assumed to -C coincide. L is increased, and a warning is given. -C - IF ( NUM.NE.L ) THEN - L = NUMZ - THETA = Z - IWARN = 1 - ELSE - THETA = TH - END IF -C - RETURN -C *** Last line of MB03MD *** - END diff --git a/slycot/src/MB03MY.f b/slycot/src/MB03MY.f deleted file mode 100644 index cee355e8..00000000 --- a/slycot/src/MB03MY.f +++ /dev/null @@ -1,91 +0,0 @@ - DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the absolute minimal value of NX elements in an array. -C The function returns the value zero if NX < 1. -C -C ARGUMENTS -C -C NX (input) INTEGER -C The number of elements in X to be examined. -C -C X (input) DOUBLE PRECISION array, dimension (NX * INCX) -C The one-dimensional array of which the absolute minimal -C value of the elements is to be computed. -C This array is not referenced if NX < 1. -C -C INCX (input) INTEGER -C The increment to be taken in the array X, defining the -C distance between two consecutive elements. INCX >= 1. -C INCX = 1, if all elements are contiguous in memory. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MB03AZ by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C June 16, 1997. -C -C KEYWORDS -C -C None. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INCX, NX -C .. Array Arguments .. - DOUBLE PRECISION X(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION DX -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( NX.LE.0 ) THEN - MB03MY = ZERO - RETURN - END IF -C - MB03MY = ABS( X(1) ) -C - DO 20 I = 1+INCX, NX*INCX, INCX - DX = ABS( X(I) ) - IF ( DX.LT.MB03MY ) MB03MY = DX - 20 CONTINUE -C - RETURN -C *** Last line of MB03MY *** - END diff --git a/slycot/src/MB03ND.f b/slycot/src/MB03ND.f deleted file mode 100644 index a6cbbd52..00000000 --- a/slycot/src/MB03ND.f +++ /dev/null @@ -1,218 +0,0 @@ - INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the number of singular values of the bidiagonal matrix -C -C |q(1) e(1) . ... 0 | -C | 0 q(2) e(2) . | -C J = | . . | -C | . e(N-1)| -C | 0 ... ... 0 q(N) | -C -C which are less than or equal to a given bound THETA. -C -C This routine is intended to be called only by other SLICOT -C routines. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the bidiagonal matrix J. N >= 0. -C -C THETA (input) DOUBLE PRECISION -C Given bound. -C Note: If THETA < 0.0 on entry, then MB03ND is set to 0 -C as the singular values of J are non-negative. -C -C Q2 (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the squares of the diagonal -C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. -C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. -C -C E2 (input) DOUBLE PRECISION array, dimension (N-1) -C This array must contain the squares of the superdiagonal -C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. -C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. -C -C PIVMIN (input) DOUBLE PRECISION -C The minimum absolute value of a "pivot" in the Sturm -C sequence loop. -C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), -C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at -C least the smallest number that can divide one without -C overflow (see LAPACK Library routine DLAMCH). -C Note that this condition is not checked by the routine. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The computation of the number of singular values s(i) of J which -C are less than or equal to THETA is based on applying Sylvester's -C Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the -C unreduced symmetric tridiagonal matrices associated with J as -C follows. Let T be the following 2N-by-2N symmetric matrix -C associated with J: -C -C | 0 J'| -C T = | |. -C | J 0 | -C -C (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2), -C ...,-s(N)). Then, by permuting the rows and columns of T into the -C order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally -C similar to the tridiagonal matrix T" with zeros on its diagonal -C and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals -C [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero, -C Sylvester's Law of Inertia may be applied directly to T". -C Otherwise, T" is block diagonal and each diagonal block (which is -C then unreduced) must be analysed separately by applying -C Sylvester's Law of Inertia. -C -C REFERENCES -C -C [1] Parlett, B.N. -C The Symmetric Eigenvalue Problem. -C Prentice Hall, Englewood Cliffs, New Jersey, 1980. -C -C [2] Demmel, J. and Kahan, W. -C Computing Small Singular Values of Bidiagonal Matrices with -C Guaranteed High Relative Accuracy. -C Technical Report, Courant Inst., New York, March 1988. -C -C [3] Van Huffel, S. and Vandewalle, J. -C The Partial Total Least-Squares Algorithm. -C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. -C -C [4] Golub, G.H. and Kahan, W. -C Calculating the Singular Values and Pseudo-inverse of a -C Matrix. -C SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965. -C -C [5] Demmel, J.W., Dhillon, I. and Ren, H. -C On the Correctness of Parallel Bisection in Floating Point. -C Computer Science Division Technical Report UCB//CSD-94-805, -C University of California, Berkeley, CA 94720, March 1994. -C -C NUMERICAL ASPECTS -C -C The singular values s(i) could also be obtained with the use of -C the symmetric tridiagonal matrix T = J'J, whose eigenvalues are -C the squared singular values of J [4,p.213]. However, the method -C actually used by the routine is more accurate and equally -C efficient (see [2]). -C -C To avoid overflow, matrix J should be scaled so that its largest -C element is no greater than overflow**(1/2) * underflow**(1/4) -C in absolute value (and not much smaller than that, for maximal -C accuracy). -C -C With respect to accuracy the following condition holds (see [2]): -C -C If the established value is denoted by p, then at least p -C singular values of J are less than or equal to -C THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values -C are less than or equal to -C THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke -C University, Leuven, Belgium. -C -C REVISIONS -C -C July 10, 1997. -C -C KEYWORDS -C -C Bidiagonal matrix, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, N - DOUBLE PRECISION PIVMIN, THETA -C .. Array Arguments .. - DOUBLE PRECISION E2(*), Q2(*) -C .. Local Scalars .. - INTEGER J, NUMEIG - DOUBLE PRECISION R, T -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C -C Test the input scalar arguments. PIVMIN is not checked. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - MB03ND = ZERO - CALL XERBLA( 'MB03ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN - MB03ND = 0 - RETURN - END IF -C - NUMEIG = N - T = -THETA - R = T - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN -C - DO 20 J = 1, N - 1 - R = T - Q2(J)/R - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN - IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 - R = T - E2(J)/R - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN - IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 - 20 CONTINUE -C - R = T - Q2(N)/R - IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN - IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 - MB03ND = NUMEIG -C - RETURN -C *** Last line of MB03ND *** - END diff --git a/slycot/src/MB03NY.f b/slycot/src/MB03NY.f deleted file mode 100644 index e507ea29..00000000 --- a/slycot/src/MB03NY.f +++ /dev/null @@ -1,211 +0,0 @@ - DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK, - $ LDWORK, CWORK, LCWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the smallest singular value of A - jwI. -C -C FUNCTION VALUE -C -C MB03NY DOUBLE PRECISION -C The smallest singular value of A - jwI (if INFO = 0). -C If N = 0, the function value is set to zero. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the the matrix A. N >= 0. -C -C OMEGA (input) DOUBLE PRECISION -C The constant factor of A - jwI. -C -C A (input/workspace) DOUBLE PRECISION array, dimension -C (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, if OMEGA = 0, the contents of this array are -C destroyed. Otherwise, this array is unchanged. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C S (output) DOUBLE PRECISION array, dimension (N) -C The singular values of A - jwI in decreasing order. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX( 1, 5*N ). -C For optimum performance LDWORK should be larger. -C -C CWORK COMPLEX*16 array, dimension (LCWORK) -C On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the -C optimal value of LCWORK. -C If OMEGA is zero, this array is not referenced. -C -C LCWORK INTEGER -C The length of the array CWORK. -C LCWORK >= 1, if OMEGA = 0; -C LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0. -C For optimum performance LCWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: The SVD algorithm (in either LAPACK Library routine -C DGESVD or ZGESVD) fails to converge; this error is -C very rare. -C -C METHOD -C -C This procedure simply constructs the matrix A - jwI, and calls -C ZGESVD if w is not zero, or DGESVD if w = 0. -C -C FURTHER COMMENTS -C -C This routine is not very efficient because it computes all -C singular values, but it is very accurate. The routine is intended -C to be called only from the SLICOT Library routine AB13FD. -C -C CONTRIBUTOR -C -C R. Byers, the routine SIGMIN (January, 1995). -C -C REVISIONS -C -C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. -C -C REVISIONS -C -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C Apr. 2002, V. Sima. -C -C KEYWORDS -C -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CONE, RTMONE - PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), - $ RTMONE = ( 0.0D0, 1.0D0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LCWORK, LDA, LDWORK, N - DOUBLE PRECISION OMEGA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), S(*) - COMPLEX*16 CWORK(*) -C .. Local Scalars .. - INTEGER I, IC, J -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1,1) - COMPLEX*16 ZDUMMY(1,1) -C .. External Subroutines .. - EXTERNAL DGESVD, XERBLA, ZGESVD -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDWORK.LT.MAX( 1, 5*N ) ) THEN - INFO = -7 - ELSE IF( LCWORK.LT.1 .OR. ( OMEGA.NE.ZERO .AND. - $ LCWORK.LT.N*N + 3*N ) ) THEN - INFO = -9 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - MB03NY = ZERO - CALL XERBLA( 'MB03NY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - MB03NY = ZERO - DWORK(1) = ONE - IF ( OMEGA.NE.ZERO ) - $ CWORK(1) = CONE - RETURN - END IF -C - IF ( OMEGA.EQ.ZERO ) THEN -C -C OMEGA = 0 allows real SVD. -C - CALL DGESVD( 'No vectors', 'No vectors', N, N, A, N, S, DUMMY, - $ 1, DUMMY, 1, DWORK, LDWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 2 - MB03NY = ZERO - RETURN - END IF - ELSE -C -C General case, that is complex SVD. -C - IC = 1 - DO 20 J = 1, N - DO 10 I = 1, N - CWORK(IC) = A(I,J) - IC = IC + 1 - 10 CONTINUE - CWORK((J-1)*N+J) = CWORK((J-1)*N+J) - OMEGA * RTMONE - 20 CONTINUE - CALL ZGESVD( 'No vectors', 'No vectors', N, N, CWORK, N, S, - $ ZDUMMY, 1, ZDUMMY, 1, CWORK(N*N+1), LCWORK-N*N, - $ DWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 2 - MB03NY = ZERO - RETURN - END IF - CWORK(1) = CWORK(N*N+1) + DBLE( N*N ) * CONE - DWORK(1) = DBLE( 5*N ) - END IF -C - MB03NY = S(N) -C -C *** Last line of MB03NY *** - END diff --git a/slycot/src/MB03OD.f b/slycot/src/MB03OD.f deleted file mode 100644 index 71cb43d6..00000000 --- a/slycot/src/MB03OD.f +++ /dev/null @@ -1,306 +0,0 @@ - SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, - $ RANK, SVAL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute (optionally) a rank-revealing QR factorization of a -C real general M-by-N matrix A, which may be rank-deficient, -C and estimate its effective rank using incremental condition -C estimation. -C -C The routine uses a QR factorization with column pivoting: -C A * P = Q * R, where R = [ R11 R12 ], -C [ 0 R22 ] -C with R11 defined as the largest leading submatrix whose estimated -C condition number is less than 1/RCOND. The order of R11, RANK, -C is the effective rank of A. -C -C MB03OD does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBQR CHARACTER*1 -C = 'Q': Perform a QR factorization with column pivoting; -C = 'N': Do not perform the QR factorization (but assume -C that it has been done outside). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry with JOBQR = 'Q', the leading M by N part of this -C array must contain the given matrix A. -C On exit with JOBQR = 'Q', the leading min(M,N) by N upper -C triangular part of A contains the triangular factor R, -C and the elements below the diagonal, with the array TAU, -C represent the orthogonal matrix Q as a product of -C min(M,N) elementary reflectors. -C On entry and on exit with JOBQR = 'N', the leading -C min(M,N) by N upper triangular part of A contains the -C triangular factor R, as determined by the QR factorization -C with pivoting. The elements below the diagonal of A are -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input/output) INTEGER array, dimension ( N ) -C On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th -C column of A is an initial column, otherwise it is a free -C column. Before the QR factorization of A, all initial -C columns are permuted to the leading positions; only the -C remaining free columns are moved as a result of column -C pivoting during the factorization. For rank determination -C it is preferable that all columns be free. -C On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th -C column of A*P was the k-th column of A. -C Array JPVT is not referenced when JOBQR = 'N'. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C RCOND >= 0. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C On exit with JOBQR = 'Q', the leading min(M,N) elements of -C TAU contain the scalar factors of the elementary -C reflectors. -C Array TAU is not referenced when JOBQR = 'N'. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e. the order of -C the submatrix R11. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 3*N + 1, if JOBQR = 'Q'; -C LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'. -C For good performance when JOBQR = 'Q', LDWORK should be -C larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where -C NB is the optimal block size for the LAPACK Library -C routine DGEQP3. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes or uses a QR factorization with column -C pivoting of A, A * P = Q * R, with R defined above, and then -C finds the largest leading submatrix whose estimated condition -C number is less than 1/RCOND, taking the possible positive value of -C SVLMAX into account. This is performed using the LAPACK -C incremental condition estimation scheme and a slightly modified -C rank decision test. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBQR - INTEGER INFO, LDA, LDWORK, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) -C .. Local Scalars .. - LOGICAL LJOBQR - INTEGER I, ISMAX, ISMIN, MAXWRK, MINWRK, MN - DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEQP3, DLAIC1, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - LJOBQR = LSAME( JOBQR, 'Q' ) - MN = MIN( M, N ) - ISMIN = 1 - ISMAX = MN + 1 - IF( LJOBQR ) THEN - MINWRK = 3*N + 1 - ELSE - MINWRK = MAX( 1, 2*MN ) - END IF - MAXWRK = MINWRK -C -C Test the input scalar arguments. -C - INFO = 0 - IF( .NOT.LJOBQR .AND. .NOT.LSAME( JOBQR, 'N' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( RCOND.LT.ZERO ) THEN - INFO = -7 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03OD', -INFO ) - RETURN - END IF -C -C Quick return if possible -C - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C - IF ( LJOBQR ) THEN -C -C Compute QR factorization with column pivoting of A: -C A * P = Q * R -C Workspace need 3*N + 1; -C prefer 2*N + (N+1)*NB. -C Details of Householder rotations stored in TAU. -C - CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, LDWORK, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) - END IF -C -C Determine RANK using incremental condition estimation -C - DWORK( ISMIN ) = ONE - DWORK( ISMAX ) = ONE - SMAX = ABS( A( 1, 1 ) ) - SMIN = SMAX - IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN - RANK = 0 - SVAL( 1 ) = SMAX - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - ELSE - RANK = 1 - SMINPR = SMIN -C - 10 CONTINUE - IF( RANK.LT.MN ) THEN - I = RANK + 1 - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), - $ A( I, I ), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), - $ A( I, I ), SMAXPR, S2, C2 ) -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN - DO 20 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 20 CONTINUE - DWORK( ISMIN+RANK ) = C1 - DWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 10 - END IF - END IF - END IF - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR - END IF -C - DWORK( 1 ) = MAXWRK - RETURN -C *** Last line of MB03OD *** - END diff --git a/slycot/src/MB03OY.f b/slycot/src/MB03OY.f deleted file mode 100644 index e39734d5..00000000 --- a/slycot/src/MB03OY.f +++ /dev/null @@ -1,388 +0,0 @@ - SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing QR factorization of a real general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated QR factorization with column pivoting -C [ R11 R12 ] -C A * P = Q * R, where R = [ ], -C [ 0 R22 ] -C with R11 defined as the largest leading upper triangular submatrix -C whose estimated condition number is less than 1/RCOND. The order -C of R11, RANK, is the effective rank of A. Condition estimation is -C performed during the QR factorization process. Matrix R22 is full -C (but of small norm), or empty. -C -C MB03OY does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the leading RANK-by-RANK upper triangular part -C of A contains the triangular factor R11, and the elements -C below the diagonal in the first RANK columns, with the -C array TAU, represent the orthogonal matrix Q as a product -C of RANK elementary reflectors. -C The remaining N-RANK columns contain the result of the -C QR factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R11. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C JPVT (output) INTEGER array, dimension ( N ) -C If JPVT(i) = k, then the i-th column of A*P was the k-th -C column of A. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C The leading RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 3*N-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of A, A * P = Q * R, with R defined above, and, -C during this process, finds the largest leading submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using the LAPACK incremental condition estimation scheme and a -C slightly modified rank decision test. The factorization process -C stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in -C A(i+1:m,i), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth column of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, orthogonal transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P05 = 0.05D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) -C .. -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT - DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, - $ SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2, IDAMAX -C .. External Subroutines .. - EXTERNAL DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - 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( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03OY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - MN = MIN( M, N ) - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = 1 - ISMAX = ISMIN + N -C -C Initialize partial column norms and pivoting vector. The first n -C elements of DWORK store the exact column norms. The already used -C leading part is then overwritten by the condition estimator. -C - DO 10 I = 1, N - DWORK( I ) = DNRM2( M, A( 1, I ), 1 ) - DWORK( N+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.MN ) THEN - I = RANK + 1 -C -C Determine ith pivot column and swap if necessary. -C - PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) -C - 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 - DWORK( PVT ) = DWORK( I ) - DWORK( N+PVT ) = DWORK( N+I ) - END IF -C -C Save A(I,I) and generate elementary reflector H(i). -C - IF( I.LT.M ) THEN - AII = A( I, I ) - CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) - ELSE - TAU( M ) = ZERO - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( 1, 1 ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), - $ A( I, I ), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), - $ A( I, I ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Continue factorization, as rank is at least RANK. -C - IF( I.LT.N ) THEN -C -C Apply H(i) to A(i:m,i+1:n) from the left. -C - 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, - $ DWORK( 2*N+1 ) ) - A( I, I ) = AII - END IF -C -C Update partial column norms. -C - DO 30 J = I + 1, N - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( N+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - IF( M-I.GT.0 ) THEN - DWORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) - DWORK( N+J ) = DWORK( J ) - ELSE - DWORK( J ) = ZERO - DWORK( N+J ) = ZERO - END IF - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - DO 40 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 40 CONTINUE -C - DWORK( ISMIN+RANK ) = C1 - DWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (RANK+1)-th column and set SVAL. -C - IF ( RANK.LT.N ) THEN - IF ( I.LT.M ) THEN - CALL DSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = AII - END IF - END IF - IF ( RANK.EQ.0 ) THEN - SMIN = ZERO - SMINPR = ZERO - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB03OY *** - END diff --git a/slycot/src/MB03PD.f b/slycot/src/MB03PD.f deleted file mode 100644 index 5dae9366..00000000 --- a/slycot/src/MB03PD.f +++ /dev/null @@ -1,339 +0,0 @@ - SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, - $ RANK, SVAL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute (optionally) a rank-revealing RQ factorization of a -C real general M-by-N matrix A, which may be rank-deficient, -C and estimate its effective rank using incremental condition -C estimation. -C -C The routine uses an RQ factorization with row pivoting: -C P * A = R * Q, where R = [ R11 R12 ], -C [ 0 R22 ] -C with R22 defined as the largest trailing submatrix whose estimated -C condition number is less than 1/RCOND. The order of R22, RANK, -C is the effective rank of A. -C -C MB03PD does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBRQ CHARACTER*1 -C = 'R': Perform an RQ factorization with row pivoting; -C = 'N': Do not perform the RQ factorization (but assume -C that it has been done outside). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry with JOBRQ = 'R', the leading M-by-N part of this -C array must contain the given matrix A. -C On exit with JOBRQ = 'R', -C if M <= N, the upper triangle of the subarray -C A(1:M,N-M+1:N) contains the M-by-M upper triangular -C matrix R; -C if M >= N, the elements on and above the (M-N)-th -C subdiagonal contain the M-by-N upper trapezoidal matrix R; -C the remaining elements, with the array TAU, represent the -C orthogonal matrix Q as a product of min(M,N) elementary -C reflectors (see METHOD). -C On entry and on exit with JOBRQ = 'N', -C if M <= N, the upper triangle of the subarray -C A(1:M,N-M+1:N) must contain the M-by-M upper triangular -C matrix R; -C if M >= N, the elements on and above the (M-N)-th -C subdiagonal must contain the M-by-N upper trapezoidal -C matrix R; -C the remaining elements are not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input/output) INTEGER array, dimension ( M ) -C On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row -C of A is a final row, otherwise it is a free row. Before -C the RQ factorization of A, all final rows are permuted -C to the trailing positions; only the remaining free rows -C are moved as a result of row pivoting during the -C factorization. For rank determination it is preferable -C that all rows be free. -C On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th -C row of P*A was the k-th row of A. -C Array JPVT is not referenced when JOBRQ = 'N'. -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest trailing triangular -C submatrix R22 in the RQ factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C RCOND >= 0. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C On exit with JOBRQ = 'R', the leading min(M,N) elements of -C TAU contain the scalar factors of the elementary -C reflectors. -C Array TAU is not referenced when JOBRQ = 'N'. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e. the order of -C the submatrix R22. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(2): smallest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), -C if RANK < MIN( M, N ), or of -C R(M-RANK+1:M,N-RANK+1:N), otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the trailing rows were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(M-RANK+1:M,N-RANK+1:N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) -C where LDWORK = max( 1, 3*M ), if JOBRQ = 'R'; -C LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes or uses an RQ factorization with row -C pivoting of A, P * A = R * Q, with R defined above, and then -C finds the largest trailing submatrix whose estimated condition -C number is less than 1/RCOND, taking the possible positive value of -C SVLMAX into account. This is performed using an adaptation of the -C LAPACK incremental condition estimation scheme and a slightly -C modified rank decision test. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit -C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. -C -C REVISIONS -C -C Nov. 1997 -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, orthogonal transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBRQ - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) -C .. Local Scalars .. - LOGICAL LJOBRQ - INTEGER I, ISMAX, ISMIN, JWORK, MN - DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLAIC1, MB04GD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C - LJOBRQ = LSAME( JOBRQ, 'R' ) - MN = MIN( M, N ) -C -C Test the input scalar arguments. -C - INFO = 0 - IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( RCOND.LT.ZERO ) THEN - INFO = -7 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -8 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - IF ( LJOBRQ ) THEN -C -C Compute RQ factorization with row pivoting of A: -C P * A = R * Q -C Workspace 3*M. Details of Householder rotations stored in TAU. -C - CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO ) - END IF -C -C Determine RANK using incremental condition estimation. -C Workspace 3*min(M,N). -C - SMAX = ABS( A( M, N ) ) - IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN - RANK = 0 - SVAL( 1 ) = SMAX - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - ELSE - ISMIN = MN - ISMAX = 2*MN - JWORK = ISMAX + 1 - DWORK( ISMIN ) = ONE - DWORK( ISMAX ) = ONE - RANK = 1 - SMIN = SMAX - SMINPR = SMIN -C - 10 CONTINUE - IF( RANK.LT.MN ) THEN - CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA, - $ DWORK( JWORK ), 1 ) - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, - $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR, - $ S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, - $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR, - $ S2, C2 ) -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN - DO 20 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 20 CONTINUE - ISMIN = ISMIN - 1 - ISMAX = ISMAX - 1 - DWORK( ISMIN ) = C1 - DWORK( ISMAX ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 10 - END IF - END IF - END IF - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR - END IF -C - RETURN -C *** Last line of MB03PD *** - END diff --git a/slycot/src/MB03PY.f b/slycot/src/MB03PY.f deleted file mode 100644 index d0c7d0ca..00000000 --- a/slycot/src/MB03PY.f +++ /dev/null @@ -1,392 +0,0 @@ - SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing RQ factorization of a real general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated RQ factorization with row pivoting: -C [ R11 R12 ] -C P * A = R * Q, where R = [ ], -C [ 0 R22 ] -C with R22 defined as the largest trailing upper triangular -C submatrix whose estimated condition number is less than 1/RCOND. -C The order of R22, RANK, is the effective rank of A. Condition -C estimation is performed during the RQ factorization process. -C Matrix R11 is full (but of small norm), or empty. -C -C MB03PY does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the upper triangle of the subarray -C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper -C triangular matrix R22; the remaining elements in the last -C RANK rows, with the array TAU, represent the orthogonal -C matrix Q as a product of RANK elementary reflectors -C (see METHOD). The first M-RANK rows contain the result -C of the RQ factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest trailing triangular -C submatrix R22 in the RQ factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R22. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(2): smallest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), -C if RANK < MIN( M, N ), or of -C R(M-RANK+1:M,N-RANK+1:N), otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the trailing rows were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(M-RANK+1:M,N-RANK+1:N). -C -C JPVT (output) INTEGER array, dimension ( M ) -C If JPVT(i) = k, then the i-th row of P*A was the k-th row -C of A. -C -C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) -C The trailing RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 3*M-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated RQ factorization with row -C pivoting of A, P * A = R * Q, with R defined above, and, -C during this process, finds the largest trailing submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using an adaptation of the LAPACK incremental condition estimation -C scheme and a slightly modified rank decision test. The -C factorization process stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit -C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, -C Jan. 2009. -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, orthogonal transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, - $ PVT - DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, - $ SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - 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( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03PY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = M - ISMAX = ISMIN + M - JWORK = ISMAX + 1 -C -C Initialize partial row norms and pivoting vector. The first m -C elements of DWORK store the exact row norms. The already used -C trailing part is then overwritten by the condition estimator. -C - DO 10 I = 1, M - DWORK( I ) = DNRM2( N, A( I, 1 ), LDA ) - DWORK( M+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.K ) THEN - I = K - RANK -C -C Determine ith pivot row and swap if necessary. -C - MKI = M - RANK - NKI = N - RANK - PVT = IDAMAX( MKI, DWORK, 1 ) -C - IF( PVT.NE.MKI ) THEN - CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( MKI ) - JPVT( MKI ) = ITEMP - DWORK( PVT ) = DWORK( MKI ) - DWORK( M+PVT ) = DWORK( M+MKI ) - END IF -C - IF( NKI.GT.1 ) THEN -C -C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) -C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). -C - AII = A( MKI, NKI ) - CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) - $ ) - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( M, N ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DCOPY ( RANK, A( MKI, NKI+1 ), LDA, DWORK( JWORK ), 1 ) - CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, - $ DWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, - $ DWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C - IF( MKI.GT.1 ) THEN -C -C Continue factorization, as rank is at least RANK. -C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. -C - AII = A( MKI, NKI ) - A( MKI, NKI ) = ONE - CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, - $ TAU( I ), A, LDA, DWORK( JWORK ) ) - A( MKI, NKI ) = AII -C -C Update partial row norms. -C - DO 30 J = 1, MKI - 1 - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( M+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), - $ LDA ) - DWORK( M+J ) = DWORK( J ) - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - END IF -C - DO 40 I = 1, RANK - DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) - DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) - 40 CONTINUE -C - IF( RANK.GT.0 ) THEN - ISMIN = ISMIN - 1 - ISMAX = ISMAX - 1 - END IF - DWORK( ISMIN ) = C1 - DWORK( ISMAX ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (M-RANK)-th row and set SVAL. -C - IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN - CALL DSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) - A( MKI, NKI ) = AII - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB03PY *** - END diff --git a/slycot/src/MB03QD.f b/slycot/src/MB03QD.f deleted file mode 100644 index d94eed1b..00000000 --- a/slycot/src/MB03QD.f +++ /dev/null @@ -1,316 +0,0 @@ - SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, - $ A, LDA, U, LDU, NDIM, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reorder the diagonal blocks of a principal submatrix of an -C upper quasi-triangular matrix A together with their eigenvalues by -C constructing an orthogonal similarity transformation UT. -C After reordering, the leading block of the selected submatrix of A -C has eigenvalues in a suitably defined domain of interest, usually -C related to stability/instability in a continuous- or discrete-time -C sense. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the spectrum separation to be -C performed as follows: -C = 'C': continuous-time sense; -C = 'D': discrete-time sense. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C JOBU CHARACTER*1 -C Indicates how the performed orthogonal transformations UT -C are accumulated, as follows: -C = 'I': U is initialized to the unit matrix and the matrix -C UT is returned in U; -C = 'U': the given matrix U is updated and the matrix U*UT -C is returned in U. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and U. N >= 1. -C -C NLOW, (input) INTEGER -C NSUP NLOW and NSUP specify the boundary indices for the rows -C and columns of the principal submatrix of A whose diagonal -C blocks are to be reordered. 1 <= NLOW <= NSUP <= N. -C -C ALPHA (input) DOUBLE PRECISION -C The boundary of the domain of interest for the eigenvalues -C of A. If DICO = 'C', ALPHA is the boundary value for the -C real parts of eigenvalues, while for DICO = 'D', -C ALPHA >= 0 represents the boundary value for the moduli of -C eigenvalues. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain a matrix in a real Schur form whose 1-by-1 and -C 2-by-2 diagonal blocks between positions NLOW and NSUP -C are to be reordered. -C On exit, the leading N-by-N part contains the ordered -C real Schur matrix UT' * A * UT with the elements below the -C first subdiagonal set to zero. -C The leading NDIM-by-NDIM part of the principal submatrix -C D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain -C of interest and the trailing part of this submatrix has -C eigenvalues outside the domain of interest. -C The domain of interest for lambda(D), the eigenvalues of -C D, is defined by the parameters ALPHA, DICO and STDOM as -C follows: -C For DICO = 'C': -C Real(lambda(D)) < ALPHA if STDOM = 'S'; -C Real(lambda(D)) > ALPHA if STDOM = 'U'. -C For DICO = 'D': -C Abs(lambda(D)) < ALPHA if STDOM = 'S'; -C Abs(lambda(D)) > ALPHA if STDOM = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C On entry with JOBU = 'U', the leading N-by-N part of this -C array must contain a transformation matrix (e.g. from a -C previous call to this routine). -C On exit, if JOBU = 'U', the leading N-by-N part of this -C array contains the product of the input matrix U and the -C orthogonal matrix UT used to reorder the diagonal blocks -C of A. -C On exit, if JOBU = 'I', the leading N-by-N part of this -C array contains the matrix UT of the performed orthogonal -C transformations. -C Array U need not be set on entry if JOBU = 'I'. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C NDIM (output) INTEGER -C The number of eigenvalues of the selected principal -C submatrix lying inside the domain of interest. -C If NLOW = 1, NDIM is also the dimension of the invariant -C subspace corresponding to the eigenvalues of the leading -C NDIM-by-NDIM submatrix. In this case, if U is the -C orthogonal transformation matrix used to compute and -C reorder the real Schur form of A, its first NDIM columns -C form an orthonormal basis for the above invariant -C subspace. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not -C the leading element of a 1-by-1 or 2-by-2 diagonal -C block of A, or A(NSUP+1,NSUP) is nonzero, i.e. -C A(NSUP,NSUP) is not the bottom element of a 1-by-1 -C or 2-by-2 diagonal block of A; -C = 2: two adjacent blocks are too close to swap (the -C problem is very ill-conditioned). -C -C METHOD -C -C Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2 -C diagonal blocks, the routine reorders its diagonal blocks along -C with its eigenvalues by performing an orthogonal similarity -C transformation UT' * A * UT. The column transformation UT is also -C performed on the given (initial) transformation U (resulted from -C a possible previous step or initialized as the identity matrix). -C After reordering, the eigenvalues inside the region specified by -C the parameters ALPHA, DICO and STDOM appear at the top of -C the selected diagonal block between positions NLOW and NSUP. -C In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such -C that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and -C lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain -C of interest. If NLOW = 1, the first NDIM columns of U*UT span the -C corresponding invariant subspace of A. -C -C REFERENCES -C -C [1] Stewart, G.W. -C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and -C ordering the eigenvalues of a real upper Hessenberg matrix. -C ACM TOMS, 2, pp. 275-280, 1976. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires less than 4*N operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C April 1998. Based on the RASP routine SEOR1. -C -C KEYWORDS -C -C Eigenvalues, invariant subspace, orthogonal transformation, real -C Schur form, similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBU, STDOM - INTEGER INFO, LDA, LDU, N, NDIM, NLOW, NSUP - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), U(LDU,*) -C .. Local Scalars .. - LOGICAL DISCR, LSTDOM - INTEGER IB, L, LM1, NUP - DOUBLE PRECISION E1, E2, TLAMBD -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DLASET, DTREXC, MB03QY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LSTDOM = LSAME( STDOM, 'S' ) -C -C Check input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR. - $ LSAME( JOBU, 'U' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.1 ) THEN - INFO = -4 - ELSE IF( NLOW.LT.1 ) THEN - INFO = -5 - ELSE IF( NLOW.GT.NSUP .OR. NSUP.GT.N ) THEN - INFO = -6 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.N ) THEN - INFO = -9 - ELSE IF( LDU.LT.N ) THEN - INFO = -11 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03QD', -INFO ) - RETURN - END IF -C - IF( NLOW.GT.1 ) THEN - IF( A(NLOW,NLOW-1).NE.ZERO ) INFO = 1 - END IF - IF( NSUP.LT.N ) THEN - IF( A(NSUP+1,NSUP).NE.ZERO ) INFO = 1 - END IF - IF( INFO.NE.0 ) - $ RETURN -C -C Initialize U with an identity matrix if necessary. -C - IF( LSAME( JOBU, 'I' ) ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) -C - NDIM = 0 - L = NSUP - NUP = NSUP -C -C NUP is the minimal value such that the submatrix A(i,j) with -C NUP+1 <= i,j <= NSUP contains no eigenvalues inside the domain of -C interest. L is such that all the eigenvalues of the submatrix -C A(i,j) with L+1 <= i,j <= NUP lie inside the domain of interest. -C -C WHILE( L >= NLOW ) DO -C - 10 IF( L.GE.NLOW ) THEN - IB = 1 - IF( L.GT.NLOW ) THEN - LM1 = L - 1 - IF( A(L,LM1).NE.ZERO ) THEN - CALL MB03QY( N, LM1, A, LDA, U, LDU, E1, E2, INFO ) - IF( A(L,LM1).NE.ZERO ) IB = 2 - END IF - END IF - IF( DISCR ) THEN - IF( IB.EQ.1 ) THEN - TLAMBD = ABS( A(L,L) ) - ELSE - TLAMBD = DLAPY2( E1, E2 ) - END IF - ELSE - IF( IB.EQ.1 ) THEN - TLAMBD = A(L,L) - ELSE - TLAMBD = E1 - END IF - END IF - IF( ( LSTDOM .AND. TLAMBD.LT.ALPHA ) .OR. - $ ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA ) ) THEN - NDIM = NDIM + IB - L = L - IB - ELSE - IF( NDIM.NE.0 ) THEN - CALL DTREXC( 'V', N, A, LDA, U, LDU, L, NUP, DWORK, - $ INFO ) - IF( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF - NUP = NUP - 1 - L = L - 1 - ELSE - NUP = NUP - IB - L = L - IB - END IF - END IF - GO TO 10 - END IF -C -C END WHILE 10 -C - RETURN -C *** Last line of MB03QD *** - END diff --git a/slycot/src/MB03QX.f b/slycot/src/MB03QX.f deleted file mode 100644 index 26474ba9..00000000 --- a/slycot/src/MB03QX.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of an upper quasi-triangular matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix T. N >= 0. -C -C T (input) DOUBLE PRECISION array, dimension(LDT,N) -C The upper quasi-triangular matrix T. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C The real and imaginary parts, respectively, of the -C eigenvalues of T. The eigenvalues are stored in the same -C order as on the diagonal of T. If T(i:i+1,i:i+1) is a -C 2-by-2 diagonal block with complex conjugated eigenvalues -C then WI(i) > 0 and WI(i+1) = -WI(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C March 1998. Based on the RASP routine SEIG. -C -C ****************************************************************** -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDT, N -C .. Array Arguments .. - DOUBLE PRECISION T(LDT, *), WI(*), WR(*) -C .. Local Scalars .. - INTEGER I, I1, INEXT - DOUBLE PRECISION A11, A12, A21, A22, CS, SN -C .. External Subroutines .. - EXTERNAL DLANV2, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -3 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03QX', -INFO ) - RETURN - END IF -C - INEXT = 1 - DO 10 I = 1, N - IF( I.LT.INEXT ) - $ GO TO 10 - IF( I.NE.N ) THEN - IF( T(I+1,I).NE.ZERO ) THEN -C -C A pair of eigenvalues. -C - INEXT = I + 2 - I1 = I + 1 - A11 = T(I,I) - A12 = T(I,I1) - A21 = T(I1,I) - A22 = T(I1,I1) - CALL DLANV2( A11, A12, A21, A22, WR(I), WI(I), WR(I1), - $ WI(I1), CS, SN ) - GO TO 10 - END IF - END IF -C -C Simple eigenvalue. -C - INEXT = I + 1 - WR(I) = T(I,I) - WI(I) = ZERO - 10 CONTINUE -C - RETURN -C *** Last line of MB03QX *** - END diff --git a/slycot/src/MB03QY.f b/slycot/src/MB03QY.f deleted file mode 100644 index bf3c8d1a..00000000 --- a/slycot/src/MB03QY.f +++ /dev/null @@ -1,164 +0,0 @@ - SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of a selected 2-by-2 diagonal block -C of an upper quasi-triangular matrix, to reduce the selected block -C to the standard form and to split the block in the case of real -C eigenvalues by constructing an orthogonal transformation UT. -C This transformation is applied to A (by similarity) and to -C another matrix U from the right. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and UT. N >= 2. -C -C L (input) INTEGER -C Specifies the position of the block. 1 <= L < N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A whose -C selected 2-by-2 diagonal block is to be processed. -C On exit, the leading N-by-N part of this array contains -C the upper quasi-triangular matrix A after its selected -C block has been splitt and/or put in the LAPACK standard -C form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C On entry, the leading N-by-N part of this array must -C contain a transformation matrix U. -C On exit, the leading N-by-N part of this array contains -C U*UT, where UT is the transformation matrix used to -C split and/or standardize the selected block. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= N. -C -C E1, E2 (output) DOUBLE PRECISION -C E1 and E2 contain either the real eigenvalues or the real -C and positive imaginary parts, respectively, of the complex -C eigenvalues of the selected 2-by-2 diagonal block of A. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let A1 = ( A(L,L) A(L,L+1) ) -C ( A(L+1,L) A(L+1,L+1) ) -C be the specified 2-by-2 diagonal block of matrix A. -C If the eigenvalues of A1 are complex, then they are computed and -C stored in E1 and E2, where the real part is stored in E1 and the -C positive imaginary part in E2. The 2-by-2 block is reduced if -C necessary to the standard form, such that A(L,L) = A(L+1,L+1), and -C A(L,L+1) and A(L+1,L) have oposite signs. If the eigenvalues are -C real, the 2-by-2 block is reduced to an upper triangular form such -C that ABS(A(L,L)) >= ABS(A(L+1,L+1)). -C In both cases, an orthogonal rotation U1' is constructed such that -C U1'*A1*U1 has the appropriate form. Let UT be an extension of U1 -C to an N-by-N orthogonal matrix, using identity submatrices. Then A -C is replaced by UT'*A*UT and the contents of array U is U * UT. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C March 1998. Based on the RASP routine SPLITB. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalues, orthogonal transformation, real Schur form, -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDU, N - DOUBLE PRECISION E1, E2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), U(LDU,*) -C .. Local Scalars .. - INTEGER L1 - DOUBLE PRECISION EW1, EW2, CS, SN -C .. External Subroutines .. - EXTERNAL DLANV2, DROT, XERBLA -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.2 ) THEN - INFO = -1 - ELSE IF( L.LT.1 .OR. L.GE.N ) THEN - INFO = -2 - ELSE IF( LDA.LT.N ) THEN - INFO = -4 - ELSE IF( LDU.LT.N ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03QY', -INFO ) - RETURN - END IF -C -C Compute the eigenvalues and the elements of the Givens -C transformation. -C - L1 = L + 1 - CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), E1, E2, - $ EW1, EW2, CS, SN ) - IF( E2.EQ.ZERO ) E2 = EW1 -C -C Apply the transformation to A. -C - IF( L1.LT.N ) - $ CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CS, SN ) - CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) -C -C Accumulate the transformation in U. -C - CALL DROT( N, U(1,L), 1, U(1,L1), 1, CS, SN ) -C - RETURN -C *** Last line of MB03QY *** - END diff --git a/slycot/src/MB03RD.f b/slycot/src/MB03RD.f deleted file mode 100644 index 9d3910d1..00000000 --- a/slycot/src/MB03RD.f +++ /dev/null @@ -1,613 +0,0 @@ - SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, - $ BLSIZE, WR, WI, TOL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a matrix A in real Schur form to a block-diagonal form -C using well-conditioned non-orthogonal similarity transformations. -C The condition numbers of the transformations used for reduction -C are roughly bounded by PMAX*PMAX, where PMAX is a given value. -C The transformations are optionally postmultiplied in a given -C matrix X. The real Schur form is optionally ordered, so that -C clustered eigenvalues are grouped in the same block. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBX CHARACTER*1 -C Specifies whether or not the transformations are -C accumulated, as follows: -C = 'N': The transformations are not accumulated; -C = 'U': The transformations are accumulated in X (the -C given matrix X is updated). -C -C SORT CHARACTER*1 -C Specifies whether or not the diagonal blocks of the real -C Schur form are reordered, as follows: -C = 'N': The diagonal blocks are not reordered; -C = 'S': The diagonal blocks are reordered before each -C step of reduction, so that clustered eigenvalues -C appear in the same block; -C = 'C': The diagonal blocks are not reordered, but the -C "closest-neighbour" strategy is used instead of -C the standard "closest to the mean" strategy -C (see METHOD); -C = 'B': The diagonal blocks are reordered before each -C step of reduction, and the "closest-neighbour" -C strategy is used (see METHOD). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C PMAX (input) DOUBLE PRECISION -C An upper bound for the infinity norm of elementary -C submatrices of the individual transformations used for -C reduction (see METHOD). PMAX >= 1.0D0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A to be block-diagonalized, in real -C Schur form. -C On exit, the leading N-by-N part of this array contains -C the computed block-diagonal matrix, in real Schur -C canonical form. The non-diagonal blocks are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if JOBX = 'U', the leading N-by-N part of this -C array must contain a given matrix X. -C On exit, if JOBX = 'U', the leading N-by-N part of this -C array contains the product of the given matrix X and the -C transformation matrix that reduced A to block-diagonal -C form. The transformation matrix is itself a product of -C non-orthogonal similarity transformations having elements -C with magnitude less than or equal to PMAX. -C If JOBX = 'N', this array is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. -C LDX >= 1, if JOBX = 'N'; -C LDX >= MAX(1,N), if JOBX = 'U'. -C -C NBLCKS (output) INTEGER -C The number of diagonal blocks of the matrix A. -C -C BLSIZE (output) INTEGER array, dimension (N) -C The first NBLCKS elements of this array contain the orders -C of the resulting diagonal blocks of the matrix A. -C -C WR, (output) DOUBLE PRECISION arrays, dimension (N) -C WI These arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the matrix A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in the ordering of the diagonal -C blocks of the real Schur form matrix. -C If the user sets TOL > 0, then the given value of TOL is -C used as an absolute tolerance: a block i and a temporarily -C fixed block 1 (the first block of the current trailing -C submatrix to be reduced) are considered to belong to the -C same cluster if their eigenvalues satisfy -C -C | lambda_1 - lambda_i | <= TOL. -C -C If the user sets TOL < 0, then the given value of TOL is -C used as a relative tolerance: a block i and a temporarily -C fixed block 1 are considered to belong to the same cluster -C if their eigenvalues satisfy, for j = 1, ..., N, -C -C | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. -C -C If the user sets TOL = 0, then an implicitly computed, -C default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) -C is used instead, as a relative tolerance, where EPS is -C the machine precision (see LAPACK Library routine DLAMCH). -C If SORT = 'N' or 'C', this parameter is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Consider first that SORT = 'N'. Let -C -C ( A A ) -C ( 11 12 ) -C A = ( ), -C ( 0 A ) -C ( 22 ) -C -C be the given matrix in real Schur form, where initially A is the -C 11 -C first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is -C made to compute a transformation matrix X of the form -C -C ( I P ) -C X = ( ) (1) -C ( 0 I ) -C -C (partitioned as A), so that -C -C ( A 0 ) -C -1 ( 11 ) -C X A X = ( ), -C ( 0 A ) -C ( 22 ) -C -C and the elements of P do not exceed the value PMAX in magnitude. -C An adaptation of the standard method for solving Sylvester -C equations [1], which controls the magnitude of the individual -C elements of the computed solution [2], is used to obtain matrix P. -C When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of -C A , whose eigenvalue(s) is (are) the closest to the mean of those -C 22 -C of A is selected, and moved by orthogonal similarity -C 11 -C transformations in the leading position of A ; the moved diagonal -C 22 -C block is then added to the block A , increasing its order by 1 -C 11 -C (or 2). Another attempt is made to compute a suitable -C transformation matrix X with the new definitions of the blocks A -C 11 -C and A . After a successful transformation matrix X has been -C 22 -C obtained, it postmultiplies the current transformation matrix -C (if JOBX = 'U'), and the whole procedure is repeated for the -C matrix A . -C 22 -C -C When SORT = 'S', the diagonal blocks of the real Schur form are -C reordered before each step of the reduction, so that each cluster -C of eigenvalues, defined as specified in the definition of TOL, -C appears in adjacent blocks. The blocks for each cluster are merged -C together, and the procedure described above is applied to the -C larger blocks. Using the option SORT = 'S' will usually provide -C better efficiency than the standard option (SORT = 'N'), proposed -C in [2], because there could be no or few unsuccessful attempts -C to compute individual transformation matrices X of the form (1). -C However, the resulting dimensions of the blocks are usually -C larger; this could make subsequent calculations less efficient. -C -C When SORT = 'C' or 'B', the procedure is similar to that for -C SORT = 'N' or 'S', respectively, but the block of A whose -C 22 -C eigenvalue(s) is (are) the closest to those of A (not to their -C 11 -C mean) is selected and moved to the leading position of A . This -C 22 -C is called the "closest-neighbour" strategy. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Bavely, C. and Stewart, G.W. -C An Algorithm for Computing Reducing Subspaces by Block -C Diagonalization. -C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. -C -C [3] Demmel, J. -C The Condition Number of Equivalence Transformations that -C Block Diagonalize Matrix Pencils. -C SIAM J. Numer. Anal., 20, pp. 599-610, 1983. -C -C NUMERICAL ASPECTS -C 3 4 -C The algorithm usually requires 0(N ) operations, but 0(N ) are -C possible in the worst case, when all diagonal blocks in the real -C Schur form of A are 1-by-1, and the matrix cannot be diagonalized -C by well-conditioned transformations. -C -C FURTHER COMMENTS -C -C The individual non-orthogonal transformation matrices used in the -C reduction of A to a block-diagonal form have condition numbers -C of the order PMAX*PMAX. This does not guarantee that their product -C is well-conditioned enough. The routine can be easily modified to -C provide estimates for the condition numbers of the clusters of -C eigenvalues. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Partly based on the RASP routine BDIAG by A. Varga, German -C Aerospace Center, DLR Oberpfaffenhofen. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. -C -C KEYWORDS -C -C Diagonalization, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBX, SORT - INTEGER INFO, LDA, LDX, N, NBLCKS - DOUBLE PRECISION PMAX, TOL -C .. Array Arguments .. - INTEGER BLSIZE(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LJOBX, LSORN, LSORS, LSORT - CHARACTER JOBV - INTEGER DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1 - DOUBLE PRECISION C, CAV, D, EDIF, EMAX, RAV, SAFEMN, SC, THRESH -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLABAD, DLASET, DSCAL, MA02AD, MB03QX, - $ MB03RX, MB03RY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LJOBX = LSAME( JOBX, 'U' ) - LSORN = LSAME( SORT, 'N' ) - LSORS = LSAME( SORT, 'S' ) - LSORT = LSAME( SORT, 'B' ) .OR. LSORS - IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND. - $ .NOT.LSAME( SORT, 'C' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( PMAX.LT.ONE ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NBLCKS = 0 - IF( N.EQ.0 ) - $ RETURN -C -C Set the "safe" minimum positive number with representable -C reciprocal, and set JOBV parameter for MB03RX routine. -C - SAFEMN = DLAMCH( 'Safe minimum' ) - SC = ONE / SAFEMN - CALL DLABAD( SAFEMN, SC ) - SAFEMN = SAFEMN / DLAMCH( 'Precision' ) - JOBV = JOBX - IF ( LJOBX ) - $ JOBV = 'V' -C -C Compute the eigenvalues of A and set the tolerance for reordering -C the eigenvalues in clusters, if needed. -C - CALL MB03QX( N, A, LDA, WR, WI, INFO ) -C - IF ( LSORT ) THEN - THRESH = ABS( TOL ) - IF ( THRESH.EQ.ZERO ) THEN -C -C Use the default tolerance in ordering the blocks. -C - THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) ) - END IF -C - IF ( TOL.LE.ZERO ) THEN -C -C Use a relative tolerance. Find max | lambda_j |, j = 1 : N. -C - EMAX = ZERO - L = 1 -C WHILE ( L.LE.N ) DO - 10 IF ( L.LE.N ) THEN - IF ( WI(L).EQ.ZERO ) THEN - EMAX = MAX( EMAX, ABS( WR(L) ) ) - L = L + 1 - ELSE - EMAX = MAX( EMAX, DLAPY2( WR(L), WI(L) ) ) - L = L + 2 - END IF - GO TO 10 - END IF -C END WHILE 10 - THRESH = THRESH * EMAX - END IF - END IF -C -C Define the following submatrices of A: -C A11, the DA11-by-DA11 block in position (L11,L11); -C A22, the DA22-by-DA22 block in position (L22,L22); -C A12, the DA11-by-DA22 block in position (L11,L22); -C A21, the DA22-by-DA11 block in position (L22,L11) (null initially -C and finally). -C The following loop uses L11 as loop variable and try to separate a -C block in position (L11,L11), with possibly clustered eigenvalues, -C separated by the other eigenvalues (in the block A22). -C - L11 = 1 -C WHILE ( L11.LE.N ) DO - 20 IF ( L11.LE.N ) THEN - NBLCKS = NBLCKS + 1 - IF ( WI(L11).EQ.ZERO ) THEN - DA11 = 1 - ELSE - DA11 = 2 - END IF -C - IF ( LSORT ) THEN -C -C The following loop, using K as loop variable, finds the -C blocks whose eigenvalues are close to those of A11 and -C moves these blocks (if any) to the leading position of A22. -C - L22 = L11 + DA11 - K = L22 -C WHILE ( K.LE.N ) DO - 30 IF ( K.LE.N ) THEN - EDIF = DLAPY2( WR(L11) - WR(K), WI(L11) - WI(K) ) - IF ( EDIF.LE.THRESH ) THEN -C -C An 1x1 or a 2x2 block of A22 has been found so that -C -C abs( lambda_1 - lambda_k ) <= THRESH -C -C where lambda_1 and lambda_k denote an eigenvalue -C of A11 and of that block in A22, respectively. -C Try to move that block to the leading position of A22. -C - CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, - $ DWORK ) -C -C Extend A11 with the leading block of A22. -C - IF ( WI(L22).EQ.ZERO ) THEN - DA11 = DA11 + 1 - ELSE - DA11 = DA11 + 2 - END IF - L22 = L11 + DA11 - END IF - IF ( WI(K).EQ.ZERO ) THEN - K = K + 1 - ELSE - K = K + 2 - END IF - GO TO 30 - END IF -C END WHILE 30 - END IF -C -C The following loop uses L22 as loop variable and forms a -C separable DA11-by-DA11 block A11 in position (L11,L11). -C - L22 = L11 + DA11 - L22M1 = L22 - 1 -C WHILE ( L22.LE.N ) DO - 40 IF ( L22.LE.N ) THEN - DA22 = N - L22M1 -C -C Try to separate the block A11 of order DA11 by using a -C well-conditioned similarity transformation. -C -C First save A12' in the block A21. -C - CALL MA02AD( 'Full', DA11, DA22, A(L11,L22), LDA, - $ A(L22,L11), LDA ) -C -C Solve -A11*P + P*A22 = A12. -C - CALL MB03RY( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22), - $ LDA, A(L11,L22), LDA, IERR ) -C - IF ( IERR.EQ.1 ) THEN -C -C The annihilation of A12 failed. Restore A12 and A21. -C - CALL MA02AD( 'Full', DA22, DA11, A(L22,L11), LDA, - $ A(L11,L22), LDA ) - CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), - $ LDA ) -C - IF ( LSORN .OR. LSORS ) THEN -C -C Extend A11 with an 1x1 or 2x2 block of A22 having the -C nearest eigenvalues to the mean of eigenvalues of A11 -C and resume the loop. -C First compute the mean of eigenvalues of A11. -C - RAV = ZERO - CAV = ZERO -C - DO 50 I = L11, L22M1 - RAV = RAV + WR(I) - CAV = CAV + ABS( WI(I) ) - 50 CONTINUE -C - RAV = RAV/DA11 - CAV = CAV/DA11 -C -C Loop to find the eigenvalue of A22 nearest to the -C above computed mean. -C - D = DLAPY2( RAV-WR(L22), CAV-WI(L22) ) - K = L22 - IF ( WI(L22).EQ.ZERO ) THEN - L = L22 + 1 - ELSE - L = L22 + 2 - END IF -C WHILE ( L.LE.N ) DO - 60 IF ( L.LE.N ) THEN - C = DLAPY2( RAV-WR(L), CAV-WI(L) ) - IF ( C.LT.D ) THEN - D = C - K = L - END IF - IF ( WI(L).EQ.ZERO ) THEN - L = L + 1 - ELSE - L = L + 2 - END IF - GO TO 60 - END IF -C END WHILE 60 -C - ELSE -C -C Extend A11 with an 1x1 or 2x2 block of A22 having the -C nearest eigenvalues to the cluster of eigenvalues of -C A11 and resume the loop. -C -C Loop to find the eigenvalue of A22 of minimum distance -C to the cluster. -C - D = SC - L = L22 - K = L22 -C WHILE ( L.LE.N ) DO - 70 IF ( L.LE.N ) THEN - I = L11 -C WHILE ( I.LE.L22M1 ) DO - 80 IF ( I.LE.L22M1 ) THEN - C = DLAPY2( WR(I)-WR(L), WI(I)-WI(L) ) - IF ( C.LT.D ) THEN - D = C - K = L - END IF - IF ( WI(I).EQ.ZERO ) THEN - I = I + 1 - ELSE - I = I + 2 - END IF - GO TO 80 - END IF -C END WHILE 80 - IF ( WI(L).EQ.ZERO ) THEN - L = L + 1 - ELSE - L = L + 2 - END IF - GO TO 70 - END IF -C END WHILE 70 - END IF -C -C Try to move block found to the leading position of A22. -C - CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, - $ DWORK ) -C -C Extend A11 with the leading block of A22. -C - IF ( WI(L22).EQ.ZERO ) THEN - DA11 = DA11 + 1 - ELSE - DA11 = DA11 + 2 - END IF - L22 = L11 + DA11 - L22M1 = L22 - 1 - GO TO 40 - END IF - END IF -C END WHILE 40 -C - IF ( LJOBX ) THEN -C -C Accumulate the transformation in X. -C Only columns L22, ..., N are modified. -C - IF ( L22.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, DA22, - $ DA11, ONE, X(1,L11), LDX, A(L11,L22), LDA, - $ ONE, X(1,L22), LDX ) -C -C Scale to unity the (non-zero) columns of X which will be -C no more modified and transform A11 accordingly. -C - DO 90 J = L11, L22M1 - SC = DNRM2( N, X(1,J), 1 ) - IF ( SC.GT.SAFEMN ) THEN - CALL DSCAL( DA11, SC, A(J,L11), LDA ) - SC = ONE/SC - CALL DSCAL( N, SC, X(1,J), 1 ) - CALL DSCAL( DA11, SC, A(L11,J), 1 ) - END IF - 90 CONTINUE -C - END IF - IF ( L22.LE.N ) THEN -C -C Set A12 and A21 to zero. -C - CALL DLASET( 'Full', DA11, DA22, ZERO, ZERO, A(L11,L22), - $ LDA ) - CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), - $ LDA ) - END IF -C -C Store the orders of the diagonal blocks in BLSIZE. -C - BLSIZE(NBLCKS) = DA11 - L11 = L22 - GO TO 20 - END IF -C END WHILE 20 -C - RETURN -C *** Last line of MB03RD *** - END diff --git a/slycot/src/MB03RX.f b/slycot/src/MB03RX.f deleted file mode 100644 index d7c582db..00000000 --- a/slycot/src/MB03RX.f +++ /dev/null @@ -1,226 +0,0 @@ - SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI, - $ DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reorder the diagonal blocks of the principal submatrix between -C the indices KL and KU (KU >= KL) of a real Schur form matrix A -C together with their eigenvalues, using orthogonal similarity -C transformations, such that the block specified by KU is moved in -C the position KL. The transformations are optionally postmultiplied -C in a given matrix X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBV CHARACTER*1 -C Specifies whether or not the transformations are -C accumulated, as follows: -C = 'N': The transformations are not accumulated; -C = 'V': The transformations are accumulated in X (the -C given matrix X is updated). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C KL (input) INTEGER -C The lower boundary index for the rows and columns of the -C principal submatrix of A whose diagonal blocks are to be -C reordered, and also the target position for the block to -C be moved. 1 <= KL <= KU <= N. -C -C KU (input/output) INTEGER -C On entry, KU specifies the upper boundary index for the -C rows and columns of the principal submatrix of A whose -C diagonal blocks are to be reordered, and also the original -C position for the block to be moved. 1 <= KL <= KU <= N. -C On exit, KU specifies the upper boundary index for the -C rows and columns of the principal submatrix of A whose -C diagonal blocks have been reordered. The given value will -C be increased by 1 if the moved block was 2-by-2 and it has -C been replaced by two 1-by-1 blocks. Otherwise, its input -C value is preserved. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A in real Schur canonical form. -C On exit, the leading N-by-N part of this array contains -C the ordered real Schur canonical form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if JOBV = 'V', the leading N-by-N part of this -C array must contain a given matrix X. -C On exit, if JOBV = 'V', the leading N-by-N part of this -C array contains the product of the given matrix X and the -C transformation matrix that performed the reordering of A. -C If JOBV = 'N', this array is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. -C LDX >= 1, if JOBV = 'N'; -C LDX >= MAX(1,N), if JOBV = 'V'. -C -C WR, (input/output) DOUBLE PRECISION arrays, dimension (N) -C WI On entry, these arrays must contain the real and imaginary -C parts, respectively, of the eigenvalues of the matrix A. -C On exit, these arrays contain the real and imaginary -C parts, respectively, of the eigenvalues of the matrix A, -C possibly reordered. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C METHOD -C -C An attempt is made to move the block in the position (KU,KU) to -C the position (KL,KL) by a sequence of orthogonal similarity -C transformations, each swapping two consecutive blocks. The -C standard algorithm [1], [2] usually succeeds to perform this -C reordering. A failure of this algorithm means that two consecutive -C blocks (one of them being the desired block possibly moved) are -C too close to swap. In such a case, the leading block of the two -C is tried to be moved in the position (KL,KL) and the procedure is -C repeated. -C -C REFERENCES -C -C [1] Stewart, G.W. -C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and -C ordering the eigenvalues of a real upper Hessenberg matrix. -C ACM TOMS, 2, pp. 275-280, 1976. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. If some eigenvalues are -C ill-conditioned, their returned values could differ much from -C their input values. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBV - INTEGER KL, KU, LDA, LDX, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) -C .. Local Scalars .. - INTEGER IERR, IFST, ILST, L -C .. External Subroutines .. - EXTERNAL DTREXC -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C - IF ( KU.GT.KL ) THEN -C -C Try to move the block in position (KU,KU) to position (KL,KL). -C - IFST = KU -C REPEAT - 10 CONTINUE - ILST = KL - CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN -C -C During calculations, two adjacent blocks were too close -C to swap; the desired block cannot be moved further, but the -C block above it is suitable and is tried for moving. The -C number of repeat cycles is usually 1, and at most the number -C of blocks between the current position and the position KL. -C - IFST = ILST - 1 - IF ( IFST.GT.1 ) THEN - IF ( A(IFST,IFST-1).NE.ZERO ) - $ IFST = ILST - 2 - END IF - IF ( ILST.GT.KL ) - $ GO TO 10 - END IF -C UNTIL ( ILST.EQ.KL on output from DTREXC ) -C -C Recompute the eigenvalues for the modified part of A. -C Note that KU must be incremented if the moved block was 2-by-2 -C and it has been replaced by two 1-by-1 blocks. -C - IF ( WI(KU).NE.ZERO ) THEN - IF ( A(KU+1,KU).EQ.ZERO ) - $ KU = KU + 1 - END IF -C - L = KL -C WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO - 20 IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN - IF ( A(L+1,L).NE.ZERO ) THEN -C -C A 2x2 block. -C - WR(L) = A(L,L) - WR(L+1) = WR(L) - WI(L) = SQRT( ABS( A(L,L+1) ) )* - $ SQRT( ABS( A(L+1,L) ) ) - WI(L+1) = -WI(L) - L = L + 2 - ELSE -C -C An 1x1 block. -C - WR(L) = A(L,L) - WI(L) = ZERO - L = L + 1 - END IF - GO TO 20 - ELSE IF ( L.EQ.N ) THEN - WR(L) = A(L,L) - WI(L) = ZERO - END IF -C END WHILE 20 - END IF -C - RETURN -C *** Last line of MB03RX *** - END diff --git a/slycot/src/MB03RY.f b/slycot/src/MB03RY.f deleted file mode 100644 index 55008313..00000000 --- a/slycot/src/MB03RY.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the Sylvester equation -AX + XB = C, where A and B are -C M-by-M and N-by-N matrices, respectively, in real Schur form. -C -C This routine is intended to be called only by SLICOT Library -C routine MB03RD. For efficiency purposes, the computations are -C aborted when the infinity norm of an elementary submatrix of X is -C greater than a given value PMAX. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A and the number of rows of the -C matrices C and X. M >= 0. -C -C N (input) INTEGER -C The order of the matrix B and the number of columns of the -C matrices C and X. N >= 0. -C -C PMAX (input) DOUBLE PRECISION -C An upper bound for the infinity norm of an elementary -C submatrix of X (see METHOD). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain the -C matrix A of the Sylvester equation, in real Schur form. -C The elements below the real Schur form are not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain the -C matrix B of the Sylvester equation, in real Schur form. -C The elements below the real Schur form are not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix C of the Sylvester equation. -C On exit, if INFO = 0, the leading M-by-N part of this -C array contains the solution matrix X of the Sylvester -C equation, and each elementary submatrix of X (see METHOD) -C has the infinity norm less than or equal to PMAX. -C On exit, if INFO = 1, the solution matrix X has not been -C computed completely, because an elementary submatrix of X -C had the infinity norm greater than PMAX. Part of the -C matrix C has possibly been overwritten with the -C corresponding part of X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: an elementary submatrix of X had the infinity norm -C greater than the given value PMAX. -C -C METHOD -C -C The routine uses an adaptation of the standard method for solving -C Sylvester equations [1], which controls the magnitude of the -C individual elements of the computed solution [2]. The equation -C -AX + XB = C can be rewritten as -C p l-1 -C -A X + X B = C + sum A X - sum X B -C kk kl kl ll kl i=k+1 ki il j=1 kj jl -C -C for l = 1:q, and k = p:-1:1, where A , B , C , and X , are -C kk ll kl kl -C block submatrices defined by the partitioning induced by the Schur -C form of A and B, and p and q are the numbers of the diagonal -C blocks of A and B, respectively. So, the elementary submatrices of -C X are found block column by block column, starting from the -C bottom. If any such elementary submatrix has the infinity norm -C greater than the given value PMAX, the calculations are ended. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Bavely, C. and Stewart, G.W. -C An Algorithm for Computing Reducing Subspaces by Block -C Diagonalization. -C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires 0(M N + MN ) operations. -C -C FURTHER COMMENTS -C -C Let -C -C ( A C ) ( I X ) -C M = ( ), Y = ( ). -C ( 0 B ) ( 0 I ) -C -C Then -C -C -1 ( A 0 ) -C Y M Y = ( ), -C ( 0 B ) -C -C hence Y is an non-orthogonal transformation matrix which performs -C the reduction of M to a block-diagonal form. Bounding a norm of -C X is equivalent to setting an upper bound to the condition number -C of the transformation matrix Y. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on the RASP routine SYLSM by A. Varga, German Aerospace -C Center, DLR Oberpfaffenhofen. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Diagonalization, real Schur form, Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, M, N - DOUBLE PRECISION PMAX -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) -C .. Local Scalars .. - INTEGER DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1 - DOUBLE PRECISION PNORM, SCALE -C .. Local Arrays .. - DOUBLE PRECISION P(4) -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DLASY2 -C .. Executable Statements .. -C -C For efficiency reasons, this routine does not check the input -C parameters for errors. -C - INFO = 0 -C -C Column loop indexed by L. -C - L = 1 -C WHILE ( L.LE.N ) DO - 10 IF ( L.LE.N ) THEN - LM1 = L - 1 - DL = 1 - IF ( L.LT.N ) THEN - IF ( B(L+1,L).NE.ZERO ) - $ DL = 2 - ENDIF - LL = LM1 + DL - IF ( LM1.GT.0 ) THEN -C -C Update one (or two) column(s) of C. -C - IF ( DL.EQ.2 ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1, - $ -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC ) - ELSE - CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L), - $ 1, ONE, C(1,L), 1 ) - END IF - ENDIF -C -C Row loop indexed by KK. -C - KK = M -C WHILE ( KK.GE.1 ) DO - 20 IF ( KK.GE.1 ) THEN - KK1 = KK + 1 - DK = 1 - IF ( KK.GT.1 ) THEN - IF ( A(KK,KK-1).NE.ZERO ) - $ DK = 2 - ENDIF - K = KK1 - DK - IF ( K.LT.M ) THEN -C -C Update an elementary submatrix of C. -C - DO 40 J = L, LL -C - DO 30 I = K, KK - C(I,J) = C(I,J) + - $ DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 ) - 30 CONTINUE -C - 40 CONTINUE -C - ENDIF - CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA, - $ B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM, - $ IERR ) - IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN - INFO = 1 - RETURN - END IF - C(K,L) = -P(1) - IF ( DL.EQ.1 ) THEN - IF ( DK.EQ.2 ) - $ C(KK,L) = -P(2) - ELSE - IF ( DK.EQ.1 ) THEN - C(K,LL) = -P(2) - ELSE - C(KK,L) = -P(2) - C(K,LL) = -P(3) - C(KK,LL) = -P(4) - ENDIF - ENDIF - KK = KK - DK - GO TO 20 - END IF -C END WHILE 20 - L = L + DL - GO TO 10 - END IF -C END WHILE 10 - RETURN -C *** Last line of MB03RY *** - END diff --git a/slycot/src/MB03SD.f b/slycot/src/MB03SD.f deleted file mode 100644 index 679396e7..00000000 --- a/slycot/src/MB03SD.f +++ /dev/null @@ -1,348 +0,0 @@ - SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of an N-by-N square-reduced Hamiltonian -C matrix -C -C ( A' G' ) -C H' = ( T ). (1) -C ( Q' -A' ) -C -C Here, A' is an N-by-N matrix, and G' and Q' are symmetric N-by-N -C matrices. It is assumed without a check that H' is square- -C reduced, i.e., that -C -C 2 ( A'' G'' ) -C H' = ( T ) with A'' upper Hessenberg. (2) -C ( 0 A'' ) -C -C T 2 -C (Equivalently, Q'A'- A' Q' = 0, A'' = A' + G'Q', and for i > j+1, -C A''(i,j) = 0.) Ordinarily, H' is the output from SLICOT Library -C routine MB04ZD. The eigenvalues of H' are computed as the square -C roots of the eigenvalues of A''. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBSCL CHARACTER*1 -C Specifies whether or not balancing operations should -C be performed by the LAPACK subroutine DGEBAL on the -C Hessenberg matrix A'' in (2), as follows: -C = 'N': do not use balancing; -C = 'S': do scaling in order to equilibrate the rows -C and columns of A''. -C See LAPACK subroutine DGEBAL and Section METHOD below. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper left block A' of the square-reduced Hamiltonian -C matrix H' in (1), as produced by SLICOT Library routine -C MB04ZD. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) -C The leading N-by-N lower triangular part of this array -C must contain the lower triangle of the lower left -C symmetric block Q' of the square-reduced Hamiltonian -C matrix H' in (1), and the N-by-N upper triangular part of -C the submatrix in the columns 2 to N+1 of this array must -C contain the upper triangle of the upper right symmetric -C block G' of the square-reduced Hamiltonian matrix H' -C in (1), as produced by SLICOT Library routine MB04ZD. -C So, if i >= j, then Q'(i,j) is stored in QG(i,j) and -C G'(i,j) is stored in QG(j,i+1). -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C The arrays WR and WI contain the real and imaginary parts, -C respectively, of the N eigenvalues of H' with non-negative -C real part. The remaining N eigenvalues are the negatives -C of these eigenvalues. -C Eigenvalues are stored in WR and WI in decreasing order of -C magnitude of the real parts, i.e., WR(I) >= WR(I+1). -C (In particular, an eigenvalue closest to the imaginary -C axis is WR(N)+WI(N)i.) -C In addition, eigenvalues with zero real part are sorted in -C decreasing order of magnitude of imaginary parts. Note -C that non-real eigenvalues with non-zero real part appear -C in complex conjugate pairs, but eigenvalues with zero real -C part do not, in general, appear in complex conjugate -C pairs. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1,N*(N+1)). -C For good performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, then the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, then LAPACK subroutine DHSEQR -C failed to converge while computing the i-th -C eigenvalue. -C -C METHOD -C -C The routine forms the upper Hessenberg matrix A'' in (2) and calls -C LAPACK subroutines to calculate its eigenvalues. The eigenvalues -C of H' are the square roots of the eigenvalues of A''. -C -C REFERENCES -C -C [1] Van Loan, C. F. -C A Symplectic Method for Approximating All the Eigenvalues of -C a Hamiltonian Matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] Byers, R. -C Hamiltonian and Symplectic Algorithms for the Algebraic -C Riccati Equation. -C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. -C -C [3] Benner, P., Byers, R., and Barth, E. -C Fortran 77 Subroutines for Computing the Eigenvalues of -C Hamiltonian Matrices. I: The Square-Reduced Method. -C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. -C -C NUMERICAL ASPECTS -C -C The algorithm requires (32/3)*N**3 + O(N**2) floating point -C operations. -C Eigenvalues computed by this subroutine are exact eigenvalues -C of a perturbed Hamiltonian matrix H' + E where -C -C || E || <= c sqrt(eps) || H' ||, -C -C c is a modest constant depending on the dimension N and eps is the -C machine precision. Moreover, if the norm of H' and an eigenvalue -C are of roughly the same magnitude, the computed eigenvalue is -C essentially as accurate as the computed eigenvalue obtained by -C traditional methods. See [1] or [2]. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, and -C R. Byers, University of Kansas, Lawrence, USA. -C Aug. 1998, routine DHAEVS. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2002, -C May 2009. -C -C KEYWORDS -C -C Eigenvalues, (square-reduced) Hamiltonian matrix, symplectic -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDQG, LDWORK, N - CHARACTER JOBSCL -C .. -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), WI(*), WR(*) -C .. -C .. Local Scalars .. - DOUBLE PRECISION SWAP, X, Y - INTEGER BL, CHUNK, I, IGNORE, IHI, ILO, J, JW, JWORK, M, - $ N2 - LOGICAL BLAS3, BLOCK, SCALE, SORTED -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DLASET, - $ DSYMM, DSYMV, MA01AD, MA02ED, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - N2 = N*N - SCALE = LSAME( JOBSCL, 'S' ) - IF ( .NOT. ( SCALE .OR. LSAME( JOBSCL, 'N' ) ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDWORK.LT.MAX( 1, N2 + N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - CHUNK = ( LDWORK - N2 ) / N - BLOCK = MIN( CHUNK, N ).GT.1 - BLAS3 = CHUNK.GE.N -C - IF ( BLAS3 ) THEN - JWORK = N2 + 1 - ELSE - JWORK = 1 - END IF -C 2 -C Form the matrix A'' = A' + G'Q'. -C - CALL DLACPY( 'Lower', N, N, QG, LDQG, DWORK(JWORK), N ) - CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) -C - IF ( BLAS3 ) THEN -C -C Use BLAS 3 calculation. -C - CALL DSYMM( 'Left', 'Upper', N, N, ONE, QG(1, 2), LDQG, - $ DWORK(JWORK), N, ZERO, DWORK, N ) -C - ELSE IF ( BLOCK ) THEN - JW = N2 + 1 -C -C Use BLAS 3 for as many columns of Q' as possible. -C - DO 10 J = 1, N, CHUNK - BL = MIN( N-J+1, CHUNK ) - CALL DSYMM( 'Left', 'Upper', N, BL, ONE, QG(1, 2), LDQG, - $ DWORK(1+N*(J-1)), N, ZERO, DWORK(JW), N ) - CALL DLACPY( 'Full', N, BL, DWORK(JW), N, DWORK(1+N*(J-1)), - $ N ) - 10 CONTINUE -C - ELSE -C -C Use BLAS 2 calculation. -C - DO 20 J = 1, N - CALL DSYMV( 'Upper', N, ONE, QG(1, 2), LDQG, - $ DWORK(1+N*(J-1)), 1, ZERO, WR, 1 ) - CALL DCOPY( N, WR, 1, DWORK(1+N*(J-1)), 1 ) - 20 CONTINUE -C - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, A, LDA, A, - $ LDA, ONE, DWORK, N ) - IF ( SCALE .AND. N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK(3), N ) -C 2 -C Find the eigenvalues of A' + G'Q'. -C - CALL DGEBAL( JOBSCL, N, DWORK, N, ILO, IHI, DWORK(1+N2), IGNORE ) - CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, DWORK, - $ N, WR, WI, DUMMY, 1, DWORK(1+N2), N, INFO ) - IF ( INFO.EQ.0 ) THEN -C -C Eigenvalues of H' are the square roots of those computed above. -C - DO 30 I = 1, N - X = WR(I) - Y = WI(I) - CALL MA01AD( X, Y, WR(I), WI(I) ) - 30 CONTINUE -C -C Sort eigenvalues into decreasing order by real part and, for -C eigenvalues with zero real part only, decreasing order of -C imaginary part. (This simple bubble sort preserves the -C relative order of eigenvalues with equal but nonzero real part. -C This ensures that complex conjugate pairs remain -C together.) -C - SORTED = .FALSE. -C - DO 50 M = N, 1, -1 - IF ( SORTED ) GO TO 60 - SORTED = .TRUE. -C - DO 40 I = 1, M - 1 - IF ( ( ( WR(I).LT.WR(I+1) ) .OR. - $ ( ( WR(I).EQ.ZERO ) .AND. ( WR(I+1).EQ.ZERO ) .AND. - $ ( WI(I).LT.WI(I+1) ) ) ) ) THEN - SWAP = WR(I) - WR(I) = WR(I+1) - WR(I+1) = SWAP - SWAP = WI(I) - WI(I) = WI(I+1) - WI(I+1) = SWAP -C - SORTED = .FALSE. -C - END IF - 40 CONTINUE -C - 50 CONTINUE -C - 60 CONTINUE -C - END IF -C - DWORK(1) = 2*N2 - RETURN -C *** Last line of MB03SD *** - END diff --git a/slycot/src/MB03TD.f b/slycot/src/MB03TD.f deleted file mode 100644 index 05561446..00000000 --- a/slycot/src/MB03TD.f +++ /dev/null @@ -1,641 +0,0 @@ - SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reorder a matrix X in skew-Hamiltonian Schur form: -C -C [ A G ] T -C X = [ T ], G = -G, -C [ 0 A ] -C -C or in Hamiltonian Schur form: -C -C [ A G ] T -C X = [ T ], G = G, -C [ 0 -A ] -C -C where A is in upper quasi-triangular form, so that a selected -C cluster of eigenvalues appears in the leading diagonal blocks -C of the matrix A (in X) and the leading columns of [ U1; -U2 ] form -C an orthonormal basis for the corresponding right invariant -C subspace. -C -C If X is skew-Hamiltonian, then each eigenvalue appears twice; one -C copy corresponds to the j-th diagonal element and the other to the -C (n+j)-th diagonal element of X. The logical array LOWER controls -C which copy is to be reordered to the leading part of A. -C -C If X is Hamiltonian then the eigenvalues appear in pairs -C (lambda,-lambda); lambda corresponds to the j-th diagonal -C element and -lambda to the (n+j)-th diagonal element of X. -C The logical array LOWER controls whether lambda or -lambda is to -C be reordered to the leading part of A. -C -C The matrix A must be in Schur canonical form (as returned by the -C LAPACK routine DHSEQR), that is, block upper triangular with -C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has -C its diagonal elements equal and its off-diagonal elements of -C opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYP CHARACTER*1 -C Specifies the type of the input matrix X: -C = 'S': X is skew-Hamiltonian; -C = 'H': X is Hamiltonian. -C -C COMPU CHARACTER*1 -C = 'U': update the matrices U1 and U2 containing the -C Schur vectors; -C = 'N': do not update U1 and U2. -C -C SELECT (input/output) LOGICAL array, dimension (N) -C SELECT specifies the eigenvalues in the selected cluster. -C To select a real eigenvalue w(j), SELECT(j) must be set -C to .TRUE.. To select a complex conjugate pair of -C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 -C diagonal block, both SELECT(j) and SELECT(j+1) must be set -C to .TRUE.; a complex conjugate pair of eigenvalues must be -C either both included in the cluster or both excluded. -C -C LOWER (input/output) LOGICAL array, dimension (N) -C LOWER controls which copy of a selected eigenvalue is -C included in the cluster. If SELECT(j) is set to .TRUE. -C for a real eigenvalue w(j); then LOWER(j) must be set to -C .TRUE. if the eigenvalue corresponding to the (n+j)-th -C diagonal element of X is to be reordered to the leading -C part; and LOWER(j) must be set to .FALSE. if the -C eigenvalue corresponding to the j-th diagonal element of -C X is to be reordered to the leading part. Similarly, for -C a complex conjugate pair of eigenvalues w(j) and w(j+1), -C both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the -C eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1) -C diagonal block of X are to be reordered to the leading -C part. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A in Schur -C canonical form. -C On exit, the leading N-by-N part of this array contains -C the reordered matrix A, again in Schur canonical form, -C with the selected eigenvalues in the diagonal blocks. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, if TYP = 'S', the leading N-by-N part of this -C array must contain the strictly upper triangular part of -C the skew-symmetric matrix G. The rest of this array is not -C referenced. -C On entry, if TYP = 'H', the leading N-by-N part of this -C array must contain the upper triangular part of the -C symmetric matrix G. The rest of this array is not -C referenced. -C On exit, if TYP = 'S', the leading N-by-N part of this -C array contains the strictly upper triangular part of the -C skew-symmetric matrix G, updated by the orthogonal -C symplectic transformation which reorders X. -C On exit, if TYP = 'H', the leading N-by-N part of this -C array contains the upper triangular part of the symmetric -C matrix G, updated by the orthogonal symplectic -C transformation which reorders X. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, if COMPU = 'U', the leading N-by-N part of this -C array must contain U1, the (1,1) block of an orthogonal -C symplectic matrix U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U', the leading N-by-N part of this -C array contains the (1,1) block of the matrix U, -C postmultiplied by the orthogonal symplectic transformation -C which reorders X. The leading M columns of U form an -C orthonormal basis for the specified invariant subspace. -C If COMPU = 'N', this array is not referenced. -C -C LDU1 INTEGER -C The leading dimension of the array U1. -C LDU1 >= MAX(1,N), if COMPU = 'U'; -C LDU1 >= 1, otherwise. -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, if COMPU = 'U', the leading N-by-N part of this -C array must contain U2, the (1,2) block of an orthogonal -C symplectic matrix U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U', the leading N-by-N part of this -C array contains the (1,2) block of the matrix U, -C postmultiplied by the orthogonal symplectic transformation -C which reorders X. -C If COMPU = 'N', this array is not referenced. -C -C LDU2 INTEGER -C The leading dimension of the array U2. -C LDU2 >= MAX(1,N), if COMPU = 'U'; -C LDU2 >= 1, otherwise. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C The real and imaginary parts, respectively, of the -C reordered eigenvalues of A. The eigenvalues are stored -C in the same order as on the diagonal of A, with -C WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal -C block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an -C eigenvalue is sufficiently ill-conditioned, then its value -C may differ significantly from its value before reordering. -C -C M (output) INTEGER -C The dimension of the specified invariant subspace. -C 0 <= M <= N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -18, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C = 1: reordering of X failed because some eigenvalue pairs -C are too close to separate (the problem is very -C ill-conditioned); X may have been partially -C reordered, and WR and WI contain the eigenvalues in -C the same order as in X. -C -C REFERENCES -C -C [1] Bai, Z. and Demmel, J.W. -C On Swapping Diagonal Blocks in Real Schur Form. -C Linear Algebra Appl., 186, pp. 73-95, 1993. -C -C [2] Benner, P., Kressner, D., and Mehrmann, V. -C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, -C Algorithms and Applications. Techn. Report, TU Berlin, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD). -C -C KEYWORDS -C -C Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPU, TYP - INTEGER INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N -C .. Array Arguments .. - LOGICAL LOWER(*), SELECT(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), - $ U2(LDU2,*), WI(*), WR(*) -C .. Local Scalars .. - LOGICAL FLOW, ISHAM, PAIR, SWAP, WANTU - INTEGER HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT, - $ WRKMIN -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL MB03TS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Decode and check input parameters. -C - ISHAM = LSAME( TYP, 'H' ) - WANTU = LSAME( COMPU, 'U' ) - WRKMIN = MAX( 1, N ) - INFO = 0 - IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN - INFO = -11 - ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN - INFO = -13 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -18 - DWORK(1) = DBLE( WRKMIN ) - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03TD', -INFO ) - RETURN - END IF -C -C Set M to the dimension of the specified invariant subspace. -C - M = 0 - PAIR = .FALSE. - 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 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Collect the selected blocks at the top-left corner of X. -C - KS = 0 - PAIR = .FALSE. - DO 60 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - SWAP = SELECT(K) - FLOW = LOWER(K) - IF ( K.LT.N ) THEN - IF ( A(K+1,K).NE.ZERO ) THEN - PAIR = .TRUE. - SWAP = SWAP.OR.SELECT(K+1) - FLOW = FLOW.OR.LOWER(K+1) - END IF - END IF -C - IF ( PAIR ) THEN - NBF = 2 - ELSE - NBF = 1 - END IF -C - IF ( SWAP ) THEN - KS = KS + 1 - IF ( FLOW ) THEN -C -C Step 1: Swap the K-th block to position N. -C - IFST = K - ILST = N - NBL = 1 - IF ( ILST.GT.1 ) THEN - IF ( A(ILST,ILST-1).NE.ZERO ) THEN - ILST = ILST - 1 - NBL = 2 - END IF - END IF -C -C Update ILST. -C - IF ( NBF.EQ.2 .AND. NBL.EQ.1 ) - $ ILST = ILST - 1 - IF ( NBF.EQ.1 .AND. NBL.EQ.2 ) - $ ILST = ILST + 1 -C - IF ( ILST.EQ.IFST ) - $ GO TO 30 -C - HERE = IFST -C - 20 CONTINUE -C -C Swap block with next one below. -C - IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -C -C Current block is either 1-by-1 or 2-by-2. -C - NBNEXT = 1 - IF ( HERE+NBF+1.LE.N ) THEN - IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE, NBF, NBNEXT, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE + NBNEXT -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( NBF.EQ.2 ) THEN - IF ( A(HERE+1,HERE).EQ.ZERO ) - $ NBF = 3 - END IF -C - ELSE -C -C Current block consists of two 1-by-1 blocks each of -C which must be swapped individually. -C - NBNEXT = 1 - IF ( HERE+3.LE.N ) THEN - IF ( A(HERE+3,HERE+2).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE+1, 1, NBNEXT, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - IF ( NBNEXT.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks, no problems possible. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, - $ NBNEXT, DWORK, IERR ) - HERE = HERE + 1 - ELSE -C -C Recompute NBNEXT in case 2 by 2 split. -C - IF ( A(HERE+2,HERE+1).EQ.ZERO ) - $ NBNEXT = 1 - IF ( NBNEXT.EQ.2 ) THEN -C -C 2-by-2 block did not split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, - $ NBNEXT, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE + 2 - ELSE -C -C 2-by-2 block did split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, 1, - $ DWORK, IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE+1, 1, - $ 1, DWORK, IERR ) - HERE = HERE + 2 - END IF - END IF - END IF - IF ( HERE.LT.ILST ) - $ GO TO 20 -C - 30 CONTINUE -C -C Step 2: Apply an orthogonal symplectic transformation -C to swap the last blocks in A and -A' (or A'). -C - IF ( NBF.EQ.1 ) THEN -C -C Exchange columns/rows N <-> 2*N. No problems -C possible. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, N, 1, 1, - $ DWORK, IERR ) -C - ELSE IF ( NBF.EQ.2 ) THEN -C -C Swap last block with its equivalent by an -C orthogonal symplectic transformation. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, N-1, 2, 2, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( A(N-1,N).EQ.ZERO ) - $ NBF = 3 - ELSE -C -C Block did split. Swap (N-1)-th and N-th elements -C consecutively by symplectic generalized -C permutations and one rotation. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, N-1, 1, 1, DWORK, - $ IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) - END IF - IFST = N - IF ( PAIR ) - $ IFST = N-1 - ELSE - IFST = K - END IF -C -C Step 3: Swap the K-th / N-th block to position KS. -C - ILST = KS - NBL = 1 - IF ( ILST.GT.1 ) THEN - IF ( A(ILST,ILST-1).NE.ZERO ) THEN - ILST = ILST - 1 - NBL = 2 - END IF - END IF -C - IF ( ILST.EQ.IFST ) - $ GO TO 50 -C - HERE = IFST - 40 CONTINUE -C -C Swap block with next one above. -C - IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -C -C Current block either 1 by 1 or 2 by 2. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, - $ NBF, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE - NBNEXT -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( NBF.EQ.2 ) THEN - IF ( A(HERE+1,HERE).EQ.ZERO ) - $ NBF = 3 - END IF -C - ELSE -C -C Current block consists of two 1 by 1 blocks each of -C which must be swapped individually. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, - $ 1, DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - IF ( NBNEXT.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks, no problems possible. -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, - $ LDU1, U2, LDU2, HERE, NBNEXT, 1, - $ DWORK, IERR ) - - HERE = HERE - 1 - ELSE -C -C Recompute NBNEXT in case 2-by-2 split. -C - IF ( A(HERE,HERE-1).EQ.ZERO ) - $ NBNEXT = 1 - IF ( NBNEXT.EQ.2 ) THEN -C -C 2-by-2 block did not split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE-1, 2, 1, - $ DWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - GO TO 70 - END IF - HERE = HERE - 2 - ELSE -C -C 2-by-2 block did split -C - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE, 1, 1, - $ DWORK, IERR ) - CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, - $ U1, LDU1, U2, LDU2, HERE-1, 1, 1, - $ DWORK, IERR ) - HERE = HERE - 2 - END IF - END IF - END IF -C - IF ( HERE.GT.ILST ) - $ GO TO 40 -C - 50 CONTINUE - IF ( PAIR ) - $ KS = KS + 1 - END IF - END IF - 60 CONTINUE -C - 70 CONTINUE -C -C Store eigenvalues. -C - DO 80 K = 1, N - WR(K) = A(K,K) - WI(K) = ZERO - 80 CONTINUE - DO 90 K = 1, N - 1 - IF ( A(K+1,K).NE.ZERO ) THEN - WI(K) = SQRT( ABS( A(K,K+1) ) )* - $ SQRT( ABS( A(K+1,K) ) ) - WI(K+1) = -WI(K) - END IF - 90 CONTINUE -C - DWORK(1) = DBLE( WRKMIN ) -C - RETURN -C *** Last line of MB03TD *** - END diff --git a/slycot/src/MB03TS.f b/slycot/src/MB03TS.f deleted file mode 100644 index 202e72f5..00000000 --- a/slycot/src/MB03TS.f +++ /dev/null @@ -1,746 +0,0 @@ - SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2, - $ LDU2, J1, N1, N2, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper -C quasi-triangular matrix A contained in a skew-Hamiltonian matrix -C -C [ A G ] T -C X = [ T ], G = -G, -C [ 0 A ] -C -C or in a Hamiltonian matrix -C -C [ A G ] T -C X = [ T ], G = G. -C [ 0 -A ] -C -C This routine is a modified version of the LAPACK subroutine -C DLAEX2. -C -C The matrix A must be in Schur canonical form (as returned by the -C LAPACK routine DHSEQR), that is, block upper triangular with -C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has -C its diagonal elements equal and its off-diagonal elements of -C opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C ISHAM LOGIGAL -C Specifies the type of X: -C = .TRUE.: X is a Hamiltonian matrix; -C = .FALSE.: X is a skew-Hamiltonian matrix. -C -C WANTU LOGIGAL -C = .TRUE.: update the matrices U1 and U2 containing the -C Schur vectors; -C = .FALSE.: do not update U1 and U2. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A, in Schur -C canonical form. -C On exit, the leading N-by-N part of this array contains -C the reordered matrix A, again in Schur canonical form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular part of the symmetric -C matrix G, if ISHAM = .TRUE., or the strictly upper -C triangular part of the skew-symmetric matrix G, otherwise. -C The rest of this array is not referenced. -C On exit, the leading N-by-N part of this array contains -C the upper or strictly upper triangular part of the -C symmetric or skew-symmetric matrix G, respectively, -C updated by the orthogonal transformation which reorders A. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, if WANTU = .TRUE., the leading N-by-N part of -C this array must contain the matrix U1. -C On exit, if WANTU = .TRUE., the leading N-by-N part of -C this array contains U1, postmultiplied by the orthogonal -C transformation which reorders A. See the description in -C the SLICOT subroutine MB03TD for further details. -C If WANTU = .FALSE., this array is not referenced. -C -C LDU1 INTEGER -C The leading dimension of the array U1. -C LDU1 >= MAX(1,N), if WANTU = .TRUE.; -C LDU1 >= 1, otherwise. -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, if WANTU = .TRUE., the leading N-by-N part of -C this array must contain the matrix U2. -C On exit, if WANTU = .TRUE., the leading N-by-N part of -C this array contains U2, postmultiplied by the orthogonal -C transformation which reorders A. -C If WANTU = .FALSE., this array is not referenced. -C -C LDU2 INTEGER -C The leading dimension of the array U2. -C LDU2 >= MAX(1,N), if WANTU = .TRUE.; -C LDU2 >= 1, otherwise. -C -C J1 (input) INTEGER -C The index of the first row of the first block A11. -C If J1+N1 < N, then A11 is swapped with the block starting -C at (J1+N1+1)-th diagonal element. -C If J1+N1 > N, then A11 is the last block in A and swapped -C with -A11', if ISHAM = .TRUE., -C or A11', if ISHAM = .FALSE.. -C -C N1 (input) INTEGER -C The order of the first block A11. N1 = 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of the second block A22. N2 = 0, 1 or 2. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: the transformed matrix A would be too far from Schur -C form; the blocks are not swapped and A, G, U1 and -C U2 are unchanged. -C -C REFERENCES -C -C [1] Bai, Z., and Demmel, J.W. -C On swapping diagonal blocks in real Schur form. -C Linear Algebra Appl., 186, pp. 73-95, 1993. -C -C [2] Benner, P., Kressner, D., and Mehrmann, V. -C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, -C Algorithms and Applications. Techn. Report, TU Berlin, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAEX2). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, THIRTY, FORTY - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, THIRTY = 3.0D+1, - $ FORTY = 4.0D+1 ) - INTEGER LDD, LDX - PARAMETER ( LDD = 4, LDX = 2 ) -C .. Scalar Arguments .. - LOGICAL ISHAM, WANTU - INTEGER INFO, J1, LDA, LDG, LDU1, LDU2, N, N1, N2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), - $ U2(LDU2,*) -C .. Local Scalars .. - LOGICAL LBLK - INTEGER IERR, J2, J3, J4, K, ND - DOUBLE PRECISION A11, A22, A33, CS, DNORM, EPS, SCALE, SMLNUM, - $ SN, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, - $ WR1, WR2, XNORM -C .. Local Arrays .. - DOUBLE PRECISION D(LDD,4), V(3), V1(3), V2(3), X(LDX,2) -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DLANGE - EXTERNAL DDOT, DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, - $ DLASET, DLASY2, DROT, DSCAL, DSWAP, DSYMV, - $ DSYR2, MB01MD, MB01ND -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C -C .. Executable Statements .. -C - INFO = 0 -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) - $ RETURN - LBLK = ( J1+N1.GT.N ) -C - J2 = J1 + 1 - J3 = J1 + 2 - J4 = J1 + 3 -C - IF ( LBLK .AND. N1.EQ.1 ) THEN -C - IF ( ISHAM ) THEN - A11 = A(N,N) - CALL DLARTG( G(N,N), -TWO*A11, CS, SN, TEMP ) - CALL DROT( N-1, A(1,N), 1, G(1,N), 1, CS, SN ) - A(N,N) = -A11 - IF ( WANTU ) - $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) - ELSE - CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) - CALL DSCAL( N-1, -ONE, A(1,N), 1 ) - IF ( WANTU ) THEN - CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) - CALL DSCAL( N, -ONE, U1(1,N), 1 ) - END IF - END IF -C - ELSE IF ( LBLK .AND. N1.EQ.2 ) THEN -C - IF ( ISHAM ) THEN -C -C Reorder Hamiltonian matrix: -C -C [ A11 G11 ] -C [ T ]. -C [ 0 -A11 ] -C - ND = 4 - CALL DLACPY( 'Full', 2, 2, A(N-1,N-1), LDA, D, LDD ) - CALL DLASET( 'All', 2, 2, ZERO, ZERO, D(3,1), LDD ) - CALL DLACPY( 'Upper', 2, 2, G(N-1,N-1), LDG, D(1,3), LDD ) - D(2,3) = D(1,4) - D(3,3) = -D(1,1) - D(4,3) = -D(1,2) - D(3,4) = -D(2,1) - D(4,4) = -D(2,2) - DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) -C -C Compute machine-dependent threshold for test for accepting -C swap. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - THRESH = MAX( FORTY*EPS*DNORM, SMLNUM ) -C -C Solve A11*X + X*A11' = scale*G11 for X. -C - CALL DLASY2( .FALSE., .FALSE., -1, 2, 2, D, LDD, D(3,3), - $ LDD, D(1,3), LDD, SCALE, X, LDX, XNORM, IERR ) -C -C Compute symplectic QR decomposition of -C -C ( -X11 -X12 ) -C ( -X21 -X22 ). -C ( scale 0 ) -C ( 0 scale ) -C - TEMP = -X(1,1) - CALL DLARTG( TEMP, SCALE, V1(1), V2(1), X(1,1) ) - CALL DLARTG( X(1,1), -X(2,1), V1(2), V2(2), TEMP ) - X(1,2) = -X(1,2) - X(2,2) = -X(2,2) - X(1,1) = ZERO - X(2,1) = SCALE - CALL DROT( 1, X(1,2), 1, X(1,1), 1, V1(1), V2(1) ) - CALL DROT( 1, X(1,2), 1, X(2,2), 1, V1(2), V2(2) ) - CALL DROT( 1, X(1,1), 1, X(2,1), 1, V1(2), V2(2) ) - CALL DLARTG( X(2,2), X(2,1), V1(3), V2(3), TEMP ) -C -C Perform swap provisionally on D. -C - CALL DROT( 4, D(1,1), LDD, D(3,1), LDD, V1(1), V2(1) ) - CALL DROT( 4, D(1,1), LDD, D(2,1), LDD, V1(2), V2(2) ) - CALL DROT( 4, D(3,1), LDD, D(4,1), LDD, V1(2), V2(2) ) - CALL DROT( 4, D(2,1), LDD, D(4,1), LDD, V1(3), V2(3) ) - CALL DROT( 4, D(1,1), 1, D(1,3), 1, V1(1), V2(1) ) - CALL DROT( 4, D(1,1), 1, D(1,2), 1, V1(2), V2(2) ) - CALL DROT( 4, D(1,3), 1, D(1,4), 1, V1(2), V2(2) ) - CALL DROT( 4, D(1,2), 1, D(1,4), 1, V1(3), V2(3) ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), - $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 -C - CALL DLACPY( 'All', 2, 2, D(1,1), LDD, A(N-1,N-1), LDA ) - CALL DLACPY( 'Upper', 2, 2, D(1,3), LDD, G(N-1,N-1), LDG ) -C - IF ( N.GT.2 ) THEN - CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, V1(1), V2(1) ) - CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, V1(2), V2(2) ) - CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, V1(2), V2(2) ) - CALL DROT( N-2, A(1,N), 1, G(1,N), 1, V1(3), V2(3) ) - END IF -C - IF ( WANTU ) THEN - CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, V1(1), V2(1) ) - CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, V1(2), V2(2) ) - CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, V1(2), V2(2) ) - CALL DROT( N, U1(1,N), 1, U2(1,N), 1, V1(3), V2(3) ) - END IF -C - ELSE -C - IF ( ABS( A(N-1,N) ).GT.ABS( A(N,N-1) ) ) THEN - TEMP = G(N-1,N) - CALL DLARTG( TEMP, A(N-1,N), CS, SN, G(N-1,N) ) - SN = -SN - CALL DROT(N-2, A(1,N), 1, G(1,N), 1, CS, SN ) -C - A(N-1,N) = -SN*A(N,N-1) - TEMP = -CS*A(N,N-1) - A(N,N-1) = G(N-1,N) - G(N-1,N) = TEMP - IF ( WANTU ) - $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) - CALL DSWAP( N-2, A(1,N-1), 1, G(1,N-1), 1 ) - CALL DSCAL( N-2, -ONE, A(1,N-1), 1 ) - IF ( WANTU ) THEN - CALL DSWAP( N, U1(1,N-1), 1, U2(1,N-1), 1 ) - CALL DSCAL( N, -ONE, U1(1,N-1), 1 ) - END IF - ELSE - TEMP = G(N-1,N) - CALL DLARTG( TEMP, A(N,N-1), CS, SN, G(N-1,N) ) - CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, CS, SN ) - A(N,N-1) = -SN*A(N-1,N) - A(N-1,N) = CS*A(N-1,N) - IF ( WANTU ) - $ CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, CS, SN ) - CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) - CALL DSCAL( N-1, -ONE, A(1,N), 1 ) - IF ( WANTU ) THEN - CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) - CALL DSCAL( N, -ONE, U1(1,N), 1 ) - END IF - END IF - END IF -C -C Standardize new 2-by-2 block. -C - CALL DLANV2( A(N-1,N-1), A(N-1,N), A(N,N-1), - $ A(N,N), WR1, WI1, WR2, WI2, CS, SN ) - CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, CS, SN ) - IF ( ISHAM ) THEN - TEMP = G(N-1,N) - CALL DROT( N-1, G(1,N-1), 1, G(1,N), 1, CS, SN ) - TAU = CS*TEMP + SN*G(N,N) - G(N,N) = CS*G(N,N) - SN*TEMP - G(N-1,N-1) = CS*G(N-1,N-1) + SN*TAU - CALL DROT( 1, G(N-1,N), LDG, G(N,N), LDG, CS, SN ) - ELSE - CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, CS, SN ) - END IF - IF ( WANTU ) THEN - CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, CS, SN ) - CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, CS, SN ) - END IF -C - ELSE IF ( N1.EQ.1 .AND. N2.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks. -C - A11 = A(J1,J1) - A22 = A(J2,J2) -C -C Determine the transformation to perform the interchange. -C - CALL DLARTG( A(J1,J2), A22-A11, CS, SN, TEMP ) -C -C Apply transformation to the matrix A. -C - IF ( J3.LE.N ) - $ CALL DROT( N-J1-1, A(J1,J3), LDA, A(J2,J3), LDA, CS, SN ) - CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) -C - A(J1,J1) = A22 - A(J2,J2) = A11 -C -C Apply transformation to the matrix G. -C - IF ( ISHAM ) THEN - TEMP = G(J1,J2) - CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - TAU = CS*TEMP + SN*G(J2,J2) - G(J2,J2) = CS*G(J2,J2) - SN*TEMP - G(J1,J1) = CS*G(J1,J1) + SN*TAU - CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) - ELSE - IF ( N.GT.J1+1 ) - $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, CS, - $ SN ) - CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - END IF - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) - CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) - END IF -C - ELSE -C -C Swapping involves at least one 2-by-2 block. -C -C Copy the diagonal block of order N1+N2 to the local array D -C and compute its norm. -C - ND = N1 + N2 - CALL DLACPY( 'Full', ND, ND, A(J1,J1), LDA, D, LDD ) - DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) -C -C Compute machine-dependent threshold for test for accepting -C swap. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - THRESH = MAX( THIRTY*EPS*DNORM, SMLNUM ) -C -C Solve A11*X - X*A22 = scale*A12 for X. -C - 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 ) -C -C Swap the adjacent diagonal blocks. -C - K = N1 + N1 + N2 - 3 - GO TO ( 10, 20, 30 )K -C - 10 CONTINUE -C -C N1 = 1, N2 = 2: generate elementary reflector H so that: -C -C ( scale, X11, X12 ) H = ( 0, 0, * ). -C - V(1) = SCALE - V(2) = X(1,1) - V(3) = X(1,2) - CALL DLARFG( 3, V(3), V, 1, TAU ) - V(3) = ONE - A11 = A(J1,J1) -C -C Perform swap provisionally on diagonal block in D. -C - CALL DLARFX( 'Left', 3, 3, V, TAU, D, LDD, DWORK ) - CALL DLARFX( 'Right', 3, 3, V, TAU, D, LDD, DWORK ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(3,3)-A11 ) ) - $ .GT.THRESH ) GO TO 50 -C -C Accept swap: apply transformation to the entire matrix A. -C - CALL DLARFX( 'Left', 3, N-J1+1, V, TAU, A(J1,J1), LDA, DWORK ) - CALL DLARFX( 'Right', J2, 3, V, TAU, A(1,J1), LDA, DWORK ) -C - A(J3,J1) = ZERO - A(J3,J2) = ZERO - A(J3,J3) = A11 -C -C Apply transformation to G. -C - IF ( ISHAM ) THEN - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) - CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, - $ G(J1,J1), LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - ELSE - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - END IF -C - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) - END IF - GO TO 40 -C - 20 CONTINUE -C -C N1 = 2, N2 = 1: generate elementary reflector H so that: -C -C H ( -X11 ) = ( * ) -C ( -X21 ) = ( 0 ). -C ( scale ) = ( 0 ) -C - V(1) = -X(1,1) - V(2) = -X(2,1) - V(3) = SCALE - CALL DLARFG( 3, V(1), V(2), 1, TAU ) - V(1) = ONE - A33 = A(J3,J3) -C -C Perform swap provisionally on diagonal block in D. -C - CALL DLARFX( 'L', 3, 3, V, TAU, D, LDD, DWORK ) - CALL DLARFX( 'R', 3, 3, V, TAU, D, LDD, DWORK ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(2,1) ), ABS( D(3,1) ), ABS( D(1,1)-A33 ) ) - $ .GT. THRESH ) GO TO 50 -C -C Accept swap: apply transformation to the entire matrix A. -C - CALL DLARFX( 'Right', J3, 3, V, TAU, A(1,J1), LDA, DWORK ) - CALL DLARFX( 'Left', 3, N-J1, V, TAU, A(J1,J2), LDA, DWORK ) -C - A(J1,J1) = A33 - A(J2,J1) = ZERO - A(J3,J1) = ZERO -C -C Apply transformation to G. -C - IF ( ISHAM ) THEN - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) - CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - ELSE - CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) - CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, - $ DWORK ) - END IF -C - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) - END IF - GO TO 40 -C - 30 CONTINUE -C -C N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so -C that: -C -C H(2) H(1) ( -X11 -X12 ) = ( * * ) -C ( -X21 -X22 ) ( 0 * ). -C ( scale 0 ) ( 0 0 ) -C ( 0 scale ) ( 0 0 ) -C - V1(1) = -X(1,1) - V1(2) = -X(2,1) - V1(3) = SCALE - CALL DLARFG( 3, V1(1), V1(2), 1, TAU1 ) - V1(1) = ONE -C - TEMP = -TAU1*( X(1,2)+V1(2)*X(2,2) ) - V2(1) = -TEMP*V1(2) - X(2,2) - V2(2) = -TEMP*V1(3) - V2(3) = SCALE - CALL DLARFG( 3, V2(1), V2(2), 1, TAU2 ) - V2(1) = ONE -C -C Perform swap provisionally on diagonal block in D. -C - CALL DLARFX( 'L', 3, 4, V1, TAU1, D, LDD, DWORK ) - CALL DLARFX( 'R', 4, 3, V1, TAU1, D, LDD, DWORK ) - CALL DLARFX( 'L', 3, 4, V2, TAU2, D(2,1), LDD, DWORK ) - CALL DLARFX( 'R', 4, 3, V2, TAU2, D(1,2), LDD, DWORK ) -C -C Test whether to reject swap. -C - IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), - $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 -C -C Accept swap: apply transformation to the entire matrix A. -C - CALL DLARFX( 'L', 3, N-J1+1, V1, TAU1, A(J1,J1), LDA, DWORK ) - CALL DLARFX( 'R', J4, 3, V1, TAU1, A(1,J1), LDA, DWORK ) - CALL DLARFX( 'L', 3, N-J1+1, V2, TAU2, A(J2,J1), LDA, DWORK ) - CALL DLARFX( 'R', J4, 3, V2, TAU2, A(1,J2), LDA, DWORK ) -C - A(J3,J1) = ZERO - A(J3,J2) = ZERO - A(J4,J1) = ZERO - A(J4,J2) = ZERO -C -C Apply transformation to G. -C - IF ( ISHAM ) THEN - CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, - $ DWORK ) - CALL DSYMV( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU1*DDOT( 3, DWORK, 1, V1, 1 ) - CALL DAXPY( 3, TEMP, V1, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V1, 1, DWORK, 1, - $ G(J1,J1), LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), - $ LDG, DWORK ) -C - CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, - $ DWORK ) - CALL DSYMV( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, - $ DWORK, 1 ) - TEMP = -HALF*TAU2*DDOT( 3, DWORK, 1, V2, 1 ) - CALL DAXPY( 3, TEMP, V2, 1, DWORK, 1 ) - CALL DSYR2( 'Upper', 3, -ONE, V2, 1, DWORK, 1, G(J2,J2), - $ LDG ) - IF ( N.GT.J2+2 ) - $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), - $ LDG, DWORK ) - ELSE - CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, - $ DWORK ) - CALL MB01MD( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V1, 1, DWORK, 1, G(J1,J1), - $ LDG ) - IF ( N.GT.J1+2 ) - $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), - $ LDG, DWORK ) - CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, - $ DWORK ) - CALL MB01MD( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, - $ DWORK, 1 ) - CALL MB01ND( 'Upper', 3, ONE, V2, 1, DWORK, 1, G(J2,J2), - $ LDG ) - IF ( N.GT.J2+2 ) - $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), - $ LDG, DWORK ) - END IF -C - IF ( WANTU ) THEN -C -C Accumulate transformation in the matrices U1 and U2. -C - CALL DLARFX( 'R', N, 3, V1, TAU1, U1(1,J1), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V2, TAU2, U1(1,J2), LDU1, DWORK ) - CALL DLARFX( 'R', N, 3, V1, TAU1, U2(1,J1), LDU2, DWORK ) - CALL DLARFX( 'R', N, 3, V2, TAU2, U2(1,J2), LDU2, DWORK ) - END IF -C - 40 CONTINUE -C - IF ( N2.EQ.2 ) THEN -C -C Standardize new 2-by-2 block A11. -C - CALL DLANV2( A(J1,J1), A(J1,J2), A(J2,J1), A(J2,J2), WR1, - $ WI1, WR2, WI2, CS, SN ) - CALL DROT( N-J1-1, A(J1,J1+2), LDA, A(J2,J1+2), LDA, CS, - $ SN ) - CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) - IF ( ISHAM ) THEN - TEMP = G(J1,J2) - CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - TAU = CS*TEMP + SN*G(J2,J2) - G(J2,J2) = CS*G(J2,J2) - SN*TEMP - G(J1,J1) = CS*G(J1,J1) + SN*TAU - CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) - ELSE - IF ( N.GT.J1+1 ) - $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, - $ CS, SN ) - CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) - END IF - IF ( WANTU ) THEN - CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) - CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) - END IF - END IF -C - IF ( N1.EQ.2 ) THEN -C -C Standardize new 2-by-2 block A22. -C - J3 = J1 + N2 - J4 = J3 + 1 - CALL DLANV2( A(J3,J3), A(J3,J4), A(J4,J3), A(J4,J4), WR1, - $ WI1, WR2, WI2, CS, SN ) - IF ( J3+2.LE.N ) - $ CALL DROT( N-J3-1, A(J3,J3+2), LDA, A(J4,J3+2), LDA, CS, - $ SN ) - CALL DROT( J3-1, A(1,J3), 1, A(1,J4), 1, CS, SN ) - IF ( ISHAM ) THEN - TEMP = G(J3,J4) - CALL DROT( J3, G(1,J3), 1, G(1,J4), 1, CS, SN ) - TAU = CS*TEMP + SN*G(J4,J4) - G(J4,J4) = CS*G(J4,J4) - SN*TEMP - G(J3,J3) = CS*G(J3,J3) + SN*TAU - CALL DROT( N-J3, G(J3,J4), LDG, G(J4,J4), LDG, CS, SN ) - ELSE - IF ( N.GT.J3+1 ) - $ CALL DROT( N-J3-1, G(J3,J3+2), LDG, G(J4,J3+2), LDG, - $ CS, SN ) - CALL DROT( J3-1, G(1,J3), 1, G(1,J4), 1, CS, SN ) - END IF - IF ( WANTU ) THEN - CALL DROT( N, U1(1,J3), 1, U1(1,J4), 1, CS, SN ) - CALL DROT( N, U2(1,J3), 1, U2(1,J4), 1, CS, SN ) - END IF - END IF -C - END IF - RETURN -C -C Exit with INFO = 1 if swap was rejected. -C - 50 CONTINUE - INFO = 1 - RETURN -C *** Last line of MB03TS *** - END diff --git a/slycot/src/MB03UD.f b/slycot/src/MB03UD.f deleted file mode 100644 index 37e6b6bc..00000000 --- a/slycot/src/MB03UD.f +++ /dev/null @@ -1,318 +0,0 @@ - SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute all, or part, of the singular value decomposition of a -C real upper triangular matrix. -C -C The N-by-N upper triangular matrix A is factored as A = Q*S*P', -C where Q and P are N-by-N orthogonal matrices and S is an -C N-by-N diagonal matrix with non-negative diagonal elements, -C SV(1), SV(2), ..., SV(N), ordered such that -C -C SV(1) >= SV(2) >= ... >= SV(N) >= 0. -C -C The columns of Q are the left singular vectors of A, the diagonal -C elements of S are the singular values of A and the columns of P -C are the right singular vectors of A. -C -C Either or both of Q and P' may be requested. -C When P' is computed, it is returned in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBQ CHARACTER*1 -C Specifies whether the user wishes to compute the matrix Q -C of left singular vectors as follows: -C = 'V': Left singular vectors are computed; -C = 'N': No left singular vectors are computed. -C -C JOBP CHARACTER*1 -C Specifies whether the user wishes to compute the matrix P' -C of right singular vectors as follows: -C = 'V': Right singular vectors are computed; -C = 'N': No right singular vectors are computed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix A. -C On exit, if JOBP = 'V', the leading N-by-N part of this -C array contains the N-by-N orthogonal matrix P'; otherwise -C the N-by-N upper triangular part of A is used as internal -C workspace. The strictly lower triangular part of A is set -C internally to zero before the reduction to bidiagonal form -C is performed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C If JOBQ = 'V', the leading N-by-N part of this array -C contains the orthogonal matrix Q. -C If JOBQ = 'N', Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, and when JOBQ = 'V', LDQ >= MAX(1,N). -C -C SV (output) DOUBLE PRECISION array, dimension (N) -C The N singular values of the matrix A, sorted in -C descending order. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; -C if INFO > 0, DWORK(2:N) contains the unconverged -C superdiagonal elements of an upper bidiagonal matrix B -C whose diagonal is in SV (not necessarily sorted). -C B satisfies A = Q*B*P', so it has the same singular -C values as A, and singular vectors related by Q and P'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,5*N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: the QR algorithm has failed to converge. In this -C case INFO specifies how many superdiagonals did not -C converge (see the description of DWORK). -C This failure is not likely to occur. -C -C METHOD -C -C The routine reduces A to bidiagonal form by means of elementary -C reflectors and then uses the QR algorithm on the bidiagonal form. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute of Informatics, Bucharest, and -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, -C March 1998. Based on the RASP routine DTRSVD. -C -C REVISIONS -C -C V. Sima, Feb. 2000. -C -C KEYWORDS -C -C Bidiagonalization, orthogonal transformation, singular value -C decomposition, singular values, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBP, JOBQ - INTEGER INFO, LDA, LDQ, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), Q(LDQ,*), SV(*) -C .. Local Scalars .. - LOGICAL WANTQ, WANTP - INTEGER I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK, - $ MINWRK, NCOLP, NCOLQ - DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANTR - EXTERNAL DLAMCH, DLANTR, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -C .. Executable Statements .. -C -C Check the input scalar arguments. -C - INFO = 0 - WANTQ = LSAME( JOBQ, 'V' ) - WANTP = LSAME( JOBP, 'V' ) - MINWRK = 1 - IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN - INFO = -7 - END IF -C -C Compute workspace -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately following -C subroutine, as returned by ILAENV.) -C - IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. N.GT.0 ) THEN - MAXWRK = 3*N+2*N*ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) - IF( WANTQ ) - $ MAXWRK = MAX( MAXWRK, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) - IF( WANTP ) - $ MAXWRK = MAX( MAXWRK, 3*N+N* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MINWRK = 5*N - MAXWRK = MAX( MAXWRK, MINWRK ) - DWORK(1) = MAXWRK - END IF -C - IF( LDWORK.LT.MINWRK ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Get machine constants. -C - EPS = DLAMCH( 'P' ) - SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS - BIGNUM = ONE / SMLNUM -C -C Scale A if max entry outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM ) - ISCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN - ISCL = 1 - CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO ) - ELSE IF( ANRM.GT.BIGNUM ) THEN - ISCL = 1 - CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO ) - END IF -C -C Zero out below. -C - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA ) -C -C Find the singular values and optionally the singular vectors -C of the upper triangular matrix A. -C - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - JWORK = ITAUP + N -C -C First reduce the matrix to bidiagonal form. The diagonal -C elements will be in SV and the superdiagonals in DWORK(IE). -C (Workspace: need 4*N, prefer 3*N+2*N*NB) -C - CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ), - $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) - IF( WANTQ ) THEN -C -C Generate the transformation matrix Q corresponding to the -C left singular vectors. -C (Workspace: need 4*N, prefer 3*N+N*NB) -C - NCOLQ = N - CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) - CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - ELSE - NCOLQ = 0 - END IF - IF( WANTP ) THEN -C -C Generate the transformation matrix P' corresponding to the -C right singular vectors. -C (Workspace: need 4*N, prefer 3*N+N*NB) -C - NCOLP = N - CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - ELSE - NCOLP = 0 - END IF - JWORK = IE + N -C -C Perform bidiagonal QR iteration, to obtain all or part of the -C singular value decomposition of A. -C (Workspace: need 5*N) -C - CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA, - $ Q, LDQ, DUM, 1, DWORK(JWORK), INFO ) -C -C If DBDSQR failed to converge, copy unconverged superdiagonals -C to DWORK(2:N). -C - IF( INFO.NE.0 ) THEN - DO 10 I = N - 1, 1, -1 - DWORK(I+1) = DWORK(I+IE-1) - 10 CONTINUE - END IF -C -C Undo scaling if necessary. -C - IF( ISCL.EQ.1 ) THEN - IF( ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO ) - IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) - $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N, - $ INFO ) - IF( ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO ) - IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) - $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N, - $ INFO ) - END IF -C -C Return optimal workspace in DWORK(1). -C - DWORK(1) = MAXWRK -C - RETURN -C *** Last line of MB03UD *** - END diff --git a/slycot/src/MB03VD.f b/slycot/src/MB03VD.f deleted file mode 100644 index 4cf99f6f..00000000 --- a/slycot/src/MB03VD.f +++ /dev/null @@ -1,306 +0,0 @@ - SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a product of p real general matrices A = A_1*A_2*...*A_p -C to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is -C upper Hessenberg, and H_2, ..., H_p are upper triangular, by using -C orthogonal similarity transformations on A, -C -C Q_1' * A_1 * Q_2 = H_1, -C Q_2' * A_2 * Q_3 = H_2, -C ... -C Q_p' * A_p * Q_1 = H_p. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the square matrices A_1, A_2, ..., A_p. -C N >= 0. -C -C P (input) INTEGER -C The number of matrices in the product A_1*A_2*...*A_p. -C P >= 1. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that all matrices A_j, j = 2, ..., p, are -C already upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N, and A_1 is upper Hessenberg in rows and columns -C 1:ILO-1 and IHI+1:N, with A_1(ILO,ILO-1) = 0 (unless -C ILO = 1), and A_1(IHI+1,IHI) = 0 (unless IHI = N). -C If this is not the case, ILO and IHI should be set to 1 -C and N, respectively. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA1,LDA2,P) -C On entry, the leading N-by-N-by-P part of this array must -C contain the matrices of factors to be reduced; -C specifically, A(*,*,j) must contain A_j, j = 1, ..., p. -C On exit, the leading N-by-N upper triangle and the first -C subdiagonal of A(*,*,1) contain the upper Hessenberg -C matrix H_1, and the elements below the first subdiagonal, -C with the first column of the array TAU represent the -C orthogonal matrix Q_1 as a product of elementary -C reflectors. See FURTHER COMMENTS. -C For j > 1, the leading N-by-N upper triangle of A(*,*,j) -C contains the upper triangular matrix H_j, and the elements -C below the diagonal, with the j-th column of the array TAU -C represent the orthogonal matrix Q_j as a product of -C elementary reflectors. See FURTHER COMMENTS. -C -C LDA1 INTEGER -C The first leading dimension of the array A. -C LDA1 >= max(1,N). -C -C LDA2 INTEGER -C The second leading dimension of the array A. -C LDA2 >= max(1,N). -C -C TAU (output) DOUBLE PRECISION array, dimension (LDTAU,P) -C The leading N-1 elements in the j-th column contain the -C scalar factors of the elementary reflectors used to form -C the matrix Q_j, j = 1, ..., P. See FURTHER COMMENTS. -C -C LDTAU INTEGER -C The leading dimension of the array TAU. -C LDTAU >= max(1,N-1). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm consists in ihi-ilo major steps. In each such -C step i, ilo <= i <= ihi-1, the subdiagonal elements in the i-th -C column of A_j are annihilated using a Householder transformation -C from the left, which is also applied to A_(j-1) from the right, -C for j = p:-1:2. Then, the elements below the subdiagonal of the -C i-th column of A_1 are annihilated, and the Householder -C transformation is also applied to A_p from the right. -C See FURTHER COMMENTS. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. -C The periodic Schur decomposition: algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Sreedhar, J. and Van Dooren, P. -C Periodic Schur form and some matrix equations. -C Proc. of the Symposium on the Mathematical Theory of Networks -C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, -C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C FURTHER COMMENTS -C -C Each matrix Q_j is represented as a product of (ihi-ilo) -C elementary reflectors, -C -C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). -C -C Each H_j(i), i = ilo, ..., ihi-1, has the form -C -C H_j(i) = I - tau_j * v_j * v_j', -C -C where tau_j is a real scalar, and v_j is a real vector with -C v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi) -C is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j). -C -C The contents of A_1 are illustrated by the following example -C for n = 7, ilo = 2, and ihi = 6: -C -C on entry on exit -C -C ( a a a a a a a ) ( a h h h h h a ) -C ( 0 a a a a a a ) ( 0 h h h h h a ) -C ( 0 a a a a a a ) ( 0 h h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) -C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) -C -C where a denotes an element of the original matrix A_1, h denotes -C a modified element of the upper Hessenberg matrix H_1, and vi -C denotes an element of the vector defining H_1(i). -C -C The contents of A_j, j > 1, are illustrated by the following -C example for n = 7, ilo = 2, and ihi = 6: -C -C on entry on exit -C -C ( a a a a a a a ) ( a h h h h h a ) -C ( 0 a a a a a a ) ( 0 h h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 h h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) -C ( 0 a a a a a a ) ( 0 v2 v3 v4 v5 h h ) -C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) -C -C where a denotes an element of the original matrix A_j, h denotes -C a modified element of the upper triangular matrix H_j, and vi -C denotes an element of the vector defining H_j(i). (The element -C (1,2) in A_p is also unchanged for this example.) -C -C Note that for P = 1, the LAPACK Library routine DGEHRD could be -C more efficient on some computer architectures than this routine -C (a BLAS 2 version). -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, -C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. -C Partly based on the routine PSHESS by A. Varga -C (DLR Oberpfaffenhofen), November 26, 1995. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, periodic systems, -C similarity transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) -C .. -C .. Local Scalars .. - INTEGER I, I1, I2, J, NH -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUMMY( 1 ) -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DLARFG, MB04PY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( P.LT.1 ) THEN - INFO = -2 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -4 - ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03VD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NH = IHI - ILO + 1 - IF ( NH.LE.1 ) - $ RETURN -C - DUMMY( 1 ) = ZERO -C - DO 20 I = ILO, IHI - 1 - I1 = I + 1 - I2 = MIN( I+2, N ) -C - DO 10 J = P, 2, -1 -C -C Set the elements 1:ILO-1 and IHI:N-1 of TAU(*,J) to zero. -C - CALL DCOPY( ILO-1, DUMMY, 0, TAU( 1, J ), 1 ) - IF ( IHI.LT.N ) - $ CALL DCOPY( N-IHI, DUMMY, 0, TAU( IHI, J ), 1 ) -C -C Compute elementary reflector H_j(i) to annihilate -C A_j(i+1:ihi,i). -C - CALL DLARFG( IHI-I+1, A( I, I, J ), A( I1, I, J ), 1, - $ TAU( I, J ) ) -C -C Apply H_j(i) to A_(j-1)(1:ihi,i:ihi) from the right. -C - CALL MB04PY( 'Right', IHI, IHI-I+1, A( I1, I, J ), - $ TAU( I, J ), A( 1, I, J-1 ), LDA1, DWORK ) -C -C Apply H_j(i) to A_j(i:ihi,i+1:n) from the left. -C - CALL MB04PY( 'Left', IHI-I+1, N-I, A( I1, I, J ), - $ TAU( I, J ), A( I, I1, J ), LDA1, DWORK ) - 10 CONTINUE -C -C Compute elementary reflector H_1(i) to annihilate -C A_1(i+2:ihi,i). -C - CALL DLARFG( IHI-I, A( I1, I, 1 ), A( I2, I, 1 ), 1, - $ TAU( I, 1 ) ) -C -C Apply H_1(i) to A_p(1:ihi,i+1:ihi) from the right. -C - CALL MB04PY( 'Right', IHI, IHI-I, A( I2, I, 1 ), TAU( I, 1 ), - $ A( 1, I1, P ), LDA1, DWORK ) -C -C Apply H_1(i) to A_1(i+1:ihi,i+1:n) from the left. -C - CALL MB04PY( 'Left', IHI-I, N-I, A( I2, I, 1 ), TAU( I, 1 ), - $ A( I1, I1, 1 ), LDA1, DWORK ) - 20 CONTINUE -C - RETURN -C -C *** Last line of MB03VD *** - END diff --git a/slycot/src/MB03VY.f b/slycot/src/MB03VY.f deleted file mode 100644 index 163e7749..00000000 --- a/slycot/src/MB03VY.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE MB03VY( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p, -C which are defined as the product of ihi-ilo elementary reflectors -C of order n, as returned by SLICOT Library routine MB03VD: -C -C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. -C -C P (input) INTEGER -C The number p of transformation matrices. P >= 1. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C The values of the indices ilo and ihi, respectively, used -C in the previous call of the SLICOT Library routine MB03VD. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA1,LDA2,N) -C On entry, the leading N-by-N strictly lower triangular -C part of A(*,*,j) must contain the vectors which define the -C elementary reflectors used for reducing A_j, as returned -C by SLICOT Library routine MB03VD, j = 1, ..., p. -C On exit, the leading N-by-N part of A(*,*,j) contains the -C N-by-N orthogonal matrix Q_j, j = 1, ..., p. -C -C LDA1 INTEGER -C The first leading dimension of the array A. -C LDA1 >= max(1,N). -C -C LDA2 INTEGER -C The second leading dimension of the array A. -C LDA2 >= max(1,N). -C -C TAU (input) DOUBLE PRECISION array, dimension (LDTAU,P) -C The leading N-1 elements in the j-th column must contain -C the scalar factors of the elementary reflectors used to -C form the matrix Q_j, as returned by SLICOT Library routine -C MB03VD. -C -C LDTAU INTEGER -C The leading dimension of the array TAU. -C LDTAU >= max(1,N-1). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Each matrix Q_j is generated as the product of the elementary -C reflectors used for reducing A_j. Standard LAPACK routines for -C Hessenberg and QR decompositions are used. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. -C The periodic Schur decomposition: algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Sreedhar, J. and Van Dooren, P. -C Periodic Schur form and some matrix equations. -C Proc. of the Symposium on the Mathematical Theory of Networks -C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, -C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, -C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. -C Partly based on the routine PSHTR by A. Varga -C (DLR Oberpfaffenhofen), November 26, 1995. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, periodic systems, -C similarity transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C -C .. Scalar Arguments .. - INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, LDWORK, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) -C .. -C .. Local Scalars .. - INTEGER J, NH - DOUBLE PRECISION WRKOPT -C .. -C .. External Subroutines .. - EXTERNAL DLASET, DORGHR, DORGQR, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( P.LT.1 ) THEN - INFO = -2 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -4 - ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03VY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Generate the orthogonal matrix Q_1. -C - CALL DORGHR( N, ILO, IHI, A, LDA1, TAU, DWORK, LDWORK, INFO ) - WRKOPT = DWORK( 1 ) -C - NH = IHI - ILO + 1 -C - DO 20 J = 2, P -C -C Generate the orthogonal matrix Q_j. -C Set the first ILO-1 and the last N-IHI rows and columns of Q_j -C to those of the unit matrix. -C - CALL DLASET( 'Full', N, ILO-1, ZERO, ONE, A( 1, 1, J ), LDA1 ) - CALL DLASET( 'Full', ILO-1, NH, ZERO, ZERO, A( 1, ILO, J ), - $ LDA1 ) - IF ( NH.GT.1 ) - $ CALL DORGQR( NH, NH, NH-1, A( ILO, ILO, J ), LDA1, - $ TAU( ILO, J ), DWORK, LDWORK, INFO ) - IF ( IHI.LT.N ) THEN - CALL DLASET( 'Full', N-IHI, NH, ZERO, ZERO, - $ A( IHI+1, ILO, J ), LDA1 ) - CALL DLASET( 'Full', IHI, N-IHI, ZERO, ZERO, - $ A( 1, IHI+1, J ), LDA1 ) - CALL DLASET( 'Full', N-IHI, N-IHI, ZERO, ONE, - $ A( IHI+1, IHI+1, J ), LDA1 ) - END IF - 20 CONTINUE -C - DWORK( 1 ) = MAX( WRKOPT, DWORK( 1 ) ) - RETURN -C -C *** Last line of MB03VY *** - END diff --git a/slycot/src/MB03WA.f b/slycot/src/MB03WA.f deleted file mode 100644 index 0a800ae0..00000000 --- a/slycot/src/MB03WA.f +++ /dev/null @@ -1,538 +0,0 @@ - SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ, - $ Z, LDZ, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To swap adjacent diagonal blocks A11*B11 and A22*B22 of size -C 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product -C A*B by an orthogonal equivalence transformation. -C -C (A, B) must be in periodic real Schur canonical form (as returned -C by SLICOT Library routine MB03XP), i.e., A is block upper -C triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper -C triangular. -C -C Optionally, the matrices Q and Z of generalized Schur vectors are -C updated. -C -C Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)', -C Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'. -C -C This routine is largely based on the LAPACK routine DTGEX2 -C developed by Bo Kagstrom and Peter Poromaa. -C -C ARGUMENTS -C -C Mode Parameters -C -C WANTQ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = .TRUE. : The matrix Q is updated; -C = .FALSE.: the matrix Q is not required. -C -C WANTZ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = .TRUE. : The matrix Z is updated; -C = .FALSE.: the matrix Z is not required. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The order of the first block A11*B11. N1 = 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of the second block A22*B22. N2 = 0, 1 or 2. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,N1+N2) -C On entry, the leading (N1+N2)-by-(N1+N2) part of this -C array must contain the matrix A. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the matrix A of the reordered pair. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N1+N2). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,N1+N2) -C On entry, the leading (N1+N2)-by-(N1+N2) part of this -C array must contain the matrix B. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the matrix B of the reordered pair. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N1+N2). -C -C Q (input/output) DOUBLE PRECISION array, dimension -C (LDQ,N1+N2) -C On entry, if WANTQ = .TRUE., the leading -C (N1+N2)-by-(N1+N2) part of this array must contain the -C orthogonal matrix Q. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the updated matrix Q. Q will be a rotation -C matrix for N1=N2=1. -C This array is not referenced if WANTQ = .FALSE.. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If WANTQ = .TRUE., LDQ >= N1+N2. -C -C Z (input/output) DOUBLE PRECISION array, dimension -C (LDZ,N1+N2) -C On entry, if WANTZ = .TRUE., the leading -C (N1+N2)-by-(N1+N2) part of this array must contain the -C orthogonal matrix Z. -C On exit, the leading (N1+N2)-by-(N1+N2) part of this array -C contains the updated matrix Z. Z will be a rotation -C matrix for N1=N2=1. -C This array is not referenced if WANTZ = .FALSE.. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If WANTZ = .TRUE., LDZ >= N1+N2. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: the transformed matrix (A, B) would be -C too far from periodic Schur form; the blocks are -C not swapped and (A,B) and (Q,Z) are unchanged. -C -C METHOD -C -C In the current code both weak and strong stability tests are -C performed. The user can omit the strong stability test by changing -C the internal logical parameter WANDS to .FALSE.. See ref. [2] for -C details. -C -C REFERENCES -C -C [1] Kagstrom, B. -C A direct method for reordering eigenvalues in the generalized -C real Schur form of a regular matrix pair (A,B), in M.S. Moonen -C et al (eds.), Linear Algebra for Large Scale and Real-Time -C Applications, Kluwer Academic Publ., 1993, pp. 195-218. -C -C [2] Kagstrom, B., and Poromaa, P. -C Computing eigenspaces with specified eigenvalues of a regular -C matrix pair (A, B) and condition estimation: Theory, -C algorithms and software, Numer. Algorithms, 1996, vol. 12, -C pp. 369-407. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTGPX2). -C -C KEYWORDS -C -C Eigenvalue, periodic Schur form, reordering -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 1.0D+01 ) - INTEGER LDST - PARAMETER ( LDST = 4 ) - LOGICAL WANDS - PARAMETER ( WANDS = .TRUE. ) -C .. Scalar Arguments .. - LOGICAL WANTQ, WANTZ - INTEGER INFO, LDA, LDB, LDQ, LDZ, N1, N2 -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL DTRONG, WEAK - INTEGER I, LINFO, M - DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, - $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS -C .. Local Arrays .. - INTEGER IWORK( LDST ) - DOUBLE PRECISION AI(2), AR(2), BE(2), DWORK(32), 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) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASET, - $ DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, DROT, - $ DSCAL, MB03YT, SB04OW -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C -C .. Executable Statements .. -C - INFO = 0 -C -C Quick return if possible. -C For efficiency, the arguments are not checked. -C - IF ( N1.LE.0 .OR. N2.LE.0 ) - $ RETURN - M = N1 + N2 -C - WEAK = .FALSE. - DTRONG = .FALSE. -C -C Make a local copy of selected block. -C - CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, LI, LDST ) - CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, IR, LDST ) - CALL DLACPY( 'Full', M, M, A, LDA, S, LDST ) - CALL DLACPY( 'Full', M, M, B, LDB, T, LDST ) -C -C Compute threshold for testing acceptance of swapping. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - DSCALE = ZERO - DSUM = ONE - CALL DLACPY( 'Full', M, M, S, LDST, DWORK, M ) - CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) - CALL DLACPY( 'Full', M, M, T, LDST, DWORK, M ) - CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) - DNORM = DSCALE*SQRT( DSUM ) - THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) -C - IF ( M.EQ.2 ) THEN -C -C CASE 1: Swap 1-by-1 and 1-by-1 blocks. -C -C Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks -C using Givens rotations and perform the swap tentatively. -C - F = S(2,2)*T(2,2) - T(1,1)*S(1,1) - G = -S(2,2)*T(1,2) - T(1,1)*S(1,2) - SB = ABS( T(1,1) ) - 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), LDST, T(2,1), LDST, 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(2,2), T(2,1), LI(1,1), LI(2,1), DDUM ) - LI(2,1) = -LI(2,1) - 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), 1, T(1,2), 1, LI(1,1), LI(2,1) ) - LI(2,2) = LI(1,1) - LI(1,2) = -LI(2,1) -C -C Weak stability test: -C |S21| + |T21| <= O(EPS * F-norm((S, T))). -C - WS = ABS( S(2,1) ) + ABS( T(2,1) ) - WEAK = WS.LE.THRESH - IF ( .NOT.WEAK ) - $ GO TO 50 -C - IF ( WANDS ) THEN -C -C Strong stability test: -C F-norm((A-QL'*S*QR, B-QR'*T*QL)) <= O(EPS*F-norm((A,B))). -C - CALL DLACPY( 'Full', M, M, A, LDA, DWORK(M*M+1), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ LI, LDST, S, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, - $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) - DSCALE = ZERO - DSUM = ONE - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) -C - CALL DLACPY( 'Full', M, M, B, LDB, DWORK(M*M+1), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ IR, LDST, T, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, - $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) - SS = DSCALE*SQRT( DSUM ) - DTRONG = SS.LE.THRESH - IF( .NOT.DTRONG ) - $ GO TO 50 - END IF -C -C Update A and B. -C - CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) - CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) -C -C Set N1-by-N2 (2,1) - blocks to ZERO. -C - A(2,1) = ZERO - B(2,1) = ZERO -C -C Accumulate transformations into Q and Z if requested. -C - IF ( WANTQ ) - $ CALL DROT( 2, Q(1,1), 1, Q(1,2), 1, LI(1,1), LI(2,1) ) - IF ( WANTZ ) - $ CALL DROT( 2, Z(1,1), 1, Z(1,2), 1, IR(1,1), IR(2,1) ) -C -C Exit with INFO = 0 if swap was successfully performed. -C - RETURN -C - ELSE -C -C CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 -C and 2-by-2 blocks. -C -C Solve the periodic Sylvester equation -C S11 * R - L * S22 = SCALE * S12 -C T11 * L - R * T22 = SCALE * T12 -C for R and L. Solutions in IR and LI. -C - 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 SB04OW( 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, IWORK, LINFO ) - IF ( LINFO.NE.0 ) - $ GO TO 50 -C -C Compute orthogonal matrix QL: -C -C QL' * LI = [ TL ] -C [ 0 ] -C where -C LI = [ -L ]. -C [ SCALE * identity(N2) ] -C - 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, DWORK, LINFO ) - CALL DORG2R( M, M, N2, LI, LDST, TAUL, DWORK, LINFO ) -C -C Compute orthogonal matrix RQ: -C -C IR * RQ' = [ 0 TR], -C -C where IR = [ SCALE * identity(N1), R ]. -C - DO 20 I = 1, N1 - IR(N2+I,I) = SCALE - 20 CONTINUE - CALL DGERQ2( N1, M, IR(N2+1,1), LDST, TAUR, DWORK, LINFO ) - CALL DORGR2( M, M, N1, IR, LDST, TAUR, DWORK, LINFO ) -C -C Perform the swapping tentatively: -C - CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, LI, - $ LDST, S, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, DWORK, - $ M, IR, LDST, ZERO, S, LDST ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, IR, - $ LDST, T, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ DWORK, M, LI, LDST, ZERO, T, LDST ) - CALL DLACPY( 'All', M, M, S, LDST, SCPY, LDST ) - CALL DLACPY( 'All', M, M, T, LDST, TCPY, LDST ) - CALL DLACPY( 'All', M, M, IR, LDST, IRCOP, LDST ) - CALL DLACPY( 'All', M, M, LI, LDST, LICOP, LDST ) -C -C Triangularize the B-part by a QR factorization. -C Apply transformation (from left) to A-part, giving S. -C - CALL DGEQR2( M, M, T, LDST, TAUR, DWORK, LINFO ) - CALL DORM2R( 'Right', 'No Transpose', M, M, M, T, LDST, TAUR, - $ S, LDST, DWORK, LINFO ) - CALL DORM2R( 'Left', 'Transpose', M, M, M, T, LDST, TAUR, - $ IR, LDST, DWORK, LINFO ) -C -C Compute F-norm(S21) in BRQA21. (T21 is 0.) -C - 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 ) -C -C Triangularize the B-part by an RQ factorization. -C Apply transformation (from right) to A-part, giving S. -C - CALL DGERQ2( M, M, TCPY, LDST, TAUL, DWORK, LINFO ) - CALL DORMR2( 'Left', 'No Transpose', M, M, M, TCPY, LDST, - $ TAUL, SCPY, LDST, DWORK, LINFO ) - CALL DORMR2( 'Right', 'Transpose', M, M, M, TCPY, LDST, - $ TAUL, LICOP, LDST, DWORK, LINFO ) -C -C Compute F-norm(S21) in BQRA21. (T21 is 0.) -C - 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 ) -C -C Decide which method to use. -C Weak stability test: -C F-norm(S21) <= O(EPS * F-norm((S, T))) -C - IF ( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN - CALL DLACPY( 'All', M, M, SCPY, LDST, S, LDST ) - CALL DLACPY( 'All', M, M, TCPY, LDST, T, LDST ) - CALL DLACPY( 'All', M, M, IRCOP, LDST, IR, LDST ) - CALL DLACPY( 'All', M, M, LICOP, LDST, LI, LDST ) - ELSE IF ( BRQA21.GE.THRESH ) THEN - GO TO 50 - END IF -C -C Set lower triangle of B-part to zero -C - CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) -C - IF ( WANDS ) THEN -C -C Strong stability test: -C F-norm((A-QL*S*QR', B-QR*T*QL')) <= O(EPS*F-norm((A,B))) -C - CALL DLACPY( 'All', M, M, A, LDA, DWORK(M*M+1), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, - $ LI, LDST, S, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, -ONE, - $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) - DSCALE = ZERO - DSUM = ONE - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) -C - CALL DLACPY( 'All', M, M, B, LDB, DWORK(M*M+1), M ) - CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, - $ IR, LDST, T, LDST, ZERO, DWORK, M ) - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, - $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) - CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) - SS = DSCALE*SQRT( DSUM ) - DTRONG = ( SS.LE.THRESH ) - IF( .NOT.DTRONG ) - $ GO TO 50 -C - END IF -C -C If the swap is accepted ("weakly" and "strongly"), apply the -C transformations and set N1-by-N2 (2,1)-block to zero. -C - CALL DLASET( 'All', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) -C -C Copy (S,T) to (A,B). -C - CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) - CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) - CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, T, LDST ) -C -C Standardize existing 2-by-2 blocks. -C - CALL DLASET( 'All', M, M, ZERO, ZERO, DWORK, M ) - DWORK(1) = ONE - T(1,1) = ONE - IF ( N2.GT.1 ) THEN - CALL MB03YT( A, LDA, B, LDB, AR, AI, BE, DWORK(1), DWORK(2), - $ T(1,1), T(2,1) ) - DWORK(M+1) = -DWORK(2) - DWORK(M+2) = DWORK(1) - T(N2,N2) = T(1,1) - T(1,2) = -T(2,1) - END IF - DWORK(M*M) = ONE - T(M,M) = ONE -C - IF ( N1.GT.1 ) THEN - CALL MB03YT( A(N2+1,N2+1), LDA, B(N2+1,N2+1), LDB, TAUR, - $ TAUL, DWORK(M*M+1), DWORK(N2*M+N2+1), - $ DWORK(N2*M+N2+2), T(N2+1,N2+1), T(M,M-1) ) - DWORK(M*M) = DWORK(N2*M+N2+1) - DWORK(M*M-1 ) = -DWORK(N2*M+N2+2) - T(M,M) = T(N2+1,N2+1) - T(M-1,M) = -T(M,M-1) - END IF -C - CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, - $ DWORK, M, A(1,N2+1), LDA, ZERO, DWORK(M*M+1), N2 ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, A(1,N2+1), LDA ) - CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, - $ T(1,1), LDST, B(1,N2+1), LDB, ZERO, - $ DWORK(M*M+1), N2 ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, B(1,N2+1), LDB ) - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, LI, - $ LDST, DWORK, M, ZERO, DWORK(M*M+1), M ) - CALL DLACPY( 'All', M, M, DWORK(M*M+1), M, LI, LDST ) - CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, - $ A(1,N2+1), LDA, T(N2+1,N2+1), LDST, ZERO, - $ DWORK(M*M+1), M ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, A(1,N2+1), LDA ) - CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, - $ B(1,N2+1), LDB, DWORK(N2*M+N2+1), M, ZERO, - $ DWORK(M*M+1), M ) - CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, B(1,N2+1), LDB ) - CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, T, - $ LDST, IR, LDST, ZERO, DWORK, M ) - CALL DLACPY( 'All', M, M, DWORK, M, IR, LDST ) -C -C Accumulate transformations into Q and Z if requested. -C - IF( WANTQ ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, Q, - $ LDQ, LI, LDST, ZERO, DWORK, M ) - CALL DLACPY( 'All', M, M, DWORK, M, Q, LDQ ) - END IF -C - IF( WANTZ ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, Z, - $ LDZ, IR, LDST, ZERO, DWORK, M ) - CALL DLACPY( 'Full', M, M, DWORK, M, Z, LDZ ) -C - END IF -C -C Exit with INFO = 0 if swap was successfully performed. -C - RETURN -C - END IF -C -C Exit with INFO = 1 if swap was rejected. -C - 50 CONTINUE -C - INFO = 1 - RETURN -C *** Last line of MB03WA *** - END diff --git a/slycot/src/MB03WD.f b/slycot/src/MB03WD.f deleted file mode 100644 index 76bd6780..00000000 --- a/slycot/src/MB03WD.f +++ /dev/null @@ -1,966 +0,0 @@ - SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H, - $ LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Schur decomposition and the eigenvalues of a -C product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper -C Hessenberg matrix and H_2, ..., H_p upper triangular matrices, -C without evaluating the product. Specifically, the matrices Z_i -C are computed, such that -C -C Z_1' * H_1 * Z_2 = T_1, -C Z_2' * H_2 * Z_3 = T_2, -C ... -C Z_p' * H_p * Z_1 = T_p, -C -C where T_1 is in real Schur form, and T_2, ..., T_p are upper -C triangular. -C -C The routine works primarily with the Hessenberg and triangular -C submatrices in rows and columns ILO to IHI, but optionally applies -C the transformations to all the rows and columns of the matrices -C H_i, i = 1,...,p. The transformations can be optionally -C accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = 'E': Compute the eigenvalues only; -C = 'S': Compute the factors T_1, ..., T_p of the full -C Schur form, T = T_1*T_2*...*T_p. -C -C COMPZ CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrices Z_1, ..., Z_p, as follows: -C = 'N': The matrices Z_1, ..., Z_p are not required; -C = 'I': Z_i is initialized to the unit matrix and the -C orthogonal transformation matrix Z_i is returned, -C i = 1, ..., p; -C = 'V': Z_i must contain an orthogonal matrix Q_i on -C entry, and the product Q_i*Z_i is returned, -C i = 1, ..., p. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix H. N >= 0. -C -C P (input) INTEGER -C The number of matrices in the product H_1*H_2*...*H_p. -C P >= 1. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that all matrices H_j, j = 2, ..., p, are -C already upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N, and H_1 is upper quasi-triangular in rows and -C columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0 -C (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N). -C The routine works primarily with the Hessenberg submatrix -C in rows and columns ILO to IHI, but applies the -C transformations to all the rows and columns of the -C matrices H_i, i = 1,...,p, if JOB = 'S'. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C ILOZ (input) INTEGER -C IHIZ (input) INTEGER -C Specify the rows of Z to which the transformations must be -C applied if COMPZ = 'I' or COMPZ = 'V'. -C 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. -C -C H (input/output) DOUBLE PRECISION array, dimension -C (LDH1,LDH2,P) -C On entry, the leading N-by-N part of H(*,*,1) must contain -C the upper Hessenberg matrix H_1 and the leading N-by-N -C part of H(*,*,j) for j > 1 must contain the upper -C triangular matrix H_j, j = 2, ..., p. -C On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1) -C is upper quasi-triangular in rows and columns ILO:IHI, -C with any 2-by-2 diagonal blocks corresponding to a pair of -C complex conjugated eigenvalues, and the leading N-by-N -C part of H(*,*,j) for j > 1 contains the resulting upper -C triangular matrix T_j. -C If JOB = 'E', the contents of H are unspecified on exit. -C -C LDH1 INTEGER -C The first leading dimension of the array H. -C LDH1 >= max(1,N). -C -C LDH2 INTEGER -C The second leading dimension of the array H. -C LDH2 >= max(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension -C (LDZ1,LDZ2,P) -C On entry, if COMPZ = 'V', the leading N-by-N-by-P part of -C this array must contain the current matrix Q of -C transformations accumulated by SLICOT Library routine -C MB03VY. -C If COMPZ = 'I', Z need not be set on entry. -C On exit, if COMPZ = 'V', or COMPZ = 'I', the leading -C N-by-N-by-P part of this array contains the transformation -C matrices which produced the Schur form; the -C transformations are applied only to the submatrices -C Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P. -C If COMPZ = 'N', Z is not referenced. -C -C LDZ1 INTEGER -C The first leading dimension of the array Z. -C LDZ1 >= 1, if COMPZ = 'N'; -C LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. -C -C LDZ2 INTEGER -C The second leading dimension of the array Z. -C LDZ2 >= 1, if COMPZ = 'N'; -C LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C The real and imaginary parts, respectively, of the -C computed eigenvalues ILO to IHI are stored in the -C corresponding elements of WR and WI. If two eigenvalues -C are computed as a complex conjugate pair, they are stored -C in consecutive elements of WR and WI, say the i-th and -C (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the -C eigenvalues are stored in the same order as on the -C diagonal of the Schur form returned in H. -C -C Workspace -C -C DWORK DOUBLE PRECISION work array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= IHI-ILO+P-1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, ILO <= i <= IHI, the QR algorithm -C failed to compute all the eigenvalues ILO to IHI -C in a total of 30*(IHI-ILO+1) iterations; -C the elements i+1:IHI of WR and WI contain those -C eigenvalues which have been successfully computed. -C -C METHOD -C -C A refined version of the QR algorithm proposed in [1] and [2] is -C used. The elements of the subdiagonal, diagonal, and the first -C supradiagonal of current principal submatrix of H are computed -C in the process. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. -C The periodic Schur decomposition: algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Sreedhar, J. and Van Dooren, P. -C Periodic Schur form and some matrix equations. -C Proc. of the Symposium on the Mathematical Theory of Networks -C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, -C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C FURTHER COMMENTS -C -C Note that for P = 1, the LAPACK Library routine DHSEQR could be -C more efficient on some computer architectures than this routine, -C because DHSEQR uses a block multishift QR algorithm. -C When P is large and JOB = 'S', it could be more efficient to -C compute the product matrix H, and use the LAPACK Library routines. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, -C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. -C Partly based on the routine PSHQR by A. Varga -C (DLR Oberpfaffenhofen), January 22, 1996. -C -C REVISIONS -C -C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, Hessenberg form, -C orthogonal transformation, periodic systems, (periodic) Schur -C form, real Schur form, similarity transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) - DOUBLE PRECISION DAT1, DAT2 - PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER COMPZ, JOB - INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK, - $ LDZ1, LDZ2, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION DWORK( * ), H( LDH1, LDH2, * ), WI( * ), - $ WR( * ), Z( LDZ1, LDZ2, * ) -C .. -C .. Local Scalars .. - LOGICAL INITZ, WANTT, WANTZ - INTEGER I, I1, I2, ITN, ITS, J, JMAX, JMIN, K, L, M, - $ NH, NR, NROW, NZ - DOUBLE PRECISION AVE, CS, DISC, H11, H12, H21, H22, H33, H33S, - $ H43H34, H44, H44S, HH10, HH11, HH12, HH21, HH22, - $ HP00, HP01, HP02, HP11, HP12, HP22, OVFL, S, - $ SMLNUM, SN, TAU, TST1, ULP, UNFL, V1, V2, V3 -C .. -C .. Local Arrays .. - DOUBLE PRECISION V( 3 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANHS, DLANTR - EXTERNAL DLAMCH, DLANHS, DLANTR, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DLARFX, DLARTG, - $ DLASET, DROT, MB04PY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - WANTT = LSAME( JOB, 'S' ) - INITZ = LSAME( COMPZ, 'I' ) - WANTZ = LSAME( COMPZ, 'V' ) .OR. INITZ - INFO = 0 - IF( .NOT. ( WANTT .OR. LSAME( JOB, 'E' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( WANTZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.1 ) THEN - INFO = -4 - ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -6 - ELSE IF( ILOZ.LT.1 .OR. ILOZ.GT.ILO ) THEN - INFO = -7 - ELSE IF( IHIZ.LT.IHI .OR. IHIZ.GT.N ) THEN - INFO = -8 - ELSE IF( LDH1.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDH2.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDZ1.LT.1 .OR. ( WANTZ .AND. LDZ1.LT.N ) ) THEN - INFO = -13 - ELSE IF( LDZ2.LT.1 .OR. ( WANTZ .AND. LDZ2.LT.N ) ) THEN - INFO = -14 - ELSE IF( LDWORK.LT.IHI - ILO + P - 1 ) THEN - INFO = -18 - END IF - IF( INFO.EQ.0 ) THEN - IF( ILO.GT.1 ) THEN - IF( H( ILO, ILO-1, 1 ).NE.ZERO ) - $ INFO = -5 - ELSE IF( IHI.LT.N ) THEN - IF( H( IHI+1, IHI, 1 ).NE.ZERO ) - $ INFO = -6 - END IF - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Initialize Z, if necessary. -C - IF( INITZ ) THEN -C - DO 10 J = 1, P - CALL DLASET( 'Full', N, N, ZERO, ONE, Z( 1, 1, J ), LDZ1 ) - 10 CONTINUE -C - END IF -C - NH = IHI - ILO + 1 -C - IF( NH.EQ.1 ) THEN - HP00 = ONE -C - DO 20 J = 1, P - HP00 = HP00 * H( ILO, ILO, J ) - 20 CONTINUE -C - WR( ILO ) = HP00 - WI( ILO ) = ZERO - RETURN - END IF -C -C Set machine-dependent constants for the stopping criterion. -C If norm(H) <= sqrt(OVFL), overflow should not occur. -C - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( DBLE( NH ) / ULP ) -C -C Set the elements in rows and columns ILO to IHI to zero below the -C first subdiagonal in H(*,*,1) and below the first diagonal in -C H(*,*,j), j >= 2. In the same loop, compute and store in -C DWORK(NH:NH+P-2) the 1-norms of the matrices H_2, ..., H_p, to be -C used later. -C - I = NH - S = ULP * DBLE( N ) - IF( NH.GT.2 ) - $ CALL DLASET( 'Lower', NH-2, NH-2, ZERO, ZERO, - $ H( ILO+2, ILO, 1 ), LDH1 ) -C - DO 30 J = 2, P - CALL DLASET( 'Lower', NH-1, NH-1, ZERO, ZERO, - $ H( ILO+1, ILO, J ), LDH1 ) - DWORK( I ) = S * DLANTR( '1-norm', 'Upper', 'NonUnit', NH, NH, - $ H( ILO, ILO, J ), LDH1, DWORK ) - I = I + 1 - 30 CONTINUE -C -C I1 and I2 are the indices of the first row and last column of H -C to which transformations must be applied. If eigenvalues only are -C being computed, I1 and I2 are set inside the main loop. -C - IF( WANTT ) THEN - I1 = 1 - I2 = N - END IF -C - IF( WANTZ ) - $ NZ = IHIZ - ILOZ + 1 -C -C ITN is the total number of QR iterations allowed. -C - ITN = 30*NH -C -C The main loop begins here. I is the loop index and decreases from -C IHI to ILO in steps of 1 or 2. Each iteration of the loop works -C with the active submatrix in rows and columns L to I. -C Eigenvalues I+1 to IHI have already converged. Either L = ILO or -C H(L,L-1) is negligible so that the matrix splits. -C - I = IHI -C - 40 CONTINUE - L = ILO -C -C Perform QR iterations on rows and columns ILO to I until a -C submatrix of order 1 or 2 splits off at the bottom because a -C subdiagonal element has become negligible. -C -C Let T = H_2*...*H_p, and H = H_1*T. Part of the currently -C free locations of WR and WI are temporarily used as workspace. -C -C WR(L:I): the current diagonal elements of h = H(L:I,L:I); -C WI(L+1:I): the current elements of the first subdiagonal of h; -C DWORK(NH-I+L:NH-1): the current elements of the first -C supradiagonal of h. -C - DO 160 ITS = 0, ITN -C -C Initialization: compute H(I,I) (and H(I,I-1) if I > L). -C - HP22 = ONE - IF( I.GT.L ) THEN - HP12 = ZERO - HP11 = ONE -C - DO 50 J = 2, P - HP22 = HP22*H( I, I, J ) - HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) - HP11 = HP11*H( I-1, I-1, J ) - 50 CONTINUE -C - HH21 = H( I, I-1, 1 )*HP11 - HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 -C - WR( I ) = HH22 - WI( I ) = HH21 - ELSE -C - DO 60 J = 1, P - HP22 = HP22*H( I, I, J ) - 60 CONTINUE -C - WR( I ) = HP22 - END IF -C -C Look for a single small subdiagonal element. -C The loop also computes the needed current elements of the -C diagonal and the first two supradiagonals of T, as well as -C the current elements of the central tridiagonal of H. -C - DO 80 K = I, L + 1, -1 -C -C Evaluate H(K-1,K-1), H(K-1,K) (and H(K-1,K-2) if K > L+1). -C - HP00 = ONE - HP01 = ZERO - IF( K.GT.L+1 ) THEN - HP02 = ZERO -C - DO 70 J = 2, P - HP02 = HP00*H( K-2, K, J ) + HP01*H( K-1, K, J ) - $ + HP02*H( K, K, J ) - HP01 = HP00*H( K-2, K-1, J ) + HP01*H( K-1, K-1, J ) - HP00 = HP00*H( K-2, K-2, J ) - 70 CONTINUE -C - HH10 = H( K-1, K-2, 1 )*HP00 - HH11 = H( K-1, K-2, 1 )*HP01 + H( K-1, K-1, 1 )*HP11 - HH12 = H( K-1, K-2, 1 )*HP02 + H( K-1, K-1, 1 )*HP12 - $ + H( K-1, K, 1 )*HP22 - WI( K-1 ) = HH10 - ELSE - HH10 = ZERO - HH11 = H( K-1, K-1, 1 )*HP11 - HH12 = H( K-1, K-1, 1 )*HP12 + H( K-1, K, 1 )*HP22 - END IF - WR( K-1 ) = HH11 - DWORK( NH-I+K-1) = HH12 -C -C Test for a negligible subdiagonal element. -C - TST1 = ABS( HH11 ) + ABS( HH22 ) - IF( TST1.EQ.ZERO ) - $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, - $ DWORK ) - IF( ABS( HH21 ).LE.MAX( ULP*TST1, SMLNUM ) ) - $ GO TO 90 -C -C Update the values for the next cycle. -C - HP22 = HP11 - HP11 = HP00 - HP12 = HP01 - HH22 = HH11 - HH21 = HH10 - 80 CONTINUE -C - 90 CONTINUE - L = K -C - IF( L.GT.ILO ) THEN -C -C H(L,L-1) is negligible. -C - IF( WANTT ) THEN -C -C If H(L,L-1,1) is also negligible, set it to 0; otherwise, -C annihilate the subdiagonal elements bottom-up, and -C restore the triangular form of H(*,*,j). Since H(L,L-1) -C is negligible, the second case can only appear when the -C product of H(L-1,L-1,j), j >= 2, is negligible. -C - TST1 = ABS( H( L-1, L-1, 1 ) ) + ABS( H( L, L, 1 ) ) - IF( TST1.EQ.ZERO ) - $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, - $ DWORK ) - IF( ABS( H( L, L-1, 1 ) ).GT.MAX( ULP*TST1, SMLNUM ) ) - $ THEN -C - DO 110 K = I, L, -1 -C - DO 100 J = 1, P - 1 -C -C Compute G to annihilate from the right the -C (K,K-1) element of the matrix H_j. -C - V( 1 ) = H( K, K-1, J ) - CALL DLARFG( 2, H( K, K, J ), V, 1, TAU ) - H( K, K-1, J ) = ZERO - V( 2 ) = ONE -C -C Apply G from the right to transform the columns -C of the matrix H_j in rows I1 to K-1. -C - CALL DLARFX( 'Right', K-I1, 2, V, TAU, - $ H( I1, K-1, J ), LDH1, DWORK ) -C -C Apply G from the left to transform the rows of -C the matrix H_(j+1) in columns K-1 to I2. -C - CALL DLARFX( 'Left', 2, I2-K+2, V, TAU, - $ H( K-1, K-1, J+1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix -C Z_(j+1). -C - CALL DLARFX( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, K-1, J+1 ), LDZ1, - $ DWORK ) - END IF - 100 CONTINUE -C - IF( K.LT.I ) THEN -C -C Compute G to annihilate from the right the -C (K+1,K) element of the matrix H_p. -C - V( 1 ) = H( K+1, K, P ) - CALL DLARFG( 2, H( K+1, K+1, P ), V, 1, TAU ) - H( K+1, K, P ) = ZERO - V( 2 ) = ONE -C -C Apply G from the right to transform the columns -C of the matrix H_p in rows I1 to K. -C - CALL DLARFX( 'Right', K-I1+1, 2, V, TAU, - $ H( I1, K, P ), LDH1, DWORK ) -C -C Apply G from the left to transform the rows of -C the matrix H_1 in columns K to I2. -C - CALL DLARFX( 'Left', 2, I2-K+1, V, TAU, - $ H( K, K, 1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_1. -C - CALL DLARFX( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) - END IF - END IF - 110 CONTINUE -C - H( L, L-1, P ) = ZERO - END IF - H( L, L-1, 1 ) = ZERO - END IF - END IF -C -C Exit from loop if a submatrix of order 1 or 2 has split off. -C - IF( L.GE.I-1 ) - $ GO TO 170 -C -C Now the active submatrix is in rows and columns L to I. If -C eigenvalues only are being computed, only the active submatrix -C need be transformed. -C - IF( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF -C - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN -C -C Exceptional shift. -C - S = ABS( WI( I ) ) + ABS( WI( I-1 ) ) - H44 = DAT1*S + WR( I ) - H33 = H44 - H43H34 = DAT2*S*S - ELSE -C -C Prepare to use Francis' double shift (i.e., second degree -C generalized Rayleigh quotient). -C - H44 = WR( I ) - H33 = WR( I-1 ) - H43H34 = WI( I )*DWORK( NH-1 ) - DISC = ( H33 - H44 )*HALF - DISC = DISC*DISC + H43H34 - IF( DISC.GT.ZERO ) THEN -C -C Real roots: use Wilkinson's shift twice. -C - DISC = SQRT( DISC ) - AVE = HALF*( H33 + H44 ) - IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN - H33 = H33*H44 - H43H34 - H44 = H33 / ( SIGN( DISC, AVE ) + AVE ) - ELSE - H44 = SIGN( DISC, AVE ) + AVE - END IF - H33 = H44 - H43H34 = ZERO - END IF - END IF -C -C Look for two consecutive small subdiagonal elements. -C - DO 120 M = I - 2, L, -1 -C -C Determine the effect of starting the double-shift QR -C iteration at row M, and see if this would make H(M,M-1) -C negligible. -C - H11 = WR( M ) - H12 = DWORK( NH-I+M ) - H21 = WI( M+1 ) - H22 = WR( M+1 ) - H44S = H44 - H11 - H33S = H33 - H11 - V1 = ( H33S*H44S - H43H34 ) / H21 + H12 - V2 = H22 - H11 - H33S - H44S - V3 = WI( M+2 ) - S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) - V1 = V1 / S - V2 = V2 / S - V3 = V3 / S - V( 1 ) = V1 - V( 2 ) = V2 - V( 3 ) = V3 - IF( M.EQ.L ) - $ GO TO 130 - TST1 = ABS( V1 )*( ABS( WR( M-1 ) ) + - $ ABS( H11 ) + ABS( H22 ) ) - IF( ABS( WI( M ) )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 ) - $ GO TO 130 - 120 CONTINUE -C - 130 CONTINUE -C -C Double-shift QR step. -C - DO 150 K = M, I - 1 -C -C The first iteration of this loop determines a reflection G -C from the vector V and applies it from left and right to H, -C thus creating a nonzero bulge below the subdiagonal. -C -C Each subsequent iteration determines a reflection G to -C restore the Hessenberg form in the (K-1)th column, and thus -C chases the bulge one step toward the bottom of the active -C submatrix. NR is the order of G. -C - NR = MIN( 3, I-K+1 ) - NROW = MIN( K+NR, I ) - I1 + 1 - IF( K.GT.M ) - $ CALL DCOPY( NR, H( K, K-1, 1 ), 1, V, 1 ) - CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) - IF( K.GT.M ) THEN - H( K, K-1, 1 ) = V( 1 ) - H( K+1, K-1, 1 ) = ZERO - IF( K.LT.I-1 ) - $ H( K+2, K-1, 1 ) = ZERO - ELSE IF( M.GT.L ) THEN - H( K, K-1, 1 ) = -H( K, K-1, 1 ) - END IF -C -C Apply G from the left to transform the rows of the matrix -C H_1 in columns K to I2. -C - CALL MB04PY( 'Left', NR, I2-K+1, V( 2 ), TAU, H( K, K, 1 ), - $ LDH1, DWORK ) -C -C Apply G from the right to transform the columns of the -C matrix H_p in rows I1 to min(K+NR,I). -C - CALL MB04PY( 'Right', NROW, NR, V( 2 ), TAU, H( I1, K, P ), - $ LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_1. -C - CALL MB04PY( 'Right', NZ, NR, V( 2 ), TAU, - $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) - END IF -C - DO 140 J = P, 2, -1 -C -C Apply G1 (and G2, if NR = 3) from the left to transform -C the NR-by-NR submatrix of H_j in position (K,K) to upper -C triangular form. -C -C Compute G1. -C - CALL DCOPY( NR-1, H( K+1, K, J ), 1, V, 1 ) - CALL DLARFG( NR, H( K, K, J ), V, 1, TAU ) - H( K+1, K, J ) = ZERO - IF( NR.EQ.3 ) - $ H( K+2, K, J ) = ZERO -C -C Apply G1 from the left to transform the rows of the -C matrix H_j in columns K+1 to I2. -C - CALL MB04PY( 'Left', NR, I2-K, V, TAU, H( K, K+1, J ), - $ LDH1, DWORK ) -C -C Apply G1 from the right to transform the columns of the -C matrix H_(j-1) in rows I1 to min(K+NR,I). -C - CALL MB04PY( 'Right', NROW, NR, V, TAU, H( I1, K, J-1 ), - $ LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_j. -C - CALL MB04PY( 'Right', NZ, NR, V, TAU, Z( ILOZ, K, J ), - $ LDZ1, DWORK ) - END IF -C - IF( NR.EQ.3 ) THEN -C -C Compute G2. -C - V( 1 ) = H( K+2, K+1, J ) - CALL DLARFG( 2, H( K+1, K+1, J ), V, 1, TAU ) - H( K+2, K+1, J ) = ZERO -C -C Apply G2 from the left to transform the rows of the -C matrix H_j in columns K+2 to I2. -C - CALL MB04PY( 'Left', 2, I2-K-1, V, TAU, - $ H( K+1, K+2, J ), LDH1, DWORK ) -C -C Apply G2 from the right to transform the columns of -C the matrix H_(j-1) in rows I1 to min(K+3,I). -C - CALL MB04PY( 'Right', NROW, 2, V, TAU, - $ H( I1, K+1, J-1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_j. -C - CALL MB04PY( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, K+1, J ), LDZ1, DWORK ) - END IF - END IF - 140 CONTINUE -C - 150 CONTINUE -C - 160 CONTINUE -C -C Failure to converge in remaining number of iterations. -C - INFO = I - RETURN -C - 170 CONTINUE -C - IF( L.EQ.I ) THEN -C -C H(I,I-1,1) is negligible: one eigenvalue has converged. -C Note that WR(I) has already been set. -C - WI( I ) = ZERO - ELSE IF( L.EQ.I-1 ) THEN -C -C H(I-1,I-2,1) is negligible: a pair of eigenvalues have -C converged. -C -C Transform the 2-by-2 submatrix of H_1*H_2*...*H_p in position -C (I-1,I-1) to standard Schur form, and compute and store its -C eigenvalues. If the Schur form is not required, then the -C previously stored values of a similar submatrix are used. -C For real eigenvalues, a Givens transformation is used to -C triangularize the submatrix. -C - IF( WANTT ) THEN - HP22 = ONE - HP12 = ZERO - HP11 = ONE -C - DO 180 J = 2, P - HP22 = HP22*H( I, I, J ) - HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) - HP11 = HP11*H( I-1, I-1, J ) - 180 CONTINUE -C - HH21 = H( I, I-1, 1 )*HP11 - HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 - HH11 = H( I-1, I-1, 1 )*HP11 - HH12 = H( I-1, I-1, 1 )*HP12 + H( I-1, I, 1 )*HP22 - ELSE - HH11 = WR( I-1 ) - HH12 = DWORK( NH-1 ) - HH21 = WI( I ) - HH22 = WR( I ) - END IF -C - CALL DLANV2( HH11, HH12, HH21, HH22, WR( I-1 ), WI( I-1 ), - $ WR( I ), WI( I ), CS, SN ) -C - IF( WANTT ) THEN -C -C Detect negligible diagonal elements in positions (I-1,I-1) -C and (I,I) in H_j, J > 1. -C - JMIN = 0 - JMAX = 0 -C - DO 190 J = 2, P - IF( JMIN.EQ.0 ) THEN - IF( ABS( H( I-1, I-1, J ) ).LE.DWORK( NH+J-2 ) ) - $ JMIN = J - END IF - IF( ABS( H( I, I, J ) ).LE.DWORK( NH+J-2 ) ) JMAX = J - 190 CONTINUE -C - IF( JMIN.NE.0 .AND. JMAX.NE.0 ) THEN -C -C Choose the shorter path if zero elements in both -C (I-1,I-1) and (I,I) positions are present. -C - IF( JMIN-1.LE.P-JMAX+1 ) THEN - JMAX = 0 - ELSE - JMIN = 0 - END IF - END IF -C - IF( JMIN.NE.0 ) THEN -C - DO 200 J = 1, JMIN - 1 -C -C Compute G to annihilate from the right the (I,I-1) -C element of the matrix H_j. -C - V( 1 ) = H( I, I-1, J ) - CALL DLARFG( 2, H( I, I, J ), V, 1, TAU ) - H( I, I-1, J ) = ZERO - V( 2 ) = ONE -C -C Apply G from the right to transform the columns of the -C matrix H_j in rows I1 to I-1. -C - CALL DLARFX( 'Right', I-I1, 2, V, TAU, - $ H( I1, I-1, J ), LDH1, DWORK ) -C -C Apply G from the left to transform the rows of the -C matrix H_(j+1) in columns I-1 to I2. -C - CALL DLARFX( 'Left', 2, I2-I+2, V, TAU, - $ H( I-1, I-1, J+1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Accumulate transformations in the matrix Z_(j+1). -C - CALL DLARFX( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, I-1, J+1 ), LDZ1, DWORK ) - END IF - 200 CONTINUE -C - H( I, I-1, JMIN ) = ZERO -C - ELSE - IF( JMAX.GT.0 .AND. WI( I-1 ).EQ.ZERO ) - $ CALL DLARTG( H( I-1, I-1, 1 ), H( I, I-1, 1 ), CS, SN, - $ TAU ) -C -C Apply the transformation to H. -C - CALL DROT( I2-I+2, H( I-1, I-1, 1 ), LDH1, - $ H( I, I-1, 1 ), LDH1, CS, SN ) - CALL DROT( I-I1+1, H( I1, I-1, P ), 1, H( I1, I, P ), 1, - $ CS, SN ) - IF( WANTZ ) THEN -C -C Apply transformation to Z_1. -C - CALL DROT( NZ, Z( ILOZ, I-1, 1 ), 1, Z( ILOZ, I, 1 ), - $ 1, CS, SN ) - END IF -C - DO 210 J = P, MAX( 2, JMAX+1 ), -1 -C -C Compute G1 to annihilate from the left the (I,I-1) -C element of the matrix H_j. -C - V( 1 ) = H( I, I-1, J ) - CALL DLARFG( 2, H( I-1, I-1, J ), V, 1, TAU ) - H( I, I-1, J ) = ZERO -C -C Apply G1 from the left to transform the rows of the -C matrix H_j in columns I to I2. -C - CALL MB04PY( 'Left', 2, I2-I+1, V, TAU, - $ H( I-1, I, J ), LDH1, DWORK ) -C -C Apply G1 from the right to transform the columns of -C the matrix H_(j-1) in rows I1 to I. -C - CALL MB04PY( 'Right', I-I1+1, 2, V, TAU, - $ H( I1, I-1, J-1 ), LDH1, DWORK ) -C - IF( WANTZ ) THEN -C -C Apply G1 to Z_j. -C - CALL MB04PY( 'Right', NZ, 2, V, TAU, - $ Z( ILOZ, I-1, J ), LDZ1, DWORK ) - END IF - 210 CONTINUE -C - IF( JMAX.GT.0 ) THEN - H( I, I-1, 1 ) = ZERO - H( I, I-1, JMAX ) = ZERO - ELSE - IF( HH21.EQ.ZERO ) - $ H( I, I-1, 1 ) = ZERO - END IF - END IF - END IF - END IF -C -C Decrement number of remaining iterations, and return to start of -C the main loop with new value of I. -C - ITN = ITN - ITS - I = L - 1 - IF( I.GE.ILO ) - $ GO TO 40 -C - RETURN -C -C *** Last line of MB03WD *** - END diff --git a/slycot/src/MB03WX.f b/slycot/src/MB03WX.f deleted file mode 100644 index b8c3a9e2..00000000 --- a/slycot/src/MB03WX.f +++ /dev/null @@ -1,170 +0,0 @@ - SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of a product of matrices, -C T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular -C matrix and T_2, ..., T_p are upper triangular matrices. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix T. N >= 0. -C -C P (input) INTEGER -C The number of matrices in the product T_1*T_2*...*T_p. -C P >= 1. -C -C T (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P) -C The leading N-by-N part of T(*,*,1) must contain the upper -C quasi-triangular matrix T_1 and the leading N-by-N part of -C T(*,*,j) for j > 1 must contain the upper-triangular -C matrix T_j, j = 2, ..., p. -C The elements below the subdiagonal of T(*,*,1) and below -C the diagonal of T(*,*,j), j = 2, ..., p, are not -C referenced. -C -C LDT1 INTEGER -C The first leading dimension of the array T. -C LDT1 >= max(1,N). -C -C LDT2 INTEGER -C The second leading dimension of the array T. -C LDT2 >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C The real and imaginary parts, respectively, of the -C eigenvalues of T. The eigenvalues are stored in the same -C order as on the diagonal of T_1. If T(i:i+1,i:i+1,1) is a -C 2-by-2 diagonal block with complex conjugated eigenvalues -C then WI(i) > 0 and WI(i+1) = -WI(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, periodic systems, -C real Schur form, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDT1, LDT2, N, P -C .. Array Arguments .. - DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * ) -C .. Local Scalars .. - INTEGER I, I1, INEXT, J - DOUBLE PRECISION A11, A12, A21, A22, CS, SN, T11, T12, T22 -C .. External Subroutines .. - EXTERNAL DLANV2, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( P.LT.1 ) THEN - INFO = -2 - ELSE IF( LDT1.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDT2.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB03WX', -INFO ) - RETURN - END IF -C - INEXT = 1 - DO 30 I = 1, N - IF( I.LT.INEXT ) - $ GO TO 30 - IF( I.NE.N ) THEN - IF( T( I+1, I, 1 ).NE.ZERO ) THEN -C -C A pair of eigenvalues. First compute the corresponding -C elements of T(I:I+1,I:I+1). -C - INEXT = I + 2 - I1 = I + 1 - T11 = ONE - T12 = ZERO - T22 = ONE -C - DO 10 J = 2, P - T22 = T22*T( I1, I1, J ) - T12 = T11*T( I, I1, J ) + T12*T( I1, I1, J ) - T11 = T11*T( I, I, J ) - 10 CONTINUE -C - A11 = T( I, I, 1 )*T11 - A12 = T( I, I, 1 )*T12 + T( I, I1, 1 )*T22 - A21 = T( I1, I, 1 )*T11 - A22 = T( I1, I, 1 )*T12 + T( I1, I1, 1 )*T22 -C - CALL DLANV2( A11, A12, A21, A22, WR( I ), WI( I ), - $ WR( I1 ), WI( I1 ), CS, SN ) - GO TO 30 - END IF - END IF -C -C Simple eigenvalue. Compute the corresponding element of T(I,I). -C - INEXT = I + 1 - T11 = ONE -C - DO 20 J = 1, P - T11 = T11*T( I, I, J ) - 20 CONTINUE -C - WR( I ) = T11 - WI( I ) = ZERO - 30 CONTINUE -C - RETURN -C *** Last line of MB03WX *** - END diff --git a/slycot/src/MB03XD.f b/slycot/src/MB03XD.f deleted file mode 100644 index 3b68a972..00000000 --- a/slycot/src/MB03XD.f +++ /dev/null @@ -1,826 +0,0 @@ - SUBROUTINE MB03XD( BALANC, JOB, JOBU, JOBV, N, A, LDA, QG, LDQG, - $ T, LDT, U1, LDU1, U2, LDU2, V1, LDV1, V2, LDV2, - $ WR, WI, ILO, SCALE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the eigenvalues of a Hamiltonian matrix, -C -C [ A G ] T T -C H = [ T ], G = G, Q = Q, (1) -C [ Q -A ] -C -C where A, G and Q are real n-by-n matrices. -C -C Due to the structure of H all eigenvalues appear in pairs -C (lambda,-lambda). This routine computes the eigenvalues of H -C using an algorithm based on the symplectic URV and the periodic -C Schur decompositions as described in [1], -C -C T [ T G ] -C U H V = [ T ], (2) -C [ 0 -S ] -C -C where U and V are 2n-by-2n orthogonal symplectic matrices, -C S is in real Schur form and T is upper triangular. -C -C The algorithm is backward stable and preserves the eigenvalue -C pairings in finite precision arithmetic. -C -C Optionally, a symplectic balancing transformation to improve the -C conditioning of eigenvalues is computed (see MB04DD). In this -C case, the matrix H in decomposition (2) must be replaced by the -C balanced matrix. -C -C The SLICOT Library routine MB03ZD can be used to compute invariant -C subspaces of H from the output of this routine. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Indicates how H should be diagonally scaled and/or -C permuted to reduce its norm. -C = 'N': Do not diagonally scale or permute; -C = 'P': Perform symplectic permutations to make the matrix -C closer to Hamiltonian Schur form. Do not diagonally -C scale; -C = 'S': Diagonally scale the matrix, i.e., replace A, G and -C Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where -C D is a diagonal matrix chosen to make the rows and -C columns of H more equal in norm. Do not permute; -C = 'B': Both diagonally scale and permute A, G and Q. -C Permuting does not change the norm of H, but scaling does. -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to compute the full -C decomposition (2) or the eigenvalues only, as follows: -C = 'E': compute the eigenvalues only; -C = 'S': compute matrices T and S of (2); -C = 'G': compute matrices T, S and G of (2). -C -C JOBU CHARACTER*1 -C Indicates whether or not the user wishes to compute the -C orthogonal symplectic matrix U of (2) as follows: -C = 'N': the matrix U is not computed; -C = 'U': the matrix U is computed. -C -C JOBV CHARACTER*1 -C Indicates whether or not the user wishes to compute the -C orthogonal symplectic matrix V of (2) as follows: -C = 'N': the matrix V is not computed; -C = 'V': the matrix V is computed. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, this array is overwritten. If JOB = 'S' or -C JOB = 'G', the leading N-by-N part of this array contains -C the matrix S in real Schur form of decomposition (2). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain in columns 1:N the lower triangular part of the -C matrix Q and in columns 2:N+1 the upper triangular part -C of the matrix G. -C On exit, this array is overwritten. If JOB = 'G', the -C leading N-by-N+1 part of this array contains in columns -C 2:N+1 the matrix G of decomposition (2). -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= max(1,N). -C -C T (output) DOUBLE PRECISION array, dimension (LDT,N) -C On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N -C part of this array contains the upper triangular matrix T -C of the decomposition (2). Otherwise, this array is used as -C workspace. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U1 (output) DOUBLE PRECISION array, dimension (LDU1,N) -C On exit, if JOBU = 'U', the leading N-by-N part of this -C array contains the (1,1) block of the orthogonal -C symplectic matrix U of decomposition (2). -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= 1. -C LDU1 >= N, if JOBU = 'U'. -C -C U2 (output) DOUBLE PRECISION array, dimension (LDU2,N) -C On exit, if JOBU = 'U', the leading N-by-N part of this -C array contains the (2,1) block of the orthogonal -C symplectic matrix U of decomposition (2). -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= 1. -C LDU2 >= N, if JOBU = 'U'. -C -C V1 (output) DOUBLE PRECISION array, dimension (LDV1,N) -C On exit, if JOBV = 'V', the leading N-by-N part of this -C array contains the (1,1) block of the orthogonal -C symplectic matrix V of decomposition (2). -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= 1. -C LDV1 >= N, if JOBV = 'V'. -C -C V2 (output) DOUBLE PRECISION array, dimension (LDV2,N) -C On exit, if JOBV = 'V', the leading N-by-N part of this -C array contains the (2,1) block of the orthogonal -C symplectic matrix V of decomposition (2). -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= 1. -C LDV2 >= N, if JOBV = 'V'. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C On exit, the leading N elements of WR and WI contain the -C real and imaginary parts, respectively, of N eigenvalues -C that have nonpositive real part. Complex conjugate pairs -C of eigenvalues with real part not equal to zero will -C appear consecutively with the eigenvalue having the -C positive imaginary part first. For complex conjugate pairs -C of eigenvalues on the imaginary axis only the eigenvalue -C having nonnegative imaginary part will be returned. -C -C ILO (output) INTEGER -C ILO is an integer value determined when H was balanced. -C The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1. -C The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or -C I = 1,...,ILO-1. -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C On exit, if SCALE = 'S', the leading N elements of this -C array contain details of the permutation and scaling -C factors applied when balancing H, see MB04DD. -C This array is not referenced if BALANC = 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -25, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The dimension of the array DWORK. LDWORK >= max( 1, 8*N ). -C Moreover: -C If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N', -C LDWORK >= 7*N+N*N. -C If JOB = 'G' and JOBU = 'N' and JOBV = 'N', -C LDWORK >= max( 7*N+N*N, 2*N+3*N*N ). -C If JOB = 'G' and JOBU = 'U' and JOBV = 'N', -C LDWORK >= 7*N+2*N*N. -C If JOB = 'G' and JOBU = 'N' and JOBV = 'V', -C LDWORK >= 7*N+2*N*N. -C If JOB = 'G' and JOBU = 'U' and JOBV = 'V', -C LDWORK >= 7*N+N*N. -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the periodic QR algorithm failed to -C compute all the eigenvalues, elements i+1:N of WR -C and WI contain eigenvalues which have converged. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. -C Numer. Math., Vol. 78(3), pp. 329-358, 1998. -C -C [2] Benner, P., Mehrmann, V., and Xu, H. -C A new method for computing the stable invariant subspace of a -C real Hamiltonian matrix, J. Comput. Appl. Math., vol. 86, -C pp. 17-43, 1997. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAESU). -C -C KEYWORDS -C -C Eigenvalues, invariant subspace, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC, JOB, JOBU, JOBV - INTEGER ILO, INFO, LDA, LDQG, LDT, LDU1, LDU2, LDV1, - $ LDV2, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), SCALE(*), - $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), - $ V2(LDV2,*), WI(*), WR(*) -C .. Local Scalars .. - CHARACTER UCHAR, VCHAR - LOGICAL LPERM, LSCAL, SCALEH, WANTG, WANTS, WANTU, - $ WANTV - INTEGER I, IERR, ILO1, J, K, L, PBETA, PCSL, PCSR, PDW, - $ PQ, PTAUL, PTAUR, PZ, WRKMIN, WRKOPT - DOUBLE PRECISION BIGNUM, CSCALE, EPS, HNRM, SMLNUM, TEMP, TEMPI, - $ TEMPR -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, MA02ID - EXTERNAL DLAMCH, LSAME, MA02ID -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASCL, DLASET, - $ DSCAL, MA01AD, MB03XP, MB04DD, MB04QB, MB04TB, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) - LSCAL = LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' ) - WANTS = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'G' ) - WANTG = LSAME( JOB, 'G' ) - WANTU = LSAME( JOBU, 'U' ) - WANTV = LSAME( JOBV, 'V' ) -C - IF ( WANTG ) THEN - IF ( WANTU ) THEN - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 7*N+N*N ) - ELSE - WRKMIN = MAX( 1, 7*N+2*N*N ) - END IF - ELSE - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 7*N+2*N*N ) - ELSE - WRKMIN = MAX( 1, 7*N+N*N, 2*N+3*N*N ) - END IF - END IF - ELSE - IF ( WANTU ) THEN - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 8*N ) - ELSE - WRKMIN = MAX( 1, 8*N ) - END IF - ELSE - IF ( WANTV ) THEN - WRKMIN = MAX( 1, 8*N ) - ELSE - WRKMIN = MAX( 1, 7*N+N*N ) - END IF - END IF - END IF -C - WRKOPT = WRKMIN -C -C Test the scalar input parameters. -C - IF ( .NOT.LPERM .AND. .NOT.LSCAL - $ .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN - INFO = -2 - ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -3 - ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -4 - ELSE IF ( N.LT.0 ) THEN - INFO = -5 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN - INFO = -13 - ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN - INFO = -15 - ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. LDV1.LT.N ) ) THEN - INFO = -17 - ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. LDV2.LT.N ) ) THEN - INFO = -19 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -25 - DWORK(1) = DBLE( WRKMIN ) - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03XD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - ILO = 0 - IF( N.EQ.0 ) - $ RETURN -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -C -C Scale H if maximal element is outside range [SMLNUM,BIGNUM]. -C - HNRM = MA02ID( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG, - $ DWORK ) - SCALEH = .FALSE. - IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN - SCALEH = .TRUE. - CSCALE = SMLNUM - ELSE IF( HNRM.GT.BIGNUM ) THEN - SCALEH = .TRUE. - CSCALE = BIGNUM - END IF - IF ( SCALEH ) THEN - CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR ) - CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG, - $ IERR ) - END IF -C -C Balance the matrix. -C - CALL MB04DD( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR ) -C -C Copy A to T and multiply A by -1. -C - CALL DLACPY( 'All', N, N, A, LDA, T, LDT ) - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, A, LDA, IERR ) -C -C --------------------------------------------- -C Step 1: Compute symplectic URV decomposition. -C --------------------------------------------- -C - PCSL = 1 - PCSR = PCSL + 2*N - PTAUL = PCSR + 2*N - PTAUR = PTAUL + N - PDW = PTAUR + N - - IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN -C -C Copy Q and Q' to workspace. -C - PQ = PDW - PDW = PDW + N*N - DO 20 J = 1, N - K = PQ + (N+1)*(J-1) - L = K - DWORK(K) = QG(J,J) - DO 10 I = J+1, N - K = K + 1 - L = L + N - TEMP = QG(I,J) - DWORK(K) = TEMP - DWORK(L) = TEMP - 10 CONTINUE - 20 CONTINUE - ELSE IF ( WANTU ) THEN -C -C Copy Q and Q' to U2. -C - DO 40 J = 1, N - U2(J,J) = QG(J,J) - DO 30 I = J+1, N - TEMP = QG(I,J) - U2(I,J) = TEMP - U2(J,I) = TEMP - 30 CONTINUE - 40 CONTINUE - ELSE -C -C Copy Q and Q' to V2. -C - DO 60 J = 1, N - V2(J,J) = QG(J,J) - DO 50 I = J+1, N - TEMP = QG(I,J) - V2(I,J) = TEMP - V2(J,I) = TEMP - 50 CONTINUE - 60 CONTINUE - END IF -C -C Transpose G. -C - DO 80 J = 1, N - DO 70 I = J+1, N - QG(I,J+1) = QG(J,I+1) - 70 CONTINUE - 80 CONTINUE -C - IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN - CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, - $ LDA, QG(1,2), LDQG, DWORK(PQ), N, DWORK(PCSL), - $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - ELSE IF ( WANTU ) THEN - CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, - $ LDA, QG(1,2), LDQG, U2, LDU2, DWORK(PCSL), - $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - ELSE - CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, - $ LDA, QG(1,2), LDQG, V2, LDV2, DWORK(PCSL), - $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, QG(2,1), LDQG ) - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN - IF ( N.GT.1 ) THEN - CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) - CALL DLACPY( 'Upper', N-1, N-1, V2(1,2), LDV2, QG(1,2), - $ LDQG ) - END IF - ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN - IF ( N.GT.1 ) THEN - CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, V2(2,1), LDV2 ) - CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) - END IF - ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, - $ DWORK(PDW+N*N+N), N-1 ) - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, - $ DWORK(PDW+N*N+N), N-2 ) - ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, - $ DWORK(PDW+N), N-1 ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, V2(3,1), LDV2 ) - END IF -C -C ---------------------------------------------- -C Step 2: Compute periodic Schur decomposition. -C ---------------------------------------------- -C - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) - IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN - PBETA = 1 - ELSE - PBETA = PDW - END IF -C - IF ( .NOT.WANTG ) THEN -C -C Workspace requirements: 2*N (8*N with U or V). -C - PDW = PBETA + N - IF ( WANTU ) THEN - UCHAR = 'I' - ELSE - UCHAR = 'N' - END IF - IF ( WANTV ) THEN - VCHAR = 'I' - ELSE - VCHAR = 'N' - END IF - CALL MB03XP( JOB, VCHAR, UCHAR, N, ILO, N, A, LDA, T, LDT, V1, - $ LDV1, U1, LDU1, WR, WI, DWORK(PBETA), DWORK(PDW), - $ LDWORK-PDW+1, INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 3*N*N + 2*N. -C - PQ = PBETA + N - PZ = PQ + N*N - PDW = PZ + N*N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, DWORK(PQ), N, DWORK(PZ), N, WR, WI, - $ DWORK(PBETA), DWORK(PDW), LDWORK-PDW+1, INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) - ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 2*N*N + 7*N. -C - PQ = PBETA + N - PDW = PQ + N*N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, DWORK(PQ), N, U1, LDU1, WR, WI, DWORK(PBETA), - $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, - $ INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW - $ + (N-1)*(N-1) - 1 ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), - $ LDT ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) -C - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 2*N*N + 7*N -C - PZ = PBETA + N - PDW = PZ + N*N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, V1, LDV1, DWORK(PZ), N, WR, WI, DWORK(PBETA), - $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, - $ INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW - $ + (N-1)*(N-1) - 1 ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, DWORK(PDW), N-2, A(3,1), - $ LDA ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) -C - ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: N*N + 7*N. -C - PDW = PBETA + N - CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, - $ LDT, V1, LDV1, U1, LDU1, WR, WI, DWORK(PBETA), - $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, - $ INFO ) - IF ( INFO.NE.0 ) - $ GO TO 90 - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW - $ + (N-1)*(N-1) - 1 ) - IF ( N.GT.1 ) - $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), - $ LDT ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, V2(3,1), LDV2, A(3,1), LDA ) - CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, - $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) - END IF -C - 90 CONTINUE -C -C Compute square roots of eigenvalues and rescale. -C - DO 100 I = INFO + 1, N - TEMPR = WR(I) - TEMPI = WI(I) - TEMP = DWORK(PBETA + I - 1) - IF ( TEMP.GT.ZERO ) - $ TEMPR = -TEMPR - TEMP = ABS( TEMP ) - IF ( TEMPI.EQ.ZERO ) THEN - IF ( TEMPR.LT.ZERO ) THEN - WR(I) = ZERO - WI(I) = SQRT( TEMP ) * SQRT( -TEMPR ) - ELSE - WR(I) = -SQRT( TEMP ) * SQRT( TEMPR ) - WI(I) = ZERO - END IF - ELSE - CALL MA01AD( TEMPR, TEMPI, WR(I), WI(I) ) - WR(I) = -WR(I) * SQRT( TEMP ) - IF ( TEMP.GT.0 ) THEN - WI(I) = WI(I) * SQRT( TEMP ) - ELSE - WI(I) = ZERO - END IF - END IF - 100 CONTINUE -C - IF ( SCALEH ) THEN -C -C Undo scaling. -C - CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N, N, A, LDA, - $ IERR ) - CALL DLASCL( 'Upper', 0, 0, CSCALE, HNRM, N, N, T, LDT, IERR ) - If ( WANTG ) - $ CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, N, QG(1,2), - $ LDQG, IERR ) - CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WR, N, IERR ) - CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WI, N, IERR ) - END IF -C - IF ( INFO.NE.0 ) - $ RETURN -C -C ----------------------------------------------- -C Step 3: Compute orthogonal symplectic factors. -C ----------------------------------------------- -C -C Fix CSL and CSR for MB04QB. -C - IF ( WANTU ) - $ CALL DSCAL( N, -ONE, DWORK(PCSL+1), 2 ) - IF ( WANTV ) - $ CALL DSCAL( N-1, -ONE, DWORK(PCSR+1), 2 ) - ILO1 = MIN( N, ILO + 1 ) -C - IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN -C -C Workspace requirements: 7*N. -C - PDW = PTAUR - CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) - CALL DLACPY( 'Lower', N, N, U2, LDU2, T, LDT ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ QG(ILO,ILO), LDQG, T(ILO,ILO), LDT, U1(ILO,1), - $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), - $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) - CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) -C - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN -C -C Workspace requirements: 7*N. -C - PDW = PTAUR + N - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, QG(ILO,ILO1), - $ LDQG, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, - $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN -C -C Workspace requirements: 8*N. -C - PDW = PTAUR + N - CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) - CALL DLACPY( 'Lower', N, N, V2, LDV2, T, LDT ) - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, U2(ILO,ILO1), - $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, - $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), - $ DWORK(PDW+N), LDWORK-PDW-N+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) -C - CALL DLACPY( 'Lower', N, N, U2, LDU2, QG, LDQG ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ T(ILO,ILO), LDT, QG(ILO,ILO), LDQG, U1(ILO,1), - $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), - $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) - CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) -C - ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 6*N + N*N. -C - PQ = PTAUR - PDW = PQ + N*N - CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, - $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, - $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) -C - ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 7*N + N*N. -C - PQ = PTAUR+N - PDW = PQ + N*N - CALL DLACPY( 'Upper', N, N, V2, LDV2, DWORK(PQ), N ) - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), A(ILO1,ILO), LDA, - $ DWORK(PQ+ILO*N+ILO-1), N, V1(ILO1,1), LDV1, - $ V2(ILO1,1), LDV2, DWORK(PCSR+2*ILO-2), - $ DWORK(PTAUR+ILO-1), DWORK(PDW+N), - $ LDWORK-PDW-N+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) -C - ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN -C -C Workspace requirements: 6*N + N*N. -C - PDW = PTAUR + N - CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, - $ MAX(0,N-ILO), A(ILO1,ILO), LDA, U2(ILO,ILO1), - $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, - $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - PQ = PTAUR - PDW = PQ + N*N - CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) - CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) - CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', - $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, - $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, - $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, - $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), - $ DWORK(PDW), LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) - END IF -C - DWORK(1) = DBLE( WRKOPT ) - RETURN -C *** Last line of MB03XD *** - END diff --git a/slycot/src/MB03XP.f b/slycot/src/MB03XP.f deleted file mode 100644 index bf374c25..00000000 --- a/slycot/src/MB03XP.f +++ /dev/null @@ -1,659 +0,0 @@ - SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, - $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the periodic Schur decomposition and the eigenvalues of -C a product of matrices, H = A*B, with A upper Hessenberg and B -C upper triangular without evaluating any part of the product. -C Specifically, the matrices Q and Z are computed, so that -C -C Q' * A * Z = S, Z' * B * Q = T -C -C where S is in real Schur form, and T is upper triangular. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = 'E': Compute the eigenvalues only; -C = 'S': compute the factors S and T of the full -C Schur form. -C -C COMPQ CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = 'N': The matrix Q is not required; -C = 'I': Q is initialized to the unit matrix and the -C orthogonal transformation matrix Q is returned; -C = 'V': Q must contain an orthogonal matrix U on entry, -C and the product U*Q is returned. -C -C COMPZ CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = 'N': The matrix Z is not required; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned; -C = 'V': Z must contain an orthogonal matrix U on entry, -C and the product U*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that the matrices A and B are already upper -C triangular in rows and columns 1:ILO-1 and IHI+1:N. -C The routine works primarily with the submatrices in rows -C and columns ILO to IHI, but applies the transformations to -C all the rows and columns of the matrices A and B, if -C JOB = 'S'. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array A must -C contain the upper Hessenberg matrix A. -C On exit, if JOB = 'S', the leading N-by-N part of this -C array is upper quasi-triangular with any 2-by-2 diagonal -C blocks corresponding to a pair of complex conjugated -C eigenvalues. -C If JOB = 'E', the diagonal elements and 2-by-2 diagonal -C blocks of A will be correct, but the remaining parts of A -C are unspecified on exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array B must -C contain the upper triangular matrix B. -C On exit, if JOB = 'S', the leading N-by-N part of this -C array contains the transformed upper triangular matrix. -C 2-by-2 blocks in B corresponding to 2-by-2 blocks in A -C will be reduced to positive diagonal form. (I.e., if -C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) -C and B(j+1,j+1) will be positive.) -C If JOB = 'E', the elements corresponding to diagonal -C elements and 2-by-2 diagonal blocks in A will be correct, -C but the remaining parts of B are unspecified on exit. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if COMPQ = 'V', then the leading N-by-N part of -C this array must contain a matrix Q which is assumed to be -C equal to the unit matrix except for the submatrix -C Q(ILO:IHI,ILO:IHI). -C If COMPQ = 'I', Q need not be set on entry. -C On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N -C part of this array contains the transformation matrix -C which produced the Schur form. -C If COMPQ = 'N', Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If COMPQ <> 'N', LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if COMPZ = 'V', then the leading N-by-N part of -C this array must contain a matrix Z which is assumed to be -C equal to the unit matrix except for the submatrix -C Z(ILO:IHI,ILO:IHI). -C If COMPZ = 'I', Z need not be set on entry. -C On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N -C part of this array contains the transformation matrix -C which produced the Schur form. -C If COMPZ = 'N', Z is not referenced. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If COMPZ <> 'N', LDZ >= MAX(1,N). -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C The i-th (1 <= i <= N) computed eigenvalue is given by -C BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two -C eigenvalues are computed as a complex conjugate pair, -C they are stored in consecutive elements of ALPHAR, ALPHAI -C and BETA. If JOB = 'S', the eigenvalues are stored in the -C same order as on the diagonales of the Schur forms of A -C and B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then MB03XP failed to compute the Schur -C form in a total of 30*(IHI-ILO+1) iterations; -C elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and -C BETA contain successfully computed eigenvalues. -C -C METHOD -C -C The implemented algorithm is a multi-shift version of the periodic -C QR algorithm described in [1,3] with some minor modifications -C proposed in [2]. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. -C The periodic Schur decomposition: Algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Kressner, D. -C An efficient and reliable implementation of the periodic QZ -C algorithm. Proc. of the IFAC Workshop on Periodic Control -C Systems, pp. 187-192, 2001. -C -C [3] Van Loan, C. -C Generalized Singular Values with Algorithms and Applications. -C Ph. D. Thesis, University of Michigan, 1973. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C backward stable. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHGPQR). -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal -C transformation, (periodic) Schur form -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - INTEGER NSMAX, LDAS, LDBS - PARAMETER ( NSMAX = 15, LDAS = NSMAX, LDBS = NSMAX ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOB - INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDWORK, LDZ, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL INITQ, INITZ, WANTQ, WANTT, WANTZ - INTEGER DUM, I, I1, I2, IERR, ITEMP, ITN, ITS, J, K, - $ KK, L, MAXB, NH, NR, NS, NV, PV2, PV3 - DOUBLE PRECISION OVFL, SMLNUM, TAUV, TAUW, TEMP, TST, ULP, UNFL -C .. Local Arrays .. - INTEGER ISEED(4) - DOUBLE PRECISION AS(LDAS,LDAS), BS(LDBS,LDBS), V(3*NSMAX+6) -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX, UE01MD - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, IDAMAX, LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLACPY, DLARFG, - $ DLARFX, DLARNV, DLASET, DSCAL, DTRMV, MB03YA, - $ MB03YD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - WANTT = LSAME( JOB, 'S' ) - INITQ = LSAME( COMPQ, 'I' ) - WANTQ = INITQ.OR.LSAME( COMPQ, 'V' ) - INITZ = LSAME( COMPZ, 'I' ) - WANTZ = INITZ.OR.LSAME( COMPZ, 'V' ) -C -C Check the scalar input parameters. -C - INFO = 0 - IF ( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN - INFO = -1 - ELSE IF ( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN - INFO = -2 - ELSE IF ( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN - INFO = -3 - ELSE IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF ( IHI.LT.MIN( ILO,N ).OR.IHI.GT.N ) THEN - INFO = -6 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN - INFO = -12 - ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN - INFO = -14 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -19 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03XP', -INFO ) - RETURN - END IF -C -C Initialize Q and Z, if necessary. -C - IF ( INITQ ) - $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) - IF ( INITZ ) - $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) -C -C Store isolated eigenvalues and standardize B. -C -C FOR I = [1:ILO-1, IHI+1:N] - I = 1 - 10 CONTINUE - IF ( I.EQ.ILO ) THEN - I = IHI+1 - END IF - IF ( I.LE.N ) THEN - IF ( B(I,I).LT.ZERO ) THEN - IF ( WANTT ) THEN - DO 20 K = ILO, I - B(K,I) = -B(K,I) - 20 CONTINUE - DO 30 K = I, IHI - A(I,K) = -A(I,K) - 30 CONTINUE - ELSE - B(I,I) = -B(I,I) - A(I,I) = -A(I,I) - END IF - IF ( WANTQ ) THEN - DO 40 K = ILO, IHI - Q(K,I) = -Q(K,I) - 40 CONTINUE - END IF - END IF - ALPHAR(I) = A(I,I) - ALPHAI(I) = ZERO - BETA(I) = B(I,I) - I = I + 1 -C END FOR - GO TO 10 - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. ILO.EQ.IHI+1 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Set rows and coloms ILO to IHI of B (A) to zero below the first -C (sub)diagonal. -C - DO 60 J = ILO, IHI - 2 - DO 50 I = J + 2, N - A(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - DO 80 J = ILO, IHI - 1 - DO 70 I = J + 1, N - B(I,J) = ZERO - 70 CONTINUE - 80 CONTINUE - NH = IHI - ILO + 1 -C -C Suboptimal choice of the number of shifts. -C - IF ( WANTQ ) THEN - NS = UE01MD( 4, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) - MAXB = UE01MD( 8, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) - ELSE - NS = UE01MD( 4, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) - MAXB = UE01MD( 8, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) - END IF -C - IF ( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN -C -C Standard double-shift product QR. -C - CALL MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILO, IHI, A, - $ LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, - $ DWORK, LDWORK, INFO ) - RETURN - END IF - MAXB = MAX( 3, MAXB ) - NS = MIN( NS, MAXB, NSMAX ) -C -C Set machine-dependent constants for the stopping criterion. -C If max(norm(A),norm(B)) <= sqrt(OVFL), then overflow should not -C occur. -C - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( DBLE( NH ) / ULP ) -C -C I1 and I2 are the indices of the first rows and last columns of -C A and B to which transformations must be applied. -C - IF ( WANTT ) THEN - I1 = 1 - I2 = N - END IF - ISEED(1) = 1 - ISEED(2) = 0 - ISEED(3) = 0 - ISEED(4) = 1 -C -C ITN is the maximal number of QR iterations. -C - ITN = 30*NH - DUM = 0 -C -C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO -C or A(L,L-1) is negligible. -C - I = IHI - 90 CONTINUE - L = ILO - IF ( I.LT.ILO ) - $ GO TO 210 -C - DO 190 ITS = 0, ITN - DUM = DUM + (IHI-ILO)*(IHI-ILO) -C -C Look for deflations in A. -C - DO 100 K = I, L + 1, -1 - TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) - IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 110 - 100 CONTINUE - 110 CONTINUE -C -C Look for deflation in B if problem size is greater than 1. -C - IF ( I-K.GE.1 ) THEN - DO 120 KK = I, K, -1 - IF ( KK.EQ.I ) THEN - TST = ABS( B(KK-1,KK) ) - ELSE IF ( KK.EQ.K ) THEN - TST = ABS( B(KK,KK+1) ) - ELSE - TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) - END IF - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) - IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 130 - 120 CONTINUE - ELSE - KK = K-1 - END IF - 130 CONTINUE - IF ( KK.GE.K ) THEN -C -C B has an element close to zero at position (KK,KK). -C - B(KK,KK) = ZERO - CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILO, IHI, KK, - $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) - K = KK+1 - END IF - L = K - IF( L.GT.ILO ) THEN -C -C A(L,L-1) is negligible. -C - A(L,L-1) = ZERO - END IF -C -C Exit from loop if a submatrix of order <= MAXB has split off. -C - IF ( L.GE.I-MAXB+1 ) - $ GO TO 200 -C -C The active submatrices are now in rows and columns L:I. -C - IF ( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF - IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN -C -C Exceptional shift. The first column of the shift polynomial -C is a pseudo-random vector. -C - CALL DLARNV( 3, ISEED, NS+1, V ) - ELSE -C -C Use eigenvalues of trailing submatrix as shifts. -C - CALL DLACPY( 'Full', NS, NS, A(I-NS+1,I-NS+1), LDA, AS, - $ LDAS ) - CALL DLACPY( 'Full', NS, NS, B(I-NS+1,I-NS+1), LDB, BS, - $ LDBS ) - CALL MB03YD( .FALSE., .FALSE., .FALSE., NS, 1, NS, 1, NS, - $ AS, LDAS, BS, LDBS, Q, LDQ, Z, LDZ, - $ ALPHAR(I-NS+1), ALPHAI(I-NS+1), BETA(I-NS+1), - $ DWORK, LDWORK, IERR ) - END IF -C -C Compute the nonzero elements of the first column of -C (A*B-w(1)) (A*B-w(2)) .. (A*B-w(ns)). -C - V(1) = ONE - NV = 1 -C WHILE NV <= NS - 140 CONTINUE - IF ( NV.LE.NS ) THEN - IF ( NV.EQ.NS .OR. AS(NV+1,NV).EQ.ZERO ) THEN -C -C Real shift. -C - V(NV+1) = ZERO - PV2 = NV+2 - CALL DCOPY( NV, V, 1, V(PV2), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', - $ NV, B(L,L), LDB, V(PV2), 1 ) - CALL DSCAL( NV, BS(NV,NV), V, 1 ) - ITEMP = IDAMAX( 2*NV+1, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+1, TEMP, V, 1 ) - CALL DGEMV( 'No transpose', NV+1, NV, ONE, A(L,L), LDA, - $ V(PV2), 1, -AS(NV,NV), V, 1 ) - NV = NV + 1 - ELSE -C -C Double shift using a product formulation of the shift -C polynomial [2]. -C - V(NV+1) = ZERO - V(NV+2) = ZERO - PV2 = NV+3 - PV3 = 2*NV+5 - CALL DCOPY( NV+2, V, 1, V(PV2), 1 ) - CALL DCOPY( NV+1, V, 1, V(PV3), 1 ) - CALL DSCAL( NV, BS(NV+1,NV+1), V(PV2), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', - $ NV, B(L,L), LDB, V(PV3), 1 ) - ITEMP = IDAMAX( 2*NV+3, V(PV2), 1 ) - TEMP = ONE / MAX( ABS( V(PV2+ITEMP-1) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V(PV2), 1 ) -C - CALL DCOPY( NV, V(PV2), 1, V, 1 ) - CALL DGEMV( 'No transpose', NV+1, NV, -ONE, A(L,L), LDA, - $ V(PV3), 1, AS(NV+1,NV+1), V(PV2), 1 ) - CALL DSCAL( NV, AS(NV,NV+1), V, 1 ) - ITEMP = IDAMAX( 2*NV+3, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V, 1 ) -C - CALL DSCAL( NV, -AS(NV+1,NV), V, 1 ) - CALL DAXPY( NV+1, AS(NV,NV), V(PV2), 1, V, 1) - ITEMP = IDAMAX( 2*NV+3, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V, 1 ) -C - CALL DSCAL( NV+1, BS(NV,NV), V, 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', - $ NV+1, B(L,L), LDB, V(PV2), 1 ) - ITEMP = IDAMAX( 2*NV+3, V, 1 ) - TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) - CALL DSCAL( 2*NV+3, TEMP, V, 1 ) -C - CALL DGEMV( 'No transpose', NV+2, NV+1, -ONE, A(L,L), - $ LDA, V(PV2), 1, ONE, V, 1 ) - NV = NV + 2 - END IF - ITEMP = IDAMAX( NV, V, 1 ) - TEMP = ABS( V(ITEMP) ) - IF ( TEMP.EQ.ZERO ) THEN - V(1) = ONE - DO 150 K = 2, NV - V(K) = ZERO - 150 CONTINUE - ELSE - TEMP = MAX( TEMP, SMLNUM ) - CALL DSCAL( NV, ONE/TEMP, V, 1 ) - END IF - GO TO 140 -C END WHILE - END IF -C -C Multi-shift product QR step. -C - PV2 = NS+2 - DO 180 K = L,I-1 - NR = MIN( NS+1,I-K+1 ) - IF ( K.GT.L ) - $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) - CALL DLARFG( NR, V(1), V(2), 1, TAUV ) - IF ( K.GT.L ) THEN - A(K,K-1) = V(1) - DO 160 KK = K+1,I - A(KK,K-1) = ZERO - 160 CONTINUE - END IF -C -C Apply reflector V from the right to B in rows -C I1:min(K+NS,I). -C - V(1) = ONE - CALL DLARFX( 'Right', MIN(K+NS,I)-I1+1, NR, V, TAUV, - $ B(I1,K), LDB, DWORK ) -C -C Annihilate the introduced nonzeros in the K-th column. -C - CALL DCOPY( NR, B(K,K), 1, V(PV2), 1 ) - CALL DLARFG( NR, V(PV2), V(PV2+1), 1, TAUW ) - B(K,K) = V(PV2) - DO 170 KK = K+1,I - B(KK,K) = ZERO - 170 CONTINUE - V(PV2) = ONE -C -C Apply reflector W from the left to transform the rows of the -C matrix B in columns K+1:I2. -C - CALL DLARFX( 'Left', NR, I2-K, V(PV2), TAUW, B(K,K+1), LDB, - $ DWORK ) -C -C Apply reflector V from the left to transform the rows of the -C matrix A in columns K:I2. -C - CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, - $ DWORK ) -C -C Apply reflector W from the right to transform the columns of -C the matrix A in rows I1:min(K+NS,I). -C - CALL DLARFX( 'Right', MIN(K+NS+1,I)-I1+1, NR, V(PV2), TAUW, - $ A(I1,K), LDA, DWORK ) -C -C Accumulate transformations in the matrices Q and Z. -C - IF ( WANTQ ) - $ CALL DLARFX( 'Right', NH, NR, V, TAUV, Q(ILO,K), LDQ, - $ DWORK ) - IF ( WANTZ ) - $ CALL DLARFX( 'Right', NH, NR, V(PV2), TAUW, Z(ILO,K), - $ LDZ, DWORK ) - 180 CONTINUE - 190 CONTINUE -C -C Failure to converge. -C - INFO = I - RETURN - 200 CONTINUE -C -C Submatrix of order <= MAXB has split off. Use double-shift -C periodic QR algorithm. -C - CALL MB03YD( WANTT, WANTQ, WANTZ, N, L, I, ILO, IHI, A, LDA, B, - $ LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, - $ LDWORK, INFO ) - IF ( INFO.GT.0 ) - $ RETURN - ITN = ITN - ITS - I = L - 1 - GO TO 90 -C - 210 CONTINUE - DWORK(1) = DBLE( MAX( 1,N ) ) - RETURN -C *** Last line of MB03XP *** - END diff --git a/slycot/src/MB03XU.f b/slycot/src/MB03XU.f deleted file mode 100644 index b25d49da..00000000 --- a/slycot/src/MB03XU.f +++ /dev/null @@ -1,2338 +0,0 @@ - SUBROUTINE MB03XU( LTRA, LTRB, N, K, NB, A, LDA, B, LDB, G, LDG, - $ Q, LDQ, XA, LDXA, XB, LDXB, XG, LDXG, XQ, LDXQ, - $ YA, LDYA, YB, LDYB, YG, LDYG, YQ, LDYQ, CSL, - $ CSR, TAUL, TAUR, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n) -C matrix H: -C -C [ op(A) G ] -C H = [ ], -C [ Q op(B) ] -C -C so that elements in the first nb columns below the k-th -C subdiagonal of the (k+n)-by-n matrix op(A), in the first nb -C columns and rows of the n-by-n matrix Q and in the first nb rows -C above the diagonal of the n-by-(k+n) matrix op(B) are zero. -C The reduction is performed by orthogonal symplectic -C transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA, -C XB, XG, and XQ are returned so that -C -C [ op(Aout)+U*YA'+XA*V' G+U*YG'+XG*V' ] -C UU' H VV = [ ]. -C [ Qout+U*YQ'+XQ*V' op(Bout)+U*YB'+XB*V' ] -C -C This is an auxiliary routine called by MB04TB. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRA LOGICAL -C Specifies the form of op( A ) as follows: -C = .FALSE.: op( A ) = A; -C = .TRUE.: op( A ) = A'. -C -C LTRB LOGICAL -C Specifies the form of op( B ) as follows: -C = .FALSE.: op( B ) = B; -C = .TRUE.: op( B ) = B'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix Q. N >= 0. -C -C K (input) INTEGER -C The offset of the reduction. Elements below the K-th -C subdiagonal in the first NB columns of op(A) are -C reduced to zero. K >= 0. -C -C NB (input) INTEGER -C The number of columns/rows to be reduced. N > NB >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,N) if LTRA = .FALSE. -C (LDA,K+N) if LTRA = .TRUE. -C On entry with LTRA = .FALSE., the leading (K+N)-by-N part -C of this array must contain the matrix A. -C On entry with LTRA = .TRUE., the leading N-by-(K+N) part -C of this array must contain the matrix A. -C On exit with LTRA = .FALSE., the leading (K+N)-by-N part -C of this array contains the matrix Aout and, in the zero -C parts, information about the elementary reflectors used to -C compute the reduction. -C On exit with LTRA = .TRUE., the leading N-by-(K+N) part of -C this array contains the matrix Aout and in the zero parts -C information about the elementary reflectors. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,K+N), if LTRA = .FALSE.; -C LDA >= MAX(1,N), if LTRA = .TRUE.. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,K+N) if LTRB = .FALSE. -C (LDB,N) if LTRB = .TRUE. -C On entry with LTRB = .FALSE., the leading N-by-(K+N) part -C of this array must contain the matrix B. -C On entry with LTRB = .TRUE., the leading (K+N)-by-N part -C of this array must contain the matrix B. -C On exit with LTRB = .FALSE., the leading N-by-(K+N) part -C of this array contains the matrix Bout and, in the zero -C parts, information about the elementary reflectors used to -C compute the reduction. -C On exit with LTRB = .TRUE., the leading (K+N)-by-N part of -C this array contains the matrix Bout and in the zero parts -C information about the elementary reflectors. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N), if LTRB = .FALSE.; -C LDB >= MAX(1,K+N), if LTRB = .TRUE.. -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix G. -C On exit, the leading N-by-N part of this array contains -C the matrix Gout. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix Q. -C On exit, the leading N-by-N part of this array contains -C the matrix Qout and in the zero parts information about -C the elementary reflectors used to compute the reduction. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XA. -C -C LDXA INTEGER -C The leading dimension of the array XA. LDXA >= MAX(1,N). -C -C XB (output) DOUBLE PRECISION array, dimension (LDXB,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix XB. -C -C LDXB INTEGER -C The leading dimension of the array XB. LDXB >= MAX(1,K+N). -C -C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix XG. -C -C LDXG INTEGER -C The leading dimension of the array XG. LDXG >= MAX(1,K+N). -C -C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XQ. -C -C LDXQ INTEGER -C The leading dimension of the array XQ. LDXQ >= MAX(1,N). -C -C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix YA. -C -C LDYA INTEGER -C The leading dimension of the array YA. LDYA >= MAX(1,K+N). -C -C YB (output) DOUBLE PRECISION array, dimension (LDYB,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix YB. -C -C LDYB INTEGER -C The leading dimension of the array YB. LDYB >= MAX(1,N). -C -C YG (output) DOUBLE PRECISION array, dimension (LDYG,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix YG. -C -C LDYG INTEGER -C The leading dimension of the array YG. LDYG >= MAX(1,K+N). -C -C YQ (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix YQ. -C -C LDYQ INTEGER -C The leading dimension of the array YQ. LDYQ >= MAX(1,N). -C -C CSL (output) DOUBLE PRECISION array, dimension (2*NB) -C On exit, the first 2NB elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the left-hand side used to compute the -C reduction. -C -C CSR (output) DOUBLE PRECISION array, dimension (2*NB) -C On exit, the first 2NB-2 elements of this array contain -C the cosines and sines of the symplectic Givens rotations -C applied from the right-hand side used to compute the -C reduction. -C -C TAUL (output) DOUBLE PRECISION array, dimension (NB) -C On exit, the first NB elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the left-hand side. -C -C TAUR (output) DOUBLE PRECISION array, dimension (NB) -C On exit, the first NB-1 elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (5*NB) -C -C METHOD -C -C For details regarding the representation of the orthogonal -C symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q, -C TAUL and TAUR see the description of MB04TB. -C -C The contents of A, B, G and Q on exit are illustrated by the -C following example with op(A) = A, op(B) = B, n = 5, k = 2 and -C nb = 2: -C -C ( a r r a a ) ( g g g r r g g ) -C ( a r r a a ) ( g g g r r g g ) -C ( r r r r r ) ( r r r r r r r ) -C A = ( u2 r r r r ), G = ( r r r r r r r ), -C ( u2 u2 r a a ) ( g g g r r g g ) -C ( u2 u2 r a a ) ( g g g r r g g ) -C ( u2 u2 r a a ) ( g g g r r g g ) -C -C ( t t v1 v1 v1 ) ( r r r r r v2 v2 ) -C ( u1 t t v1 v1 ) ( r r r r r r v2 ) -C Q = ( u1 u1 r q q ), B = ( b b b r r b b ). -C ( u1 u1 r q q ) ( b b b r r b b ) -C ( u1 u1 r q q ) ( b b b r r b b ) -C -C where a, b, g and q denote elements of the original matrices, r -C denotes a modified element, t denotes a scalar factor of an -C applied elementary reflector, ui and vi denote elements of the -C matrices U and V, respectively. -C -C NUMERICAL ASPECTS -C -C The algorithm requires ( 16*K + 32*N + 42 )*N*NB + -C ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point -C operations and is numerically backward stable. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. -C Numer. Math., Vol. 78 (3), pp. 329-358, 1998. -C -C [2] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLASUB). -C -C KEYWORDS -C -C Elementary matrix operations, Matrix decompositions, Hamiltonian -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL LTRA, LTRB - INTEGER K, LDA, LDB, LDG, LDQ, LDXA, LDXB, LDXG, LDXQ, - $ LDYA, LDYB, LDYG, LDYQ, N, NB -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), - $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*), - $ XA(LDXA,*), XB(LDXB,*), XG(LDXG,*), XQ(LDXQ,*), - $ YA(LDYA,*), YB(LDYB,*), YG(LDYG,*), YQ(LDYQ,*) -C .. Local Scalars .. - INTEGER I, J, NB1, NB2, NB3, PDW - DOUBLE PRECISION ALPHA, C, S, TAUQ, TEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( N+K.LE.0 ) THEN - RETURN - END IF -C - NB1 = NB + 1 - NB2 = NB + NB - NB3 = NB2 + NB - PDW = NB3 + NB + 1 -C - IF ( LTRA.AND.LTRB ) THEN - DO 90 I = 1, NB -C -C Transform first row/column of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) - TEMP = A(I,K+I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) - CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) - TEMP = A(I,K+I) - A(I,K+I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) -C -C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(:,i). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(1,K+I), 1, ONE, B(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) -C -C Apply rotation to [ G(k+i,:); B(:,i)' ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) -C - DO 10 J = 1, I-1 - YG(K+I,J) = ZERO - 10 CONTINUE - DO 20 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 20 CONTINUE - DO 30 J = 1, I-1 - YA(K+I,J) = ZERO - 30 CONTINUE - DO 40 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 40 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(:,i). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) -C - A(I,K+I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first row/column of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - TEMP = B(K+I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) - S = -S - CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) - TEMP = B(K+I+1,I) - B(K+I+1,I) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) - DO 50 J = 1, I - XB(K+I+1,J) = ZERO - 50 CONTINUE - DO 60 J = 1, I - XB(K+I+1,NB+J) = ZERO - 60 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), - $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(K+I+1,1), LDB, ONE, A(I+1,1), LDA ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) - DO 70 J = 1, I - XG(K+I+1,J) = ZERO - 70 CONTINUE - DO 80 J = 1, I - XG(K+I+1,NB+J) = ZERO - 80 CONTINUE -C -C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(K+I+1,I) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 90 CONTINUE - ELSE IF ( LTRA ) THEN - DO 180 I = 1, NB -C -C Transform first row/column of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) - TEMP = A(I,K+I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) - CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) - TEMP = A(I,K+I) - A(I,K+I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) -C -C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, - $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), - $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(i+1:n,k+i). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(I,1), LDB ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(1,K+I), 1, ONE, B(I,1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) -C -C Apply rotation to [ G(k+i,:); B(i,:) ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) -C - DO 100 J = 1, I-1 - YG(K+I,J) = ZERO - 100 CONTINUE - DO 110 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 110 CONTINUE - DO 120 J = 1, I-1 - YA(K+I,J) = ZERO - 120 CONTINUE - DO 130 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 130 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(i,:). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) -C - A(I,K+I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first rows of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - TEMP = B(I,K+I+1) - CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) - S = -S - CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) - TEMP = B(I,K+I+1) - B(I,K+I+1) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) - DO 140 J = 1, I - XB(K+I+1,J) = ZERO - 140 CONTINUE - DO 150 J = 1, I - XB(K+I+1,NB+J) = ZERO - 150 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), - $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(1,K+I+1), 1, ONE, A(I+1,1), LDA ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) - DO 160 J = 1, I - XG(K+I+1,J) = ZERO - 160 CONTINUE - DO 170 J = 1, I - XG(K+I+1,NB+J) = ZERO - 170 CONTINUE -C -C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, - $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(i+1,1:k+n). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(I,K+I+1) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 180 CONTINUE -C - ELSE IF ( LTRB ) THEN - DO 270 I = 1, NB -C -C Transform first columns of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) - TEMP = A(K+I,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) - CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) - TEMP = A(K+I,I) - A(K+I,I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) -C -C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(:,i). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(K+I,1), LDA, ONE, B(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) -C -C Apply rotation to [ G(k+i,:); B(:,i)' ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) -C - DO 190 J = 1, I-1 - YG(K+I,J) = ZERO - 190 CONTINUE - DO 200 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 200 CONTINUE - DO 210 J = 1, I-1 - YA(K+I,J) = ZERO - 210 CONTINUE - DO 220 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 220 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, - $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(:,i). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) -C - A(K+I,I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first rows of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) - TEMP = B(K+I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) - S = -S - CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) - TEMP = B(K+I+1,I) - B(K+I+1,I) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) - DO 230 J = 1, I - XB(K+I+1,J) = ZERO - 230 CONTINUE - DO 240 J = 1, I - XB(K+I+1,NB+J) = ZERO - 240 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), - $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), - $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(k+i+1,i+1:n). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(K+I+1,1), LDB, ONE, A(1,I+1), 1 ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) - DO 250 J = 1, I - XG(K+I+1,J) = ZERO - 250 CONTINUE - DO 260 J = 1, I - XG(K+I+1,NB+J) = ZERO - 260 CONTINUE -C -C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(K+I+1,I) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 270 CONTINUE -C - ELSE - DO 360 I = 1, NB -C -C Transform first columns of A and Q. See routine MB04TS. -C - ALPHA = Q(I,I) - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) - Q(I,I) = ONE - TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) - CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) - TEMP = A(K+I,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) - CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) - TEMP = A(K+I,I) - A(K+I,I) = ONE -C -C Update XQ with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, - $ Q(I,I), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, - $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, - $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) -C -C Update XA with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, - $ Q(I,I), 1, ZERO, XA(1,I), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) -C -C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. -C - CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) -C -C Update XQ with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, - $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, - $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) -C -C Update Q(i,i+1:n). -C - CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) -C -C Update XA with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, - $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) -C -C Update A(k+i,i+1:n). -C - CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) -C -C Update XG with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ Q(I,I), 1, ZERO, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) -C -C Update G(k+i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) -C -C Update XB with first Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ Q(I,I), 1, ZERO, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, - $ DWORK, 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, - $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) -C -C Update B(i,:). -C - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ Q(I,1), LDQ, ONE, B(I,1), LDB ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, A(K+I,1), LDA, ONE, B(I,1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) -C -C Apply rotation to [ G(k+i,:); B(i,:) ]. -C - CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) -C - DO 280 J = 1, I-1 - YG(K+I,J) = ZERO - 280 CONTINUE - DO 290 J = 1, I-1 - YG(K+I,NB+J) = ZERO - 290 CONTINUE - DO 300 J = 1, I-1 - YA(K+I,J) = ZERO - 300 CONTINUE - DO 310 J = 1, I-1 - YA(K+I,NB+J) = ZERO - 310 CONTINUE -C -C Update XG with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, - $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) -C -C Update G(k+i,:). -C - CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) -C -C Update XB with second Householder reflection. -C - CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, - $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, - $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), - $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, - $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) -C -C Update B(i,:). -C - CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) -C - A(K+I,I) = TEMP - Q(I,I) = TAUQ - CSL(2*I-1) = C - CSL(2*I) = S -C -C Transform first rows of Q and B. -C - ALPHA = Q(I,I+1) - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) - Q(I,I+1) = ONE - TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) - TEMP = B(I,K+I+1) - CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) - S = -S - CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) - TEMP = B(I,K+I+1) - B(I,K+I+1) = ONE -C -C Update YB with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, - $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, - $ DWORK, 1, ONE, YB(I+1,I), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, - $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) -C -C Update YQ with first Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, - $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, - $ DWORK, 1, ONE, YQ(I+1,I), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) - CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) -C -C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. -C - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) - DO 320 J = 1, I - XB(K+I+1,J) = ZERO - 320 CONTINUE - DO 330 J = 1, I - XB(K+I+1,NB+J) = ZERO - 330 CONTINUE -C -C Update YB with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), - $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, - $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, - $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, - $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), - $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), - $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) -C -C Update B(i+1:n,k+i+1). -C - CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) -C -C Update YQ with second Householder reflection. -C - CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, - $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, - $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, - $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), - $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) - CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) -C -C Update Q(i+1:n,i+1). -C - CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) -C -C Update YA with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ B(1,K+I+1), 1, ONE, A(1,I+1), 1 ) -C -C Update YG with first Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, - $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, - $ DWORK, 1, ONE, YG(1,I), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) - CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) - DO 340 J = 1, I - XG(K+I+1,J) = ZERO - 340 CONTINUE - DO 350 J = 1, I - XG(K+I+1,NB+J) = ZERO - 350 CONTINUE -C -C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. -C - CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) -C -C Update YA with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) -C -C Update A(1:k+n,i+1). -C - CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) -C -C Update YG with second Householder reflection. -C - CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, - $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, - $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) - CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, - $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, - $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, - $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) - CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) -C -C Update G(1:k+n,k+i+1). -C - CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) -C - B(I,K+I+1) = TEMP - Q(I,I+1) = TAUQ - CSR(2*I-1) = C - CSR(2*I) = S - 360 CONTINUE - END IF -C - RETURN -C *** Last line of MB03XU *** - END diff --git a/slycot/src/MB03YA.f b/slycot/src/MB03YA.f deleted file mode 100644 index 0a87c7c3..00000000 --- a/slycot/src/MB03YA.f +++ /dev/null @@ -1,297 +0,0 @@ - SUBROUTINE MB03YA( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, - $ POS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To annihilate one or two entries on the subdiagonal of the -C Hessenberg matrix A for dealing with zero elements on the diagonal -C of the triangular matrix B. -C -C MB03YA is an auxiliary routine called by SLICOT Library routines -C MB03XP and MB03YD. -C -C ARGUMENTS -C -C Mode Parameters -C -C WANTT LOGICAL -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = .TRUE. : Compute the full Schur form; -C = .FALSE.: compute the eigenvalues only. -C -C WANTQ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = .TRUE. : The matrix Q is updated; -C = .FALSE.: the matrix Q is not required. -C -C WANTZ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = .TRUE. : The matrix Z is updated; -C = .FALSE.: the matrix Z is not required. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that the matrices A and B are already -C (quasi) upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N. The routine works primarily with the submatrices -C in rows and columns ILO to IHI, but applies the -C transformations to all the rows and columns of the -C matrices A and B, if WANTT = .TRUE.. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C ILOQ (input) INTEGER -C IHIQ (input) INTEGER -C Specify the rows of Q and Z to which transformations -C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., -C respectively. -C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. -C -C POS (input) INTEGER -C The position of the zero element on the diagonal of B. -C ILO <= POS <= IHI. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper Hessenberg matrix A. -C On exit, the leading N-by-N part of this array contains -C the updated matrix A where A(POS,POS-1) = 0, if POS > ILO, -C and A(POS+1,POS) = 0, if POS < IHI. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain an upper triangular matrix B with B(POS,POS) = 0. -C On exit, the leading N-by-N part of this array contains -C the updated upper triangular matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if WANTQ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Q of -C transformations accumulated by MB03XP. -C On exit, if WANTQ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Q updated in the -C submatrix Q(ILOQ:IHIQ,ILO:IHI). -C If WANTQ = .FALSE., Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If WANTQ = .TRUE., LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if WANTZ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Z of -C transformations accumulated by MB03XP. -C On exit, if WANTZ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Z updated in the -C submatrix Z(ILOQ:IHIQ,ILO:IHI). -C If WANTZ = .FALSE., Z is not referenced. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If WANTZ = .TRUE., LDZ >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The method is illustrated by Wilkinson diagrams for N = 5, -C POS = 3: -C -C [ x x x x x ] [ x x x x x ] -C [ x x x x x ] [ o x x x x ] -C A = [ o x x x x ], B = [ o o o x x ]. -C [ o o x x x ] [ o o o x x ] -C [ o o o x x ] [ o o o o x ] -C -C First, a QR factorization is applied to A(1:3,1:3) and the -C resulting nonzero in the updated matrix B is immediately -C annihilated by a Givens rotation acting on columns 1 and 2: -C -C [ x x x x x ] [ x x x x x ] -C [ x x x x x ] [ o x x x x ] -C A = [ o o x x x ], B = [ o o o x x ]. -C [ o o x x x ] [ o o o x x ] -C [ o o o x x ] [ o o o o x ] -C -C Secondly, an RQ factorization is applied to A(4:5,4:5) and the -C resulting nonzero in the updated matrix B is immediately -C annihilated by a Givens rotation acting on rows 4 and 5: -C -C [ x x x x x ] [ x x x x x ] -C [ x x x x x ] [ o x x x x ] -C A = [ o o x x x ], B = [ o o o x x ]. -C [ o o o x x ] [ o o o x x ] -C [ o o o x x ] [ o o o o x ] -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. -C The periodic Schur decomposition: Algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**2) floating point operations and is -C backward stable. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLADFB). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - LOGICAL WANTQ, WANTT, WANTZ - INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, LDZ, - $ N, POS -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I1, I2, J, NQ - DOUBLE PRECISION CS, SN, TEMP -C .. External Subroutines .. - EXTERNAL DLARTG, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - NQ = IHIQ - ILOQ + 1 - IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -6 - ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN - INFO = -7 - ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN - INFO = -8 - ELSE IF ( POS.LT.ILO .OR. POS.GT.IHI ) THEN - INFO = -9 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN - INFO = -15 - ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN - INFO = -17 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03YA', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( WANTT ) THEN - I1 = 1 - I2 = N - ELSE - I1 = ILO - I2 = IHI - END IF -C -C Apply a zero-shifted QR step. -C - DO 10 J = ILO, POS-1 - TEMP = A(J,J) - CALL DLARTG( TEMP, A(J+1,J), CS, SN, A(J,J) ) - A(J+1,J) = ZERO - CALL DROT( I2-J, A(J,J+1), LDA, A(J+1,J+1), LDA, CS, SN ) - CALL DROT( MIN(J,POS-2)-I1+2, B(I1,J), 1, B(I1,J+1), 1, CS, - $ SN ) - IF ( WANTQ ) - $ CALL DROT( NQ, Q(ILOQ,J), 1, Q(ILOQ,J+1), 1, CS, SN ) - 10 CONTINUE - DO 20 J = ILO, POS-2 - TEMP = B(J,J) - CALL DLARTG( TEMP, B(J+1,J), CS, SN, B(J,J) ) - B(J+1,J) = ZERO - CALL DROT( I2-J, B(J,J+1), LDB, B(J+1,J+1), LDB, CS, SN ) - CALL DROT( J-I1+2, A(I1,J), 1, A(I1,J+1), 1, CS, SN ) - IF ( WANTZ ) - $ CALL DROT( NQ, Z(ILOQ,J), 1, Z(ILOQ,J+1), 1, CS, SN ) - 20 CONTINUE -C -C Apply a zero-shifted RQ step. -C - DO 30 J = IHI, POS+1, -1 - TEMP = A(J,J) - CALL DLARTG( TEMP, A(J,J-1), CS, SN, A(J,J) ) - A(J,J-1) = ZERO - SN = -SN - CALL DROT( J-I1, A(I1,J-1), 1, A(I1,J), 1, CS, SN ) - CALL DROT( I2 - MAX( J-1,POS+1 ) + 1, B(J-1,MAX( J-1,POS+1 )), - $ LDB, B(J,MAX(J-1,POS+1)), LDB, CS, SN ) - IF ( WANTZ ) - $ CALL DROT( NQ, Z(ILOQ,J-1), 1, Z(ILOQ,J), 1, CS, SN ) - 30 CONTINUE - DO 40 J = IHI, POS+2, -1 - TEMP = B(J,J) - CALL DLARTG( TEMP, B(J,J-1), CS, SN, B(J,J) ) - B(J,J-1) = ZERO - SN = -SN - CALL DROT( J-I1, B(I1,J-1), 1, B(I1,J), 1, CS, SN ) - CALL DROT( I2-J+2, A(J-1,J-1), LDA, A(J,J-1), LDA, CS, SN ) - IF ( WANTQ ) - $ CALL DROT( NQ, Q(ILOQ,J-1), 1, Q(ILOQ,J), 1, CS, SN ) - 40 CONTINUE - RETURN -C *** Last line of MB03YA *** - END diff --git a/slycot/src/MB03YD.f b/slycot/src/MB03YD.f deleted file mode 100644 index e99078cd..00000000 --- a/slycot/src/MB03YD.f +++ /dev/null @@ -1,540 +0,0 @@ - SUBROUTINE MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, - $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, - $ BETA, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To deal with small subtasks of the product eigenvalue problem. -C -C MB03YD is an auxiliary routine called by SLICOT Library routine -C MB03XP. -C -C ARGUMENTS -C -C Mode Parameters -C -C WANTT LOGICAL -C Indicates whether the user wishes to compute the full -C Schur form or the eigenvalues only, as follows: -C = .TRUE. : Compute the full Schur form; -C = .FALSE.: compute the eigenvalues only. -C -C WANTQ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Q as follows: -C = .TRUE. : The matrix Q is updated; -C = .FALSE.: the matrix Q is not required. -C -C WANTZ LOGICAL -C Indicates whether or not the user wishes to accumulate -C the matrix Z as follows: -C = .TRUE. : The matrix Z is updated; -C = .FALSE.: the matrix Z is not required. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and B. N >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that the matrices A and B are already -C (quasi) upper triangular in rows and columns 1:ILO-1 and -C IHI+1:N. The routine works primarily with the submatrices -C in rows and columns ILO to IHI, but applies the -C transformations to all the rows and columns of the -C matrices A and B, if WANTT = .TRUE.. -C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. -C -C ILOQ (input) INTEGER -C IHIQ (input) INTEGER -C Specify the rows of Q and Z to which transformations -C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., -C respectively. -C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper Hessenberg matrix A. -C On exit, if WANTT = .TRUE., the leading N-by-N part of -C this array is upper quasi-triangular in rows and columns -C ILO:IHI. -C If WANTT = .FALSE., the diagonal elements and 2-by-2 -C diagonal blocks of A will be correct, but the remaining -C parts of A are unspecified on exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix B. -C On exit, if WANTT = .TRUE., the leading N-by-N part of -C this array contains the transformed upper triangular -C matrix. 2-by-2 blocks in B corresponding to 2-by-2 blocks -C in A will be reduced to positive diagonal form. (I.e., if -C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) -C and B(j+1,j+1) will be positive.) -C If WANTT = .FALSE., the elements corresponding to diagonal -C elements and 2-by-2 diagonal blocks in A will be correct, -C but the remaining parts of B are unspecified on exit. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if WANTQ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Q of -C transformations accumulated by MB03XP. -C On exit, if WANTQ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Q updated in the -C submatrix Q(ILOQ:IHIQ,ILO:IHI). -C If WANTQ = .FALSE., Q is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= 1. -C If WANTQ = .TRUE., LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if WANTZ = .TRUE., then the leading N-by-N part -C of this array must contain the current matrix Z of -C transformations accumulated by MB03XP. -C On exit, if WANTZ = .TRUE., then the leading N-by-N part -C of this array contains the matrix Z updated in the -C submatrix Z(ILOQ:IHIQ,ILO:IHI). -C If WANTZ = .FALSE., Z is not referenced. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= 1. -C If WANTZ = .TRUE., LDZ >= MAX(1,N). -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C The i-th (ILO <= i <= IHI) computed eigenvalue is given -C by BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two -C eigenvalues are computed as a complex conjugate pair, -C they are stored in consecutive elements of ALPHAR, ALPHAI -C and BETA. If WANTT = .TRUE., the eigenvalues are stored in -C the same order as on the diagonals of the Schur forms of -C A and B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -19, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then MB03YD failed to compute the Schur -C form in a total of 30*(IHI-ILO+1) iterations; -C elements i+1:n of ALPHAR, ALPHAI and BETA contain -C successfully computed eigenvalues. -C -C METHOD -C -C The implemented algorithm is a double-shift version of the -C periodic QR algorithm described in [1,3] with some minor -C modifications [2]. The eigenvalues are computed via an implicit -C complex single shift algorithm. -C -C REFERENCES -C -C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. -C The periodic Schur decomposition: Algorithms and applications. -C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, -C 1992. -C -C [2] Kressner, D. -C An efficient and reliable implementation of the periodic QZ -C algorithm. Proc. of the IFAC Workshop on Periodic Control -C Systems, pp. 187-192, 2001. -C -C [3] Van Loan, C. -C Generalized Singular Values with Algorithms and Applications. -C Ph. D. Thesis, University of Michigan, 1973. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C backward stable. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPQR). -C -C KEYWORDS -C -C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal -C transformation, (periodic) Schur form -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - LOGICAL WANTQ, WANTT, WANTZ - INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, - $ LDWORK, LDZ, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I, I1, I2, ITN, ITS, K, KK, L, NH, NQ, NR - DOUBLE PRECISION ALPHA, BETAX, CS1, CS2, CS3, DELTA, GAMMA, - $ OVFL, SMLNUM, SN1, SN2, SN3, TAUV, TAUW, - $ TEMP, TST, ULP, UNFL -C .. Local Arrays .. - INTEGER ISEED(4) - DOUBLE PRECISION V(3), W(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLARFG, DLARFX, DLARNV, DLARTG, - $ DROT, MB03YA, MB03YT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - NH = IHI - ILO + 1 - NQ = IHIQ - ILOQ + 1 - IF ( N.LT.0 ) THEN - INFO = -4 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN - INFO = -6 - ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN - INFO = -7 - ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN - INFO = -8 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - 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 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -21 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03YD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C -C Set machine-dependent constants for the stopping criterion. -C - UNFL = DLAMCH( 'Safe minimum' ) - OVFL = ONE / UNFL - CALL DLABAD( UNFL, OVFL ) - ULP = DLAMCH( 'Precision' ) - SMLNUM = UNFL*( NH / ULP ) -C -C I1 and I2 are the indices of the first rows and last columns of -C A and B to which transformations must be applied. -C - I1 = 1 - I2 = N - ISEED(1) = 1 - ISEED(2) = 0 - ISEED(3) = 0 - ISEED(4) = 1 -C -C ITN is the maximal number of QR iterations. -C - ITN = 30*NH -C -C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO -C or A(L,L-1) is negligible. -C - I = IHI - 10 CONTINUE - L = ILO - IF ( I.LT.ILO ) - $ GO TO 120 -C -C Perform periodic QR iteration on rows and columns ILO to I of A -C and B until a submatrix of order 1 or 2 splits off at the bottom. -C - DO 70 ITS = 0, ITN -C -C Look for deflations in A. -C - DO 20 K = I, L + 1, -1 - TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) - IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 30 - 20 CONTINUE - 30 CONTINUE -C -C Look for deflation in B if problem size is greater than 1. -C - IF ( I-K.GE.1 ) THEN - DO 40 KK = I, K, -1 - IF ( KK.EQ.I ) THEN - TST = ABS( B(KK-1,KK) ) - ELSE IF ( KK.EQ.K ) THEN - TST = ABS( B(KK,KK+1) ) - ELSE - TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) - END IF - IF ( TST.EQ.ZERO ) - $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) - IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) - $ GO TO 50 - 40 CONTINUE - ELSE - KK = K-1 - END IF - 50 CONTINUE - IF ( KK.GE.K ) THEN -C -C B has an element close to zero at position (KK,KK). -C - B(KK,KK) = ZERO - CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILOQ, IHIQ, KK, - $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) - K = KK+1 - END IF - L = K - IF( L.GT.ILO ) THEN -C -C A(L,L-1) is negligible. -C - A(L,L-1) = ZERO - END IF -C -C Exit from loop if a submatrix of order 1 or 2 has split off. -C - IF ( L.GE.I-1 ) - $ GO TO 80 -C -C The active submatrices are now in rows and columns L:I. -C - IF ( .NOT.WANTT ) THEN - I1 = L - I2 = I - END IF - IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN -C -C Exceptional shift. The first column of the shift polynomial -C is a pseudo-random vector. -C - CALL DLARNV( 3, ISEED, 3, V ) - ELSE -C -C The implicit double shift is constructed via a partial -C product QR factorization [2]. -C - CALL DLARTG( B(L,L), B(I,I), CS2, SN2, TEMP ) - CALL DLARTG( TEMP, B(I-1,I), CS1, SN1, ALPHA ) -C - ALPHA = A(L,L)*CS2 - A(I,I)*SN2 - BETAX = CS1*( CS2*A(L+1,L) ) - GAMMA = CS1*( SN2*A(I-1,I) ) + SN1*A(I-1,I-1) - ALPHA = ALPHA*CS1 - A(I,I-1)*SN1 - CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) -C - CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) - ALPHA = CS2 - GAMMA = ( A(I-1,I-1)*CS1 )*CS2 + A(I,I-1)*SN2 - DELTA = ( A(I-1,I-1)*SN1 )*CS2 - CALL DLARTG( GAMMA, DELTA, CS3, SN3, TEMP ) - CALL DLARTG( ALPHA, TEMP, CS2, SN2, ALPHA ) -C - ALPHA = ( B(L,L)*CS1 + B(L,L+1)*SN1 )*CS2 - BETAX = ( B(L+1,L+1)*SN1 )*CS2 - GAMMA = B(I-1,I-1)*SN2 - CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) - CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) -C - ALPHA = CS1*A(L,L) + SN1*A(L,L+1) - BETAX = CS1*A(L+1,L) + SN1*A(L+1,L+1) - GAMMA = SN1*A(L+2,L+1) -C - V(1) = CS2*ALPHA - SN2*CS3 - V(2) = CS2*BETAX - SN2*SN3 - V(3) = GAMMA*CS2 - END IF -C -C Double-shift QR step -C - DO 60 K = L, I-1 -C - NR = MIN( 3,I-K+1 ) - IF ( K.GT.L ) - $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) - CALL DLARFG( NR, V(1), V(2), 1, TAUV ) - IF ( K.GT.L ) THEN - A(K,K-1) = V(1) - A(K+1,K-1) = ZERO - IF ( K.LT.I-1 ) - $ A(K+2,K-1) = ZERO - END IF -C -C Apply reflector V from the right to B in rows I1:min(K+2,I). -C - V(1) = ONE - CALL DLARFX( 'Right', MIN(K+2,I)-I1+1, NR, V, TAUV, B(I1,K), - $ LDB, DWORK ) -C -C Annihilate the introduced nonzeros in the K-th column. -C - CALL DCOPY( NR, B(K,K), 1, W, 1 ) - CALL DLARFG( NR, W(1), W(2), 1, TAUW ) - B(K,K) = W(1) - B(K+1,K) = ZERO - IF ( K.LT.I-1 ) - $ B(K+2,K) = ZERO -C -C Apply reflector W from the left to transform the rows of the -C matrix B in columns K+1:I2. -C - W(1) = ONE - CALL DLARFX( 'Left', NR, I2-K, W, TAUW, B(K,K+1), LDB, - $ DWORK ) -C -C Apply reflector V from the left to transform the rows of the -C matrix A in columns K:I2. -C - CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, - $ DWORK ) -C -C Apply reflector W from the right to transform the columns of -C the matrix A in rows I1:min(K+3,I). -C - CALL DLARFX( 'Right', MIN(K+3,I)-I1+1, NR, W, TAUW, A(I1,K), - $ LDA, DWORK ) -C -C Accumulate transformations in the matrices Q and Z. -C - IF ( WANTQ ) - $ CALL DLARFX( 'Right', NQ, NR, V, TAUV, Q(ILOQ,K), LDQ, - $ DWORK ) - IF ( WANTZ ) - $ CALL DLARFX( 'Right', NQ, NR, W, TAUW, Z(ILOQ,K), LDZ, - $ DWORK ) - 60 CONTINUE - 70 CONTINUE -C -C Failure to converge. -C - INFO = I - RETURN -C - 80 CONTINUE -C -C Compute 1-by-1 or 2-by-2 subproblem. -C - IF ( L.EQ.I ) THEN -C -C Standardize B, set ALPHAR, ALPHAI and BETA. -C - IF ( B(I,I).LT.ZERO ) THEN - IF ( WANTT ) THEN - DO 90 K = I1, I - B(K,I) = -B(K,I) - 90 CONTINUE - DO 100 K = I, I2 - A(I,K) = -A(I,K) - 100 CONTINUE - ELSE - B(I,I) = -B(I,I) - A(I,I) = -A(I,I) - END IF - IF ( WANTQ ) THEN - DO 110 K = ILOQ, IHIQ - Q(K,I) = -Q(K,I) - 110 CONTINUE - END IF - END IF - ALPHAR(I) = A(I,I) - ALPHAI(I) = ZERO - BETA(I) = B(I,I) - ELSE IF( L.EQ.I-1 ) THEN -C -C A double block has converged. -C Compute eigenvalues and standardize double block. -C - CALL MB03YT( A(I-1,I-1), LDA, B(I-1,I-1), LDB, ALPHAR(I-1), - $ ALPHAI(I-1), BETA(I-1), CS1, SN1, CS2, SN2 ) -C -C Apply transformation to rest of A and B. -C - IF ( I2.GT.I ) - $ CALL DROT( I2-I, A(I-1,I+1), LDA, A(I,I+1), LDA, CS1, SN1 ) - CALL DROT( I-I1-1, A(I1,I-1), 1, A(I1,I), 1, CS2, SN2 ) - IF ( I2.GT.I ) - $ CALL DROT( I2-I, B(I-1,I+1), LDB, B(I,I+1), LDB, CS2, SN2 ) - CALL DROT( I-I1-1, B(I1,I-1), 1, B(I1,I), 1, CS1, SN1 ) -C -C Apply transformation to rest of Q and Z if desired. -C - IF ( WANTQ ) - $ CALL DROT( NQ, Q(ILOQ,I-1), 1, Q(ILOQ,I), 1, CS1, SN1 ) - IF ( WANTZ ) - $ CALL DROT( NQ, Z(ILOQ,I-1), 1, Z(ILOQ,I), 1, CS2, SN2 ) - END IF -C -C Decrement number of remaining iterations, and return to start of -C the main loop with new value of I. -C - ITN = ITN - ITS - I = L - 1 - GO TO 10 -C - 120 CONTINUE - DWORK(1) = DBLE( MAX( 1, N ) ) - RETURN -C *** Last line of MB03YD *** - END diff --git a/slycot/src/MB03YT.f b/slycot/src/MB03YT.f deleted file mode 100644 index 774b0bdd..00000000 --- a/slycot/src/MB03YT.f +++ /dev/null @@ -1,331 +0,0 @@ - SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, - $ CSR, SNR ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the periodic Schur factorization of a real 2-by-2 -C matrix pair (A,B) where B is upper triangular. This routine -C computes orthogonal (rotation) matrices given by CSL, SNL and CSR, -C SNR such that -C -C 1) if the pair (A,B) has two real eigenvalues, then -C -C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] -C [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] -C -C [ b11 b12 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] -C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ], -C -C 2) if the pair (A,B) has a pair of complex conjugate eigenvalues, -C then -C -C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] -C [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] -C -C [ b11 0 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] -C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ]. -C -C This is a modified version of the LAPACK routine DLAGV2 for -C computing the real, generalized Schur decomposition of a -C two-by-two matrix pencil. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,2) -C On entry, the leading 2-by-2 part of this array must -C contain the matrix A. -C On exit, the leading 2-by-2 part of this array contains -C the matrix A of the pair in periodic Schur form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= 2. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,2) -C On entry, the leading 2-by-2 part of this array must -C contain the upper triangular matrix B. -C On exit, the leading 2-by-2 part of this array contains -C the matrix B of the pair in periodic Schur form. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= 2. -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (2) -C ALPHAI (output) DOUBLE PRECISION array, dimension (2) -C BETA (output) DOUBLE PRECISION array, dimension (2) -C (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the -C pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0. -C -C CSL (output) DOUBLE PRECISION -C The cosine of the first rotation matrix. -C -C SNL (output) DOUBLE PRECISION -C The sine of the first rotation matrix. -C -C CSR (output) DOUBLE PRECISION -C The cosine of the second rotation matrix. -C -C SNR (output) DOUBLE PRECISION -C The sine of the second rotation matrix. -C -C REFERENCES -C -C [1] Van Loan, C. -C Generalized Singular Values with Algorithms and Applications. -C Ph. D. Thesis, University of Michigan, 1973. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2). -C V. Sima, July 2008, May 2009. -C -C KEYWORDS -C -C Eigenvalue, periodic Schur form -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER LDA, LDB - DOUBLE PRECISION CSL, CSR, SNL, SNR -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*), - $ BETA(2) -C .. Local Scalars .. - DOUBLE PRECISION ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN, - $ SCALE1, SCALE2, T, ULP, WI, WR1, WR2 -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -C .. External Subroutines .. - EXTERNAL DLAG2, DLARTG, DLASV2, DROT -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C -C .. Executable Statements .. -C - SAFMIN = DLAMCH( 'S' ) - ULP = DLAMCH( 'P' ) -C -C Scale A. -C - ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ), - $ ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN ) - A(1,1) = A(1,1) / ANORM - A(1,2) = A(1,2) / ANORM - A(2,1) = A(2,1) / ANORM - A(2,2) = A(2,2) / ANORM -C -C Scale B. -C - BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN) - B(1,1) = B(1,1) / BNORM - B(1,2) = B(1,2) / BNORM - B(2,2) = B(2,2) / BNORM -C -C Check if A can be deflated. -C - IF ( ABS( A(2,1) ).LE.ULP ) THEN - CSL = ONE - SNL = ZERO - CSR = ONE - SNR = ZERO - WI = ZERO - A(2,1) = ZERO - B(2,1) = ZERO -C -C Check if B is singular. -C - ELSE IF ( ABS( B(1,1) ).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), LDB, B(2,1), LDB, CSR, SNR ) - CSL = ONE - SNL = ZERO - WI = ZERO - A(2,1) = ZERO - B(1,1) = ZERO - B(2,1) = ZERO - ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN - CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) - CSR = ONE - SNR = ZERO - WI = ZERO - CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) - CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) - A(2,1) = ZERO - B(2,1) = ZERO - B(2,2) = ZERO - ELSE -C -C B is nonsingular, first compute the eigenvalues of A / adj(B). -C - R = B(1,1) - B(1,1) = B(2,2) - B(2,2) = R - B(1,2) = -B(1,2) - CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, - $ WI ) -C - IF( WI.EQ.ZERO ) THEN -C -C Two real eigenvalues, compute s*A-w*B. -C - 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) -C - RR = DLAPY2( H1, H2 ) - QQ = DLAPY2( SCALE1*A(2,1), H3 ) -C - IF ( RR.GT.QQ ) THEN -C -C Find right rotation matrix to zero 1,1 element of -C (sA - wB). -C - CALL DLARTG( H2, H1, CSR, SNR, T ) -C - ELSE -C -C Find right rotation matrix to zero 2,1 element of -C (sA - wB). -C - CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T ) -C - END IF -C - 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 ) -C -C Compute inf norms of A and B. -C - 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) ) ) -C - IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN -C -C Find left rotation matrix Q to zero out B(2,1). -C - CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R ) -C - ELSE -C -C Find left rotation matrix Q to zero out A(2,1). -C - CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) -C - END IF -C - 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 ) -C - A(2,1) = ZERO - B(2,1) = ZERO -C -C Re-adjoint B. -C - R = B(1,1) - B(1,1) = B(2,2) - B(2,2) = R - B(1,2) = -B(1,2) -C - ELSE -C -C A pair of complex conjugate eigenvalues: -C first compute the SVD of the matrix adj(B). -C - R = B(1,1) - B(1,1) = B(2,2) - B(2,2) = R - B(1,2) = -B(1,2) - CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL, - $ SNR, CSR ) -C -C Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix -C and Z is right rotation matrix computed from DLASV2. -C - CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) - CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, 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, CSL, SNL ) -C - B(2,1) = ZERO - B(1,2) = ZERO - END IF -C - END IF -C -C Unscaling -C - R = B(1,1) - T = B(2,2) - 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) -C - 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 - WR1 = ANORM*WR1 - WI = ANORM*WI - IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN - WR1 = WR1*R - WI = WI*R - R = ONE - END IF - IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN - WR1 = WR1*T - WI = WI*T - T = ONE - END IF - ALPHAR(1) = ( WR1 / SCALE1 )*R*T - ALPHAI(1) = ABS( ( WI / SCALE1 )*R*T ) - ALPHAR(2) = ALPHAR(1) - ALPHAI(2) = -ALPHAI(1) - BETA(1) = BNORM - BETA(2) = BNORM - END IF - RETURN -C *** Last line of MB03YT *** - END diff --git a/slycot/src/MB03ZA.f b/slycot/src/MB03ZA.f deleted file mode 100644 index 81452520..00000000 --- a/slycot/src/MB03ZA.f +++ /dev/null @@ -1,1371 +0,0 @@ - SUBROUTINE MB03ZA( COMPC, COMPU, COMPV, COMPW, WHICH, SELECT, N, - $ A, LDA, B, LDB, C, LDC, U1, LDU1, U2, LDU2, V1, - $ LDV1, V2, LDV2, W, LDW, WR, WI, M, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C 1. To compute, for a given matrix pair (A,B) in periodic Schur -C form, orthogonal matrices Ur and Vr so that -C -C T [ A11 A12 ] T [ B11 B12 ] -C Vr * A * Ur = [ ], Ur * B * Vr = [ ], (1) -C [ 0 A22 ] [ 0 B22 ] -C -C is in periodic Schur form, and the eigenvalues of A11*B11 -C form a selected cluster of eigenvalues. -C -C 2. To compute an orthogonal matrix W so that -C -C T [ 0 -A11 ] [ R11 R12 ] -C W * [ ] * W = [ ], (2) -C [ B11 0 ] [ 0 R22 ] -C -C where the eigenvalues of R11 and -R22 coincide and have -C positive real part. -C -C Optionally, the matrix C is overwritten by Ur'*C*Vr. -C -C All eigenvalues of A11*B11 must either be complex or real and -C negative. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPC CHARACTER*1 -C = 'U': update the matrix C; -C = 'N': do not update C. -C -C COMPU CHARACTER*1 -C = 'U': update the matrices U1 and U2; -C = 'N': do not update U1 and U2. -C See the description of U1 and U2. -C -C COMPV CHARACTER*1 -C = 'U': update the matrices V1 and V2; -C = 'N': do not update V1 and V2. -C See the description of V1 and V2. -C -C COMPW CHARACTER*1 -C Indicates whether or not the user wishes to accumulate -C the matrix W as follows: -C = 'N': the matrix W is not required; -C = 'I': W is initialized to the unit matrix and the -C orthogonal transformation matrix W is returned; -C = 'V': W must contain an orthogonal matrix Q on entry, -C and the product Q*W is returned. -C -C WHICH CHARACTER*1 -C = 'A': select all eigenvalues, this effectively means -C that Ur and Vr are identity matrices and A11 = A, -C B11 = B; -C = 'S': select a cluster of eigenvalues specified by -C SELECT. -C -C SELECT LOGICAL array, dimension (N) -C If WHICH = 'S', then SELECT specifies the eigenvalues of -C A*B in the selected cluster. To select a real eigenvalue -C w(j), SELECT(j) must be set to .TRUE.. To select a complex -C conjugate pair of eigenvalues w(j) and w(j+1), -C corresponding to a 2-by-2 diagonal block in A, both -C SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex -C conjugate pair of eigenvalues must be either both included -C in the cluster or both excluded. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi-triangular matrix A of the matrix -C pair (A,B) in periodic Schur form. -C On exit, the leading M-by-M part of this array contains -C the matrix R22 in (2). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix B of the matrix pair -C (A,B) in periodic Schur form. -C On exit, the leading N-by-N part of this array is -C overwritten. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, if COMPC = 'U', the leading N-by-N part of this -C array must contain a general matrix C. -C On exit, if COMPC = 'U', the leading N-by-N part of this -C array contains the updated matrix Ur'*C*Vr. -C If COMPC = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= 1. -C LDC >= N, if COMPC = 'U' and WHICH = 'S'. -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain U1, the (1,1) -C block of an orthogonal symplectic matrix -C U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains U1*Ur. -C If COMPU = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= 1. -C LDU1 >= N, if COMPU = 'U' and WHICH = 'S'. -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain U2, the (1,2) -C block of an orthogonal symplectic matrix -C U = [ U1, U2; -U2, U1 ]. -C On exit, if COMPU = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains U2*Ur. -C If COMPU = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= 1. -C LDU2 >= N, if COMPU = 'U' and WHICH = 'S'. -C -C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) -C On entry, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain V1, the (1,1) -C block of an orthogonal symplectic matrix -C V = [ V1, V2; -V2, V1 ]. -C On exit, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains V1*Vr. -C If COMPV = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= 1. -C LDV1 >= N, if COMPV = 'U' and WHICH = 'S'. -C -C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,N) -C On entry, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array must contain V2, the (1,2) -C block of an orthogonal symplectic matrix -C V = [ V1, V2; -V2, V1 ]. -C On exit, if COMPV = 'U' and WHICH = 'S', the leading -C N-by-N part of this array contains V2*Vr. -C If COMPV = 'N' or WHICH = 'A', this array is not -C referenced. -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= 1. -C LDV2 >= N, if COMPV = 'U' and WHICH = 'S'. -C -C W (input/output) DOUBLE PRECISION array, dimension (LDW,2*M) -C On entry, if COMPW = 'V', then the leading 2*M-by-2*M part -C of this array must contain a matrix W. -C If COMPW = 'I', then W need not be set on entry, W is set -C to the identity matrix. -C On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part -C of this array is post-multiplied by the transformation -C matrix that produced (2). -C If COMPW = 'N', this array is not referenced. -C -C LDW INTEGER -C The leading dimension of the array W. LDW >= 1. -C LDW >= 2*M, if COMPW = 'I' or COMPW = 'V'. -C -C WR (output) DOUBLE PRECISION array, dimension (M) -C WI (output) DOUBLE PRECISION array, dimension (M) -C The real and imaginary parts, respectively, of the -C eigenvalues of R22. The eigenvalues are stored in the same -C order as on the diagonal of R22, with -C WR(i) = R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2 -C diagonal block, WI(i) > 0 and WI(i+1) = -WI(i). -C In exact arithmetic, these eigenvalue are the positive -C square roots of the selected eigenvalues of the product -C A*B. However, if an eigenvalue is sufficiently -C ill-conditioned, then its value may differ significantly. -C -C M (output) INTEGER -C The number of selected eigenvalues. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = -28, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, 4*N, 8*M ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: reordering of the product A*B in Step 1 failed -C because some eigenvalues are too close to separate; -C = 2: reordering of some submatrix in Step 2 failed -C because some eigenvalues are too close to separate; -C = 3: the QR algorithm failed to compute the Schur form -C of some submatrix in Step 2; -C = 4: the condition that all eigenvalues of A11*B11 must -C either be complex or real and negative is -C numerically violated. -C -C METHOD -C -C Step 1 is performed using a reordering technique analogous to the -C LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2 -C is an implementation of Algorithm 2 in [3]. It requires O(M*N*N) -C floating point operations. -C -C REFERENCES -C -C [1] Kagstrom, B. -C A direct method for reordering eigenvalues in the generalized -C real Schur form of a regular matrix pair (A,B), in M.S. Moonen -C et al (eds), Linear Algebra for Large Scale and Real-Time -C Applications, Kluwer Academic Publ., 1993, pp. 195-218. -C -C [2] Kagstrom, B. and Poromaa P.: -C Computing eigenspaces with specified eigenvalues of a regular -C matrix pair (A, B) and condition estimation: Theory, -C algorithms and software, Numer. Algorithms, 1996, vol. 12, -C pp. 369-407. -C -C [3] Benner, P., Mehrmann, V., and Xu, H. -C A new method for computing the stable invariant subspace of a -C real Hamiltonian matrix, J. Comput. Appl. Math., 86, -C pp. 17-43, 1997. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLABMX). -C -C KEYWORDS -C -C Hamiltonian matrix, invariant subspace. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER LDQZ - PARAMETER ( LDQZ = 4 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPC, COMPU, COMPV, COMPW, WHICH - INTEGER INFO, LDA, LDB, LDC, LDU1, LDU2, LDV1, LDV2, - $ LDW, LDWORK, M, N -C .. Array Arguments .. - LOGICAL SELECT(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), V2(LDV2,*), - $ W(LDW,*), WI(*), WR(*) -C .. Local Scalars .. - LOGICAL CMPALL, INITW, PAIR, SWAP, WANTC, WANTU, WANTV, - $ WANTW - INTEGER HERE, I, IERR, IFST, ILST, K, KS, L, LEN, MM, - $ NB, NBF, NBL, NBNEXT, POS, PW, PWC, PWCK, PWD, - $ PWDL, WRKMIN - DOUBLE PRECISION TEMP -C .. Local Arrays .. - LOGICAL LDUM(1), SELNEW(4) - DOUBLE PRECISION DW12(12), Q(LDQZ,LDQZ), T(LDQZ,LDQZ), WINEW(4), - $ WRNEW(4), Z(LDQZ,LDQZ) - INTEGER IDUM(1) -C .. External Functions .. - LOGICAL LFDUM, LSAME - EXTERNAL LFDUM, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DLACPY, DLASET, DSCAL, - $ DTRSEN, MB03WA, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Decode and check input parameters -C - WANTC = LSAME( COMPC, 'U' ) - WANTU = LSAME( COMPU, 'U' ) - WANTV = LSAME( COMPV, 'U' ) - INITW = LSAME( COMPW, 'I' ) - WANTW = INITW .OR. LSAME( COMPW, 'V' ) - CMPALL = LSAME( WHICH, 'A' ) - WRKMIN = MAX( 1, 4*N ) -C - INFO = 0 - IF ( .NOT.WANTC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN - INFO = -2 - ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( COMPV, 'N' ) ) THEN - INFO = -3 - ELSE IF ( .NOT.WANTW .AND. .NOT.LSAME( COMPW, 'N' ) ) THEN - INFO = -4 - ELSE IF ( .NOT.CMPALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN - INFO = -5 - ELSE - IF ( CMPALL ) THEN - M = N - ELSE -C -C Set M to the dimension of the specified invariant subspace. -C - M = 0 - PAIR = .FALSE. - 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 -C -C Compute workspace requirements. -C - WRKMIN = MAX( WRKMIN, 8*M ) -C - IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF ( LDC.LT.1 .OR. ( WANTC .AND. .NOT.CMPALL .AND. - $ LDC.LT.N ) ) THEN - INFO = -13 - ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. - $ LDU1.LT.N ) ) THEN - INFO = -15 - ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. - $ LDU2.LT.N ) ) THEN - INFO = -17 - ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. - $ LDV1.LT.N ) ) THEN - INFO = -19 - ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. - $ LDV2.LT.N ) ) THEN - INFO = -21 - ELSE IF ( LDW.LT.1 .OR. ( WANTW .AND. LDW.LT.2*M ) ) THEN - INFO = -23 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -28 - DWORK(1) = DBLE( WRKMIN ) - END IF - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03ZA', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Jump immediately to Step 2, if all eigenvalues are requested. -C - IF ( CMPALL ) - $ GO TO 50 -C -C Step 1: Collect the selected blocks at the top-left corner of A*B. -C - KS = 0 - PAIR = .FALSE. - DO 40 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 -C - IF ( PAIR ) THEN - NBF = 2 - ELSE - NBF = 1 - END IF -C - IF ( SWAP ) THEN - KS = KS + 1 - IFST = K -C -C Swap the K-th block to position KS. -C - ILST = KS - NBL = 1 - IF ( ILST.GT.1 ) THEN - IF ( A(ILST,ILST-1).NE.ZERO ) THEN - ILST = ILST - 1 - NBL = 2 - END IF - END IF -C - IF ( ILST.EQ.IFST ) - $ GO TO 30 -C - HERE = IFST - 20 CONTINUE -C -C Swap block with next one above. -C - IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN -C -C Current block either 1-by-1 or 2-by-2. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - POS = HERE - NBNEXT - NB = NBNEXT + NBF - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., NBNEXT, NBF, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, - $ IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), - $ LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), - $ LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), - $ LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, - $ ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), - $ LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), - $ LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), - $ LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), - $ LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), - $ LDV2 ) - END IF -C - HERE = HERE - NBNEXT -C -C Test if 2-by-2 block breaks into two 1-by-1 blocks. -C - IF ( NBF.EQ.2 ) THEN - IF ( A(HERE+1,HERE).EQ.ZERO ) - $ NBF = 3 - END IF -C - ELSE -C -C Current block consists of two 1 by 1 blocks each of -C which must be swapped individually. -C - NBNEXT = 1 - IF ( HERE.GE.3 ) THEN - IF ( A(HERE-1,HERE-2).NE.ZERO ) - $ NBNEXT = 2 - END IF - POS = HERE - NBNEXT - NB = NBNEXT + 1 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, - $ IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), - $ LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, - $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), - $ LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), - $ LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, - $ ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), - $ LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), - $ LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), - $ LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), - $ LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), - $ LDV2 ) - END IF -C - IF ( NBNEXT.EQ.1 ) THEN -C -C Swap two 1-by-1 blocks. -C - POS = HERE - NB = NBNEXT + 1 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), LDA, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), LDB, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, - $ B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, - $ ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), - $ LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, - $ ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), - $ LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U1(1,POS), LDU1, Z, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), - $ LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, U2(1,POS), LDU2, Z, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), - $ LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V1(1,POS), LDV1, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), - $ LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, - $ NB, NB, ONE, V2(1,POS), LDV2, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), - $ LDV2 ) - END IF -C - HERE = HERE - 1 - ELSE -C -C Recompute NBNEXT in case 2-by-2 split. -C - IF ( A(HERE,HERE-1).EQ.ZERO ) - $ NBNEXT = 1 -C - IF ( NBNEXT.EQ.2 ) THEN -C -C 2-by-2 block did not split. -C - POS = HERE - 1 - NB = 3 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), - $ LDA, Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), - $ LDB, Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, C(1,POS), LDC, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ C(1,POS), LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), - $ LDC, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, - $ C(POS,1), LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U1(1,POS), LDU1, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U1(1,POS), LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U2(1,POS), LDU2, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U2(1,POS), LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V1(1,POS), LDV1, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V1(1,POS), LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V2(1,POS), LDV2, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V2(1,POS), LDV2 ) - END IF -C - HERE = HERE - 2 - ELSE -C -C 2-by-2 block did split. -C - POS = HERE - NB = 2 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), - $ LDA, Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), - $ LDB, Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, C(1,POS), LDC, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ C(1,POS), LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), - $ LDC, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, - $ C(POS,1), LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U1(1,POS), LDU1, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U1(1,POS), LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U2(1,POS), LDU2, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U2(1,POS), LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V1(1,POS), LDV1, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V1(1,POS), LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V2(1,POS), LDV2, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V2(1,POS), LDV2 ) - END IF -C - POS = HERE - 1 - NB = 2 - CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) - CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) -C - CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), - $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, - $ LDQZ, IERR ) -C - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 1 - RETURN - END IF -C -C Update rest of A. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, A(1,POS), - $ LDA, Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ A(1,POS), LDA ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Q, LDQZ, - $ A(POS,POS+NB), LDA, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, A(POS,POS+NB), LDA ) - END IF -C -C Update rest of B. -C - IF ( POS.GT.1 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ POS-1, NB, NB, ONE, B(1,POS), - $ LDB, Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', POS-1, NB, DWORK, N, - $ B(1,POS), LDB ) - END IF - IF ( POS+NB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N-POS-NB+1, NB, ONE, Z, LDQZ, - $ B(POS,POS+NB), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, - $ NB, B(POS,POS+NB), LDB ) - END IF -C -C Update C. -C - IF ( WANTC ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, C(1,POS), LDC, Q, - $ LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ C(1,POS), LDC ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, - $ N, NB, ONE, Z, LDQZ, C(POS,1), - $ LDC, ZERO, DWORK, NB ) - CALL DLACPY( 'All', NB, N, DWORK, NB, - $ C(POS,1), LDC ) - END IF -C -C Update U. -C - IF ( WANTU ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U1(1,POS), LDU1, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U1(1,POS), LDU1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, U2(1,POS), LDU2, - $ Z, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ U2(1,POS), LDU2 ) - END IF -C -C Update V. -C - IF ( WANTV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V1(1,POS), LDV1, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V1(1,POS), LDV1 ) - CALL DGEMM( 'No Transpose', 'No Transpose', - $ N, NB, NB, ONE, V2(1,POS), LDV2, - $ Q, LDQZ, ZERO, DWORK, N ) - CALL DLACPY( 'All', N, NB, DWORK, N, - $ V2(1,POS), LDV2 ) - END IF -C - HERE = HERE - 2 - END IF - END IF - END IF -C - IF ( HERE.GT.ILST ) - $ GO TO 20 -C - 30 CONTINUE - IF ( PAIR ) - $ KS = KS + 1 - END IF - END IF - 40 CONTINUE -C - 50 CONTINUE -C -C Step 2: Compute an ordered Schur decomposition of -C [ 0, -A11; B11, 0 ]. -C - IF ( INITW ) - $ CALL DLASET( 'All', 2*M, 2*M, ZERO, ONE, W, LDW ) - PWC = 1 - PWD = PWC + 2*M - PW = PWD + 2*M - PAIR = .FALSE. - NB = 1 -C - DO 80 K = 1, M - IF ( PAIR ) THEN - PAIR = .FALSE. - NB = 1 - ELSE - IF ( K.LT.N ) THEN - IF ( A(K+1,K).NE.ZERO ) THEN - PAIR = .TRUE. - NB = 2 - END IF - END IF - PWCK = PWC + 2*( K - 1 ) - PWDL = PWD + 2*( K - 1 ) - CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, DWORK(PWCK), 2 ) - CALL DLACPY( 'All', NB, M-K+1, A(K,K), LDA, DWORK(PWDL), 2 ) - CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, A(K,K), LDA ) -C - L = K -C -C WHILE L >= 1 DO -C - 60 CONTINUE -C - IF ( K.EQ.L ) THEN -C -C Annihilate B(k,k). -C - NBL = NB - CALL DLASET( 'All', NB+NBL, NB+NBL, ZERO, ZERO, T, - $ LDQZ ) - CALL DLACPY( 'Upper', NBL, NBL, B(L,L), LDB, - $ T(NB+1,1), LDQZ ) - IF ( NB.EQ.1 ) THEN - DWORK(PWDL) = -DWORK(PWDL) - ELSE - CALL DSCAL( 2*NB, -ONE, DWORK(PWDL), 1 ) - END IF - CALL DLACPY( 'All', NB, NB, DWORK(PWDL), 2, T(1,NB+1), - $ LDQZ ) - ELSE -C -C Annihilate B(l,k). -C - CALL DLASET( 'All', NBL+NB, NBL+NB, ZERO, ZERO, T, - $ LDQZ ) - CALL DLACPY( 'All', NBL, NBL, A(L,L), LDA, T, LDQZ ) - CALL DLACPY( 'All', NBL, NB, B(L,K), LDB, T(1,NBL+1), - $ LDQZ ) - CALL DLACPY( 'All', NB, NB, DWORK(PWCK), 2, - $ T(NBL+1,NBL+1), LDQZ ) - PWDL = PWD + 2*( L - 1 ) - END IF -C - CALL DGEES( 'V', 'Not Sorted', LFDUM, NB+NBL, T, LDQZ, - $ MM, WRNEW, WINEW, Q, LDQZ, DW12, 12, LDUM, - $ IERR ) - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 3 - RETURN - END IF -C -C Reorder Schur form. -C - MM = 0 - DO 70 I = 1, NB+NBL - IF ( WRNEW(I).GT.0 ) THEN - MM = MM + 1 - SELNEW(I) = .TRUE. - ELSE - SELNEW(I) = .FALSE. - END IF - 70 CONTINUE - IF ( MM.LT.NB ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 4 - RETURN - END IF - CALL DTRSEN( 'None', 'V', SELNEW, NB+NBL, T, LDQZ, Q, - $ LDQZ, WRNEW, WINEW, MM, TEMP, TEMP, DW12, - $ 4, IDUM, 1, IERR ) - IF ( IERR.NE.0 ) THEN - DWORK(1) = DBLE( WRKMIN ) - INFO = 2 - RETURN - END IF -C -C Permute Q if necessary. -C - IF ( K.NE.L ) THEN - CALL DLACPY( 'All', NBL, NB+NBL, Q, LDQZ, Z(NB+1,1), - $ LDQZ ) - CALL DLACPY( 'All', NB, NB+NBL, Q(NBL+1,1), LDQZ, - $ Z, LDQZ ) - CALL DLACPY( 'All', NB+NBL, NB+NBL, Z, LDQZ, Q, LDQZ ) - END IF -C -C Update "diagonal" blocks. -C - CALL DLACPY( 'All', NB, NB, T, LDQZ, DWORK(PWCK), 2 ) - CALL DLACPY( 'All', NB, NBL, T(1,NB+1), LDQZ, - $ DWORK(PWDL), 2 ) - IF ( NB.EQ.1 ) THEN - CALL DSCAL( NBL, -ONE, DWORK(PWDL), 2 ) - ELSE - CALL DSCAL( 2*NBL, -ONE, DWORK(PWDL), 1 ) - END IF - CALL DLACPY( 'All', NBL, NBL, T(NB+1,NB+1), LDQZ, - $ A(L,L), LDA ) -C -C Update block columns of A and B. -C - LEN = L - 1 - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NB, ONE, B(1,K), LDB, Q, LDQZ, ZERO, - $ DWORK(PW), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NB, ONE, B(1,K), LDB, Q(1,NB+1), LDQZ, - $ ZERO, DWORK(PW+2*M), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NBL, ONE, A(1,L), LDA, Q(NB+1,1), LDQZ, - $ ONE, DWORK(PW), M ) - CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, B(1,K), - $ LDB ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NBL, ONE, A(1,L), LDA, Q(NB+1,NB+1), - $ LDQZ, ONE, DWORK(PW+2*M), M ) - CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, - $ A(1,L), LDA ) - END IF -C -C Update block column of A. -C - LEN = M - L - NBL + 1 - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, - $ ONE, Q, LDQZ, DWORK(PWDL+2*NBL), 2, ZERO, - $ DWORK(PW), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, - $ -ONE, Q(1,NB+1), LDQZ, DWORK(PWDL+2*NBL), - $ 2, ZERO, DWORK(PW+2*M), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, - $ -ONE, Q(NB+1,1), LDQZ, A(L,L+NBL), LDA, - $ ONE, DWORK(PW), 2 ) - CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, - $ DWORK(PWDL+2*NBL), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, - $ NBL, ONE, Q(NB+1,NB+1), LDQZ, A(L,L+NBL), - $ LDA, ONE, DWORK(PW+2*M), 2 ) - CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, - $ A(L,L+NBL), LDA ) - END IF -C -C Update block row of B. -C - LEN = M - K - NB + 1 - IF ( LEN.GT.0 ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, - $ ONE, Q, LDQZ, DWORK(PWCK+2*NB), 2, ZERO, - $ DWORK(PW), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, - $ ONE, Q(1,NB+1), LDQZ, DWORK(PWCK+2*NB), 2, - $ ZERO, DWORK(PW+2*M), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, - $ ONE, Q(NB+1,1), LDQZ, B(L,K+NB), LDB, ONE, - $ DWORK(PW), 2 ) - CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, - $ DWORK(PWCK+2*NB), 2 ) - CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, - $ NBL, ONE, Q(NB+1,NB+1), LDQZ, B(L,K+NB), - $ LDB, ONE, DWORK(PW+2*M), 2 ) - CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, - $ B(L,K+NB), LDB ) - END IF -C -C Update W. -C - IF ( WANTW ) THEN - IF ( INITW ) THEN - POS = L - LEN = K + NB - L - ELSE - POS = 1 - LEN = M - END IF - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NB, ONE, W(POS,K), LDW, Q, LDQZ, ZERO, - $ DWORK(PW), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NB, ONE, W(POS,K), LDW, Q(1,NB+1), LDQZ, - $ ZERO, DWORK(PW+2*M), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,1), - $ LDQZ, ONE, DWORK(PW), M ) - CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(POS,K), - $ LDW ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,NB+1), - $ LDQZ, ONE, DWORK(PW+2*M), M ) - CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, - $ W(POS,M+L), LDW ) -C - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NB, ONE, W(M+POS,K), LDW, Q, LDQZ, ZERO, - $ DWORK(PW), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NB, ONE, W(M+POS,K), LDW, Q(1,NB+1), LDQZ, - $ ZERO, DWORK(PW+2*M), M ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, - $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,1), - $ LDQZ, ONE, DWORK(PW), M ) - CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(M+POS,K), - $ LDW ) - CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, - $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,NB+1), - $ LDQZ, ONE, DWORK(PW+2*M), M ) - CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, - $ W(M+POS,M+L), LDW ) - END IF -C - L = L - 1 - NBL = 1 - IF ( L.GT.1 ) THEN - IF ( A(L,L-1).NE.ZERO ) THEN - NBL = 2 - L = L - 1 - END IF - END IF -C -C END WHILE L >= 1 DO -C - IF ( L.GE.1 ) - $ GO TO 60 -C -C Copy recomputed eigenvalues. -C - CALL DCOPY( NB, WRNEW, 1, WR(K), 1 ) - CALL DCOPY( NB, WINEW, 1, WI(K), 1 ) - END IF - 80 CONTINUE - DWORK(1) = DBLE( WRKMIN ) - RETURN -C *** Last line of MB03ZA *** - END -C - LOGICAL FUNCTION LFDUM( X, Y ) -C -C Void logical function for DGEES. -C - DOUBLE PRECISION X, Y - LFDUM = .FALSE. - RETURN -C *** Last line of LFDUM *** - END diff --git a/slycot/src/MB03ZD.f b/slycot/src/MB03ZD.f deleted file mode 100644 index 74e94552..00000000 --- a/slycot/src/MB03ZD.f +++ /dev/null @@ -1,908 +0,0 @@ - SUBROUTINE MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, - $ MM, ILO, SCALE, S, LDS, T, LDT, G, LDG, U1, - $ LDU1, U2, LDU2, V1, LDV1, V2, LDV2, M, WR, WI, - $ US, LDUS, UU, LDUU, LWORK, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the stable and unstable invariant subspaces for a -C Hamiltonian matrix with no eigenvalues on the imaginary axis, -C using the output of the SLICOT Library routine MB03XD. -C -C ARGUMENTS -C -C Mode Parameters -C -C WHICH CHARACTER*1 -C Specifies the cluster of eigenvalues for which the -C invariant subspaces are computed: -C = 'A': select all n eigenvalues; -C = 'S': select a cluster of eigenvalues specified by -C SELECT. -C -C METH CHARACTER*1 -C If WHICH = 'A' this parameter specifies the method to be -C used for computing bases of the invariant subspaces: -C = 'S': compute the n-dimensional basis from a set of -C n vectors; -C = 'L': compute the n-dimensional basis from a set of -C 2*n vectors. -C When in doubt, use METH = 'S'. In some cases, METH = 'L' -C may result in more accurately computed invariant -C subspaces, see [1]. -C -C STAB CHARACTER*1 -C Specifies the type of invariant subspaces to be computed: -C = 'S': compute the stable invariant subspace, i.e., the -C invariant subspace belonging to those selected -C eigenvalues that have negative real part; -C = 'U': compute the unstable invariant subspace, i.e., -C the invariant subspace belonging to those -C selected eigenvalues that have positive real -C part; -C = 'B': compute both the stable and unstable invariant -C subspaces. -C -C BALANC CHARACTER*1 -C Specifies the type of inverse balancing transformation -C required: -C = 'N': do nothing; -C = 'P': do inverse transformation for permutation only; -C = 'S': do inverse transformation for scaling only; -C = 'B': do inverse transformations for both permutation -C and scaling. -C BALANC must be the same as the argument BALANC supplied to -C MB03XD. Note that if the data is further post-processed, -C e.g., for solving an algebraic Riccati equation, it is -C recommended to delay inverse balancing (in particular the -C scaling part) and apply it to the final result only, -C see [2]. -C -C ORTBAL CHARACTER*1 -C If BALANC <> 'N', this option specifies how inverse -C balancing is applied to the computed invariant subspaces: -C = 'B': apply inverse balancing before orthogonal bases -C for the invariant subspaces are computed; -C = 'A': apply inverse balancing after orthogonal bases -C for the invariant subspaces have been computed; -C this may yield non-orthogonal bases if -C BALANC = 'S' or BALANC = 'B'. -C -C SELECT (input) LOGICAL array, dimension (N) -C If WHICH = 'S', SELECT specifies the eigenvalues -C corresponding to the positive and negative square -C roots of the eigenvalues of S*T in the selected cluster. -C To select a real eigenvalue w(j), SELECT(j) must be set -C to .TRUE.. To select a complex conjugate pair of -C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 -C diagonal block, both SELECT(j) and SELECT(j+1) must be set -C to .TRUE.; a complex conjugate pair of eigenvalues must be -C either both included in the cluster or both excluded. -C This array is not referenced if WHICH = 'A'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices S, T and G. N >= 0. -C -C MM (input) INTEGER -C The number of columns in the arrays US and/or UU. -C If WHICH = 'A' and METH = 'S', MM >= N; -C if WHICH = 'A' and METH = 'L', MM >= 2*N; -C if WHICH = 'S', MM >= M. -C The minimal values above for MM give the numbers of -C vectors to be used for computing a basis for the -C invariant subspace(s). -C -C ILO (input) INTEGER -C If BALANC <> 'N', then ILO is the integer returned by -C MB03XD. 1 <= ILO <= N+1. -C -C SCALE (input) DOUBLE PRECISION array, dimension (N) -C If BALANC <> 'N', the leading N elements of this array -C must contain details of the permutation and scaling -C factors, as returned by MB03XD. -C This array is not referenced if BALANC = 'N'. -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix S in real Schur form. -C On exit, the leading N-by-N part of this array is -C overwritten. -C -C LDS INTEGER -C The leading dimension of the array S. LDS >= max(1,N). -C -C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix T. -C On exit, the leading N-by-N part of this array is -C overwritten. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, if METH = 'L', the leading N-by-N part of this -C array must contain a general matrix G. -C On exit, if METH = 'L', the leading N-by-N part of this -C array is overwritten. -C This array is not referenced if METH = 'S'. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= 1. -C LDG >= max(1,N) if METH = 'L'. -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, the leading N-by-N part of this array must -C contain the (1,1) block of an orthogonal symplectic -C matrix U. -C On exit, this array is overwritten. -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= MAX(1,N). -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, the leading N-by-N part of this array must -C contain the (2,1) block of an orthogonal symplectic -C matrix U. -C On exit, this array is overwritten. -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= MAX(1,N). -C -C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) -C On entry, the leading N-by-N part of this array must -C contain the (1,1) block of an orthogonal symplectic -C matrix V. -C On exit, this array is overwritten. -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= MAX(1,N). -C -C V2 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) -C On entry, the leading N-by-N part of this array must -C contain the (2,1) block of an orthogonal symplectic -C matrix V. -C On exit, this array is overwritten. -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= MAX(1,N). -C -C M (output) INTEGER -C The number of selected eigenvalues. -C -C WR (output) DOUBLE PRECISION array, dimension (M) -C WI (output) DOUBLE PRECISION array, dimension (M) -C On exit, the leading M elements of WR and WI contain the -C real and imaginary parts, respectively, of the selected -C eigenvalues that have nonpositive real part. Complex -C conjugate pairs of eigenvalues with real part not equal -C to zero will appear consecutively with the eigenvalue -C having the positive imaginary part first. Note that, due -C to roundoff errors, these numbers may differ from the -C eigenvalues computed by MB03XD. -C -C US (output) DOUBLE PRECISION array, dimension (LDUS,MM) -C On exit, if STAB = 'S' or STAB = 'B', the leading 2*N-by-M -C part of this array contains a basis for the stable -C invariant subspace belonging to the selected eigenvalues. -C This basis is orthogonal unless ORTBAL = 'A'. -C -C LDUS INTEGER -C The leading dimension of the array US. LDUS >= 1. -C If STAB = 'S' or STAB = 'B', LDUS >= 2*N. -C -C UU (output) DOUBLE PRECISION array, dimension (LDUU,MM) -C On exit, if STAB = 'U' or STAB = 'B', the leading 2*N-by-M -C part of this array contains a basis for the unstable -C invariant subspace belonging to the selected eigenvalues. -C This basis is orthogonal unless ORTBAL = 'A'. -C -C LDUU INTEGER -C The leading dimension of the array UU. LDUU >= 1. -C If STAB = 'U' or STAB = 'B', LDUU >= 2*N. -C -C Workspace -C -C LWORK LOGICAL array, dimension (2*N) -C This array is only referenced if WHICH = 'A' and -C METH = 'L'. -C -C IWORK INTEGER array, dimension (2*N), -C This array is only referenced if WHICH = 'A' and -C METH = 'L'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -35, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If WHICH = 'S' or METH = 'S': -C LDWORK >= MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ). -C If WHICH = 'A' and METH = 'L' and -C ( STAB = 'U' or STAB = 'S' ): -C LDWORK >= MAX( 1, 2*N*N + 2*N, 8*N ). -C If WHICH = 'A' and METH = 'L' and STAB = 'B': -C LDWORK >= 8*N + 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: some of the selected eigenvalues are on or too close -C to the imaginary axis; -C = 2: reordering of the product S*T in routine MB03ZA -C failed because some eigenvalues are too close to -C separate; -C = 3: the QR algorithm failed to compute some Schur form -C in MB03ZA; -C = 4: reordering of the Hamiltonian Schur form in routine -C MB03TD failed because some eigenvalues are too close -C to separate. -C -C METHOD -C -C This is an implementation of Algorithm 1 in [1]. -C -C NUMERICAL ASPECTS -C -C The method is strongly backward stable for an embedded -C (skew-)Hamiltonian matrix, see [1]. Although good results have -C been reported if the eigenvalues are not too close to the -C imaginary axis, the method is not backward stable for the original -C Hamiltonian matrix itself. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A new method for computing the stable invariant subspace of a -C real Hamiltonian matrix, J. Comput. Appl. Math., 86, -C pp. 17-43, 1997. -C -C [2] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHASUB). -C -C KEYWORDS -C -C Hamiltonian matrix, invariant subspace. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC, METH, ORTBAL, STAB, WHICH - INTEGER ILO, INFO, LDG, LDS, LDT, LDU1, LDU2, LDUS, - $ LDUU, LDV1, LDV2, LDWORK, M, MM, N -C .. Array Arguments .. - LOGICAL LWORK(*), SELECT(*) - INTEGER IWORK(*) - DOUBLE PRECISION DWORK(*), G(LDG,*), S(LDS,*), SCALE(*), - $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), US(LDUS,*), - $ UU(LDUU,*), V1(LDV1,*), V2(LDV2,*), WI(*), - $ WR(*) -C .. Local Scalars .. - LOGICAL LALL, LBAL, LBEF, LEXT, LUS, LUU, PAIR - INTEGER I, IERR, J, K, PDW, PW, WRKMIN, WRKOPT - DOUBLE PRECISION TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DLACPY, DLASCL, - $ DLASET, DORGQR, DSCAL, MB01UX, MB03TD, MB03ZA, - $ MB04DI, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode and check input parameters. -C - LALL = LSAME( WHICH, 'A' ) - IF ( LALL ) THEN - LEXT = LSAME( METH, 'L' ) - ELSE - LEXT = .FALSE. - END IF - LUS = LSAME( STAB, 'S' ) .OR. LSAME( STAB, 'B' ) - LUU = LSAME( STAB, 'U' ) .OR. LSAME( STAB, 'B' ) - LBAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR. - $ LSAME( BALANC, 'B' ) - LBEF = .FALSE. - IF ( LBAL ) - $ LBEF = LSAME( ORTBAL, 'B' ) -C - WRKMIN = 1 - WRKOPT = WRKMIN -C - INFO = 0 -C - IF ( .NOT.LALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN - INFO = -1 - ELSE IF ( LALL .AND. ( .NOT.LEXT .AND. - $ .NOT.LSAME( METH, 'S' ) ) ) THEN - INFO = -2 - ELSE IF ( .NOT.LUS .AND. .NOT.LUU ) THEN - INFO = -3 - ELSE IF ( .NOT.LBAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN - INFO = -4 - ELSE IF ( LBAL .AND. ( .NOT.LBEF .AND. - $ .NOT.LSAME( ORTBAL, 'A' ) ) ) THEN - INFO = -5 - ELSE - IF ( LALL ) THEN - M = N - ELSE -C -C Set M to the dimension of the specified invariant subspace. -C - M = 0 - PAIR = .FALSE. - DO 10 K = 1, N - IF ( PAIR ) THEN - PAIR = .FALSE. - ELSE - IF ( K.LT.N ) THEN - IF ( S(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 -C -C Compute workspace requirements. -C - IF ( .NOT.LEXT ) THEN - WRKOPT = MAX( WRKOPT, 4*M*M + MAX( 8*M, 4*N ) ) - ELSE - IF ( LUS.AND.LUU ) THEN - WRKOPT = MAX( WRKOPT, 8*N + 1 ) - ELSE - WRKOPT = MAX( WRKOPT, 2*N*N + 2*N, 8*N ) - END IF - END IF -C - IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( MM.LT.M .OR. ( LEXT .AND. MM.LT.2*N ) ) THEN - INFO = -8 - ELSE IF ( LBAL .AND. ( ILO.LT.1 .OR. ILO.GT.N+1 ) ) THEN - INFO = -9 - ELSE IF ( LDS.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF ( LDG.LT.1 .OR. ( LEXT .AND. LDG.LT.N ) ) THEN - INFO = -16 - ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF ( LDUS.LT.1 .OR. ( LUS .AND. LDUS.LT.2*N ) ) THEN - INFO = -29 - ELSE IF ( LDUU.LT.1 .OR. ( LUU .AND. LDUU.LT.2*N ) ) THEN - INFO = -31 - ELSE IF ( LDWORK.LT.WRKMIN ) THEN - INFO = -35 - DWORK(1) = DBLE( WRKMIN ) - END IF - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB03ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF - WRKOPT = WRKMIN -C - IF ( .NOT.LEXT ) THEN -C -C Workspace requirements: 4*M*M + MAX( 8*M, 4*N ). -C - PW = 1 - PDW = PW + 4*M*M - CALL MB03ZA( 'No Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, U2, - $ LDU2, V1, LDV1, V2, LDV2, DWORK(PW), 2*M, WR, WI, - $ M, DWORK(PDW), LDWORK-PDW+1, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 -C - PDW = PW + 2*M*M - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, - $ DWORK(PW), 2*M, V1, LDV1, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C - IF ( LUS ) - $ CALL DLACPY( 'All', N, M, V1, LDV1, US, LDUS ) - IF ( LUU ) - $ CALL DLACPY( 'All', N, M, V1, LDV1, UU, LDUU ) -C - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, - $ DWORK(PW+M), 2*M, U1, LDU1, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) -C - IF ( LUS ) THEN - DO 20 J = 1, M - CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,J), 1 ) - 20 CONTINUE - END IF - IF ( LUU ) THEN - DO 30 J = 1, M - CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,J), 1 ) - 30 CONTINUE - END IF -C - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, -ONE, - $ DWORK(PW), 2*M, V2, LDV2, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) -C - IF ( LUS ) - $ CALL DLACPY( 'All', N, M, V2, LDV2, US(N+1,1), LDUS ) - IF ( LUU ) - $ CALL DLACPY( 'All', N, M, V2, LDV2, UU(N+1,1), LDUU ) -C - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, - $ DWORK(PW+M), 2*M, U2, LDU2, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) -C - IF ( LUS ) THEN - DO 40 J = 1, M - CALL DAXPY( N, ONE, U2(1,J), 1, US(N+1,J), 1 ) - 40 CONTINUE - END IF - IF ( LUU ) THEN - DO 50 J = 1, M - CALL DAXPY( N, -ONE, U2(1,J), 1, UU(N+1,J), 1 ) - 50 CONTINUE - END IF -C -C Orthonormalize obtained bases and apply inverse balancing -C transformation. -C - IF ( LBAL .AND. LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF -C - IF ( LUS ) THEN - CALL DGEQRF( 2*N, M, US, LDUS, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - CALL DORGQR( 2*N, M, M, US, LDUS, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - END IF - IF ( LUU ) THEN - CALL DGEQRF( 2*N, M, UU, LDUU, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - CALL DORGQR( 2*N, M, M, UU, LDUU, DWORK(1), DWORK(M+1), - $ LDWORK-M, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) - END IF -C - IF ( LBAL .AND. .NOT.LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF -C - ELSE -C - DO 60 I = 1, 2*N - LWORK(I) = .TRUE. - 60 CONTINUE -C - IF ( LUS .AND.( .NOT.LUU ) ) THEN -C -C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) -C - CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, - $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, - $ WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 -C - CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C - DO 70 J = 1, N - CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) - 70 CONTINUE - PDW = 2*N*N+1 -C -C DW <- -[V1;V2]*W11 -C - CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) - CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, - $ US, LDUS, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C -C DW2 <- DW2 - U2*W21 -C - CALL DLACPY( 'All', N, N, U2, LDU2, US, LDUS ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, - $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 80 J = 1, N - CALL DAXPY( N, ONE, US(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) - 80 CONTINUE -C -C US11 <- -U1*W21 - DW1 -C - CALL DLACPY( 'All', N, N, U1, LDU1, US, LDUS ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, - $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 90 J = 1, N - CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, US(1,J), 1 ) - 90 CONTINUE -C -C US21 <- DW2 -C - CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, US(N+1,1), LDUS ) -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, - $ IERR ) - CALL DLACPY( 'All', N, N, V1, LDV1, US(1,N+1), LDUS ) - CALL DLACPY( 'All', N, N, V2, LDV2, US(N+1,N+1), LDUS ) - DO 100 J = 1, N - CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,N+J), 1 ) - 100 CONTINUE - DO 110 J = 1, N - CALL DAXPY( N, -ONE, U2(1,J), 1, US(N+1,N+J), 1 ) - 110 CONTINUE -C - CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, - $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), - $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, US(N+1,N+1), - $ LDUS, IERR ) -C - ELSE IF ( ( .NOT.LUS ).AND.LUU ) THEN -C -C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) -C - CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, - $ U2, LDU2, V1, LDV1, V2, LDV2, UU, LDUU, WR, - $ WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 - CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, - $ UU(N+1,N+1), LDUU, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(1,N+1), LDUU, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - DO 120 J = 1, N - CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) - 120 CONTINUE - PDW = 2*N*N+1 -C -C DW <- -[V1;V2]*W11 -C - CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) - CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, - $ UU, LDUU, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) -C -C DW2 <- DW2 - U2*W21 -C - CALL DLACPY( 'All', N, N, U2, LDU2, UU, LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, - $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 130 J = 1, N - CALL DAXPY( N, ONE, UU(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) - 130 CONTINUE -C -C UU11 <- U1*W21 - DW1 -C - CALL DLACPY( 'All', N, N, U1, LDU1, UU, LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, - $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), - $ LDWORK-PDW+1, IERR ) - DO 140 J = 1, N - CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, UU(1,J), 1 ) - 140 CONTINUE -C -C UU21 <- DW2 -C - CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, UU(N+1,1), LDUU ) -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(1,N+1), LDUU, V1, LDV1, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(1,N+1), LDUU, V2, LDV2, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(N+1,N+1), LDUU, U1, LDU1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ UU(N+1,N+1), LDUU, U2, LDU2, DWORK, LDWORK, - $ IERR ) - CALL DLACPY( 'All', N, N, V1, LDV1, UU(1,N+1), LDUU ) - CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,N+1), LDUU ) - DO 150 J = 1, N - CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,N+J), 1 ) - 150 CONTINUE - DO 160 J = 1, N - CALL DAXPY( N, ONE, U2(1,J), 1, UU(N+1,N+J), 1 ) - 160 CONTINUE -C - CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, - $ S, LDS, G, LDG, UU(1,N+1), LDUU, UU(N+1,N+1), - $ LDUU, WR, WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, UU(N+1,N+1), - $ LDUU, IERR ) - ELSE -C -C Workspace requirements: 8*N -C - CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, - $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, - $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, - $ WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) - $ GO TO 250 - CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, - $ IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - DO 170 J = 1, N - CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) - 170 CONTINUE -C -C UU = [ V1 -V2; U1 -U2 ]*diag(W11,W21) -C - CALL DLACPY( 'All', N, N, V1, LDV1, UU, LDUU ) - CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,1), LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, - $ US, LDUS, UU, LDUU, DWORK, LDWORK, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL DLACPY( 'All', N, N, U1, LDU1, UU(1,N+1), LDUU ) - CALL DLACPY( 'All', N, N, U2, LDU2, UU(N+1,N+1), LDUU ) - CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, - $ US(N+1,1), LDUS, UU(1,N+1), LDUU, DWORK, - $ LDWORK, IERR ) - CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, 2*N, UU(N+1,1), - $ LDUU, IERR ) -C - CALL DLACPY( 'All', 2*N, N, UU, LDUU, US, LDUS ) - DO 180 J = 1, N - CALL DAXPY( 2*N, -ONE, UU(1,N+J), 1, US(1,J), 1 ) - 180 CONTINUE - DO 190 J = 1, N - CALL DAXPY( 2*N, ONE, UU(1,N+J), 1, UU(1,J), 1 ) - 190 CONTINUE -C -C V1 <- V1*W12-U1*W22 -C U1 <- V1*W12+U1*W22 -C V2 <- V2*W12-U2*W22 -C U2 <- V2*W12+U2*W22 -C - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, - $ IERR ) - CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, - $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, - $ IERR ) - DO 210 J = 1, N - DO 200 I = 1, N - TEMP = V1(I,J) - V1(I,J) = TEMP - U1(I,J) - U1(I,J) = TEMP + U1(I,J) - 200 CONTINUE - 210 CONTINUE - DO 230 J = 1, N - DO 220 I = 1, N - TEMP = V2(I,J) - V2(I,J) = TEMP - U2(I,J) - U2(I,J) = TEMP + U2(I,J) - 220 CONTINUE - 230 CONTINUE -C - CALL DLASET( 'All', 2*N, N, ZERO, ONE, US(1,N+1), LDUS ) - CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, - $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), - $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ U1, LDU1, US(1,N+1), LDUS, ZERO, UU(1,N+1), - $ LDUU ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ U2, LDU2, US(N+1,N+1), LDUS, ONE, UU(1,N+1), - $ LDUU ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ U1, LDU1, US(N+1,N+1), LDUS, ZERO, UU(N+1,N+1), - $ LDUU ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ U2, LDU2, US(1,N+1), LDUS, ONE, UU(N+1,N+1), - $ LDUU ) - CALL DLACPY( 'All', N, N, US(1,N+1), LDUS, U1, LDU1 ) - CALL DLACPY( 'All', N, N, US(N+1,N+1), LDUS, U2, LDU2 ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, - $ V1, LDV1, U1, LDU1, ZERO, US(1,N+1), LDUS ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ V2, LDV2, U2, LDU2, ONE, US(1,N+1), LDUS ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ V1, LDV1, U2, LDU2, ZERO, US(N+1,N+1), LDUS ) - CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, - $ V2, LDV2, U1, LDU1, ONE, US(N+1,N+1), LDUS ) - END IF -C -C Orthonormalize obtained bases and apply inverse balancing -C transformation. -C - IF ( LBAL .AND. LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF -C -C Workspace requirements: 8*N+1 -C - DO 240 J = 1, 2*N - IWORK(J) = 0 - 240 CONTINUE - IF ( LUS ) THEN - CALL DGEQP3( 2*N, 2*N, US, LDUS, IWORK, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - CALL DORGQR( 2*N, 2*N, N, US, LDUS, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - END IF - IF ( LUU ) THEN - CALL DGEQP3( 2*N, 2*N, UU, LDUU, IWORK, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - CALL DORGQR( 2*N, 2*N, N, UU, LDUU, DWORK, DWORK(2*N+1), - $ LDWORK-2*N, IERR ) - WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) - END IF -C - IF ( LBAL .AND. .NOT.LBEF ) THEN - IF ( LUS ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, - $ LDUS, US(N+1,1), LDUS, IERR ) - IF ( LUU ) - $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, - $ LDUU, UU(N+1,1), LDUU, IERR ) - END IF - END IF -C - CALL DSCAL( M, -ONE, WR, 1 ) - DWORK(1) = DBLE( WRKOPT ) -C - RETURN - 250 CONTINUE - IF ( IERR.EQ.1 ) THEN - INFO = 2 - ELSE IF ( IERR.EQ.2 .OR. IERR.EQ.4 ) THEN - INFO = 1 - ELSE IF ( IERR.EQ.3 ) THEN - INFO = 3 - END IF - RETURN -C *** Last line of MB03ZD *** - END diff --git a/slycot/src/MB04DD.f b/slycot/src/MB04DD.f deleted file mode 100644 index 857bceef..00000000 --- a/slycot/src/MB04DD.f +++ /dev/null @@ -1,440 +0,0 @@ - SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance a real Hamiltonian matrix, -C -C [ A G ] -C H = [ T ] , -C [ Q -A ] -C -C where A is an N-by-N matrix and G, Q are N-by-N symmetric -C matrices. This involves, first, permuting H by a symplectic -C similarity transformation to isolate eigenvalues in the first -C 1:ILO-1 elements on the diagonal of A; and second, applying a -C diagonal similarity transformation to rows and columns -C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm -C as possible. Both steps are optional. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the operations to be performed on H: -C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; -C = 'P': permute only; -C = 'S': scale only; -C = 'B': both permute and scale. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix A of the balanced Hamiltonian. In particular, -C the lower triangular part of the first ILO-1 columns of A -C is zero. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain the lower triangular part of the matrix Q and -C the upper triangular part of the matrix G. -C On exit, the leading N-by-N+1 part of this array contains -C the lower and upper triangular parts of the matrices Q and -C G, respectively, of the balanced Hamiltonian. In -C particular, the lower triangular and diagonal part of the -C first ILO-1 columns of QG is zero. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C ILO (output) INTEGER -C ILO-1 is the number of deflated eigenvalues in the -C balanced Hamiltonian matrix. -C -C SCALE (output) DOUBLE PRECISION array of dimension (N) -C Details of the permutations and scaling factors applied to -C H. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, -C then rows and columns P(j) and P(j)+N are interchanged -C with rows and columns j and j+N, respectively. If -C P(j) > N, then row and column P(j)-N are interchanged with -C row and column j+N by a generalized symplectic -C permutation. For j = ILO,...,N the j-th element of SCALE -C contains the factor of the scaling applied to row and -C column j. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAL). -C -C KEYWORDS -C -C Balancing, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER ILO, INFO, LDA, LDQG, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) -C .. Local Scalars .. - LOGICAL CONV, LPERM, LSCAL - INTEGER I, IC, ILOOLD, J - DOUBLE PRECISION C, F, GII, MAXC, MAXR, QII, R, SCLFAC, - $ SFMAX1, SFMAX2, SFMIN1, SFMIN2, TEMP -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) - LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) -C - IF ( .NOT.LPERM .AND. .NOT.LSCAL - $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN - INFO = -1 - ELSE IF ( N.LT.0 ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C -C Return if there were illegal values. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DD', -INFO ) - RETURN - END IF -C - ILO = 1 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN - IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN - DO 10 I = 1, N - SCALE(I) = ONE - 10 CONTINUE - RETURN - END IF -C -C Permutations to isolate eigenvalues if possible. -C - IF ( LPERM ) THEN - ILOOLD = 0 -C WHILE ( ILO.NE.ILOOLD ) - 20 IF ( ILO.NE.ILOOLD ) THEN - ILOOLD = ILO -C -C Scan columns ILO .. N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 40 J = ILO, I-1 - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 40 CONTINUE - DO 50 J = I+1, N - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 50 CONTINUE - DO 60 J = ILO, I - IF ( QG(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 60 CONTINUE - DO 70 J = I+1, N - IF ( QG(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 70 CONTINUE -C -C Exchange columns/rows ILO <-> I. -C - SCALE( ILO ) = DBLE( I ) - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) - CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) - CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) -C - CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), - $ LDQG ) - CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), - $ 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 30 -C -C Scan columns N+ILO .. 2*N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 90 J = ILO, I-1 - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 90 CONTINUE - DO 100 J = I+1, N - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 100 CONTINUE - DO 110 J = ILO, I - IF ( QG(J,I+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 110 CONTINUE - DO 120 J = I+1, N - IF ( QG(I,J+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 120 CONTINUE - SCALE( ILO ) = DBLE( N+I ) -C -C Exchange columns/rows I <-> I+N with a symplectic -C generalized permutation. -C - CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) - CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) - CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) - CALL DSCAL( N-I, -ONE, A(I,I+1), LDA ) - CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) - CALL DSCAL( I-1, -ONE, A(1,I), 1 ) - CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) - CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) - A(I,I) = -A(I,I) - TEMP = QG(I,I) - QG(I,I) = -QG(I,I+1) - QG(I,I+1) = -TEMP -C -C Exchange columns/rows ILO <-> I. -C - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) - CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) - CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) -C - CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), - $ LDQG ) - CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), - $ 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 80 - GOTO 20 - END IF -C END WHILE 20 - END IF -C - DO 130 I = ILO, N - SCALE(I) = ONE - 130 CONTINUE -C -C Scale to reduce the 1-norm of the remaining blocks. -C - IF ( LSCAL ) THEN - SCLFAC = DLAMCH( 'B' ) - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C -C Scale the rows and columns one at a time to minimize the -C 1-norm of the remaining Hamiltonian submatrix. -C Stop when the 1-norm is very roughly minimal. -C - 140 CONTINUE - CONV = .TRUE. - DO 170 I = ILO, N -C -C Compute 1-norm of row and column I without diagonal -C elements. -C - R = DASUM( I-ILO, A(I,ILO), LDA ) + - $ DASUM( N-I, A(I,I+1), LDA ) + - $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + - $ DASUM( N-I, QG(I,I+2), LDQG ) - C = DASUM( I-ILO, A(ILO,I), 1 ) + - $ DASUM( N-I, A(I+1,I), 1 ) + - $ DASUM( I-ILO, QG(I,ILO), LDQG ) + - $ DASUM( N-I, QG(I+1,I), 1 ) - QII = ABS( QG(I,I) ) - GII = ABS( QG(I,I+1) ) -C -C Compute inf-norms of row and column I. -C - IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) - MAXR = ABS( A(I,IC+ILO-1) ) - IF ( I.GT.1 ) THEN - IC = IDAMAX( I-1, QG(1,I+1), 1 ) - MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I,I+2), LDQG ) - MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) - END IF - IC = IDAMAX( N, A(1,I), 1 ) - MAXC = ABS( A(IC,I) ) - IF ( I.GT.ILO ) THEN - IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) - MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I+1,I), 1 ) - MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) - END IF - IF ( ( C + QII ).EQ.ZERO .OR. ( R + GII ).EQ.ZERO ) - $ GO TO 170 -C - F = ONE - 150 CONTINUE - IF ( ( ( R + GII/SCLFAC )/SCLFAC ).GE. - $ ( ( C + QII*SCLFAC )*SCLFAC ) .AND. - $ MAX( F*SCLFAC, C*SCLFAC, MAXC*SCLFAC, - $ QII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. - $ MIN( ( R + GII/SCLFAC )/SCLFAC, MAX( MAXR/SCLFAC, - $ GII/SCLFAC/SCLFAC ) ).GT.SFMIN2 ) THEN - F = F*SCLFAC - C = C*SCLFAC - QII = QII*SCLFAC*SCLFAC - R = R / SCLFAC - GII = GII/SCLFAC/SCLFAC - MAXC = MAXC*SCLFAC - MAXR = MAXR / SCLFAC - GO TO 150 - END IF -C - 160 CONTINUE - IF ( ( ( R + GII*SCLFAC )*SCLFAC ).LE. - $ ( ( C + QII/SCLFAC )/SCLFAC ) .AND. - $ MAX( R*SCLFAC, MAXR*SCLFAC, - $ GII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. - $ MIN( F/SCLFAC, ( C + QII/SCLFAC )/SCLFAC, - $ MAX( MAXC/SCLFAC, QII/SCLFAC/SCLFAC ) ) - $ .GT.SFMIN2 ) THEN - F = F / SCLFAC - C = C / SCLFAC - QII = QII/SCLFAC/SCLFAC - R = R*SCLFAC - GII = GII*SCLFAC*SCLFAC - MAXC = MAXC/SCLFAC - MAXR = MAXR*SCLFAC - GO TO 160 - END IF -C -C Now balance if necessary. -C - IF ( F.NE.ONE ) THEN - IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN - IF ( F*SCALE(I).LE.SFMIN1 ) - $ GO TO 170 - END IF - IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN - IF ( SCALE(I).GE.SFMAX1 / F ) - $ GO TO 170 - END IF - CONV = .FALSE. - SCALE(I) = SCALE(I)*F - CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) - CALL DRSCL( N-I, F, A(I,I+1), LDA ) - CALL DSCAL( I-1, F, A(1,I), 1 ) - CALL DSCAL( N-I, F, A(I+1,I), 1 ) - CALL DRSCL( I-1, F, QG(1,I+1), 1 ) - QG(I,I+1) = QG(I,I+1) / F / F - CALL DRSCL( N-I, F, QG(I,I+1+1), LDQG ) - CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) - QG(I,I) = QG(I,I) * F * F - CALL DSCAL( N-I, F, QG(I+1,I), 1 ) - END IF - 170 CONTINUE - IF ( .NOT.CONV ) GO TO 140 - END IF - RETURN -C *** Last line of MB04DD *** - END diff --git a/slycot/src/MB04DI.f b/slycot/src/MB04DI.f deleted file mode 100644 index 793d6ab5..00000000 --- a/slycot/src/MB04DI.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the inverse of a balancing transformation, computed by -C the SLICOT Library routines MB04DD or MB04DS, to a 2*N-by-M matrix -C -C [ V1 ] -C [ ], -C [ sgn*V2 ] -C -C where sgn is either +1 or -1. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the type of inverse transformation required: -C = 'N': do nothing, return immediately; -C = 'P': do inverse transformation for permutation only; -C = 'S': do inverse transformation for scaling only; -C = 'B': do inverse transformations for both permutation -C and scaling. -C JOB must be the same as the argument JOB supplied to -C MB04DD or MB04DS. -C -C SGN CHARACTER*1 -C Specifies the sign to use for V2: -C = 'P': sgn = +1; -C = 'N': sgn = -1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrices V1 and V2. N >= 0. -C -C ILO (input) INTEGER -C The integer ILO determined by MB04DD or MB04DS. -C 1 <= ILO <= N+1. -C -C SCALE (input) DOUBLE PRECISION array, dimension (N) -C Details of the permutation and scaling factors, as -C returned by MB04DD or MB04DS. -C -C M (input) INTEGER -C The number of columns of the matrices V1 and V2. M >= 0. -C -C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix V1. -C On exit, the leading N-by-M part of this array is -C overwritten by the updated matrix V1 of the transformed -C matrix. -C -C LDV1 INTEGER -C The leading dimension of the array V1. LDV1 >= max(1,N). -C -C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix V2. -C On exit, the leading N-by-M part of this array is -C overwritten by the updated matrix V2 of the transformed -C matrix. -C -C LDV2 INTEGER -C The leading dimension of the array V2. LDV2 >= max(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAK). -C -C KEYWORDS -C -C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB, SGN - INTEGER ILO, INFO, LDV1, LDV2, M, N -C .. Array Arguments .. - DOUBLE PRECISION SCALE(*), V1(LDV1,*), V2(LDV2,*) -C .. Local Scalars .. - LOGICAL LPERM, LSCAL, LSGN, SYSW - INTEGER I, K -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) - LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) - LSGN = LSAME( SGN, 'N' ) - IF ( .NOT.LPERM .AND. .NOT.LSCAL - $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN - INFO = -2 - ELSE IF ( N.LT.0 ) THEN - INFO = -3 - ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN - INFO = -4 - ELSE IF ( M.LT.0 ) THEN - INFO = -6 - ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DI', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) - $ RETURN -C -C Inverse scaling. -C - IF ( LSCAL ) THEN - DO 20 I = ILO, N - CALL DRSCL( M, SCALE(I), V1(I,1), LDV1 ) - 20 CONTINUE - DO 30 I = ILO, N - CALL DRSCL( M, SCALE(I), V2(I,1), LDV2 ) - 30 CONTINUE - END IF -C -C Inverse permutation. -C - IF ( LPERM ) THEN - DO 40 I = ILO-1, 1, -1 - K = SCALE( I ) - SYSW = ( K.GT.N ) - IF ( SYSW ) - $ K = K - N -C - IF ( K.NE.I ) THEN -C -C Exchange rows k <-> i. -C - CALL DSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) - CALL DSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) - END IF -C - IF ( SYSW ) THEN -C -C Exchange V1(k,:) <-> V2(k,:). -C - CALL DSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) - IF ( LSGN ) THEN - CALL DSCAL( M, -ONE, V2(K,1), LDV2 ) - ELSE - CALL DSCAL( M, -ONE, V1(K,1), LDV1 ) - END IF - END IF - 40 CONTINUE - END IF -C - RETURN -C *** Last line of MB04DI *** - END diff --git a/slycot/src/MB04DS.f b/slycot/src/MB04DS.f deleted file mode 100644 index f543a97d..00000000 --- a/slycot/src/MB04DS.f +++ /dev/null @@ -1,450 +0,0 @@ - SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance a real skew-Hamiltonian matrix -C -C [ A G ] -C S = [ T ] , -C [ Q A ] -C -C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric -C matrices. This involves, first, permuting S by a symplectic -C similarity transformation to isolate eigenvalues in the first -C 1:ILO-1 elements on the diagonal of A; and second, applying a -C diagonal similarity transformation to rows and columns -C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm -C as possible. Both steps are optional. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the operations to be performed on S: -C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; -C = 'P': permute only; -C = 'S': scale only; -C = 'B': both permute and scale. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix A of the balanced skew-Hamiltonian. In -C particular, the lower triangular part of the first ILO-1 -C columns of A is zero. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N) -C On entry, the leading N-by-N+1 part of this array must -C contain in columns 1:N the strictly lower triangular part -C of the matrix Q and in columns 2:N+1 the strictly upper -C triangular part of the matrix G. The parts containing the -C diagonal and the first supdiagonal of this array are not -C referenced. -C On exit, the leading N-by-N+1 part of this array contains -C the strictly lower and strictly upper triangular parts of -C the matrices Q and G, respectively, of the balanced -C skew-Hamiltonian. In particular, the strictly lower -C triangular part of the first ILO-1 columns of QG is zero. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C ILO (output) INTEGER -C ILO-1 is the number of deflated eigenvalues in the -C balanced skew-Hamiltonian matrix. -C -C SCALE (output) DOUBLE PRECISION array of dimension (N) -C Details of the permutations and scaling factors applied to -C S. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, -C then rows and columns P(j) and P(j)+N are interchanged -C with rows and columns j and j+N, respectively. If -C P(j) > N, then row and column P(j)-N are interchanged with -C row and column j+N by a generalized symplectic -C permutation. For j = ILO,...,N the j-th element of SCALE -C contains the factor of the scaling applied to row and -C column j. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P. -C Symplectic balancing of Hamiltonian matrices. -C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DSHBAL). -C -C KEYWORDS -C -C Balancing, skew-Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - DOUBLE PRECISION FACTOR - PARAMETER ( FACTOR = 0.95D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER ILO, INFO, LDA, LDQG, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) -C .. Local Scalars .. - LOGICAL CONV, LPERM, LSCAL - INTEGER I, IC, ILOOLD, J - DOUBLE PRECISION C, F, G, MAXC, MAXR, R, S, SCLFAC, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2 -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) - LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) -C - IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND. - $ .NOT.LSAME( JOB, 'N' ) ) THEN - INFO = -1 - ELSE IF ( N.LT.0 ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C -C Return if there were illegal values. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DS', -INFO ) - RETURN - END IF -C - ILO = 1 -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN - IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN - DO 10 I = 1, N - SCALE(I) = ONE - 10 CONTINUE - RETURN - END IF -C -C Permutations to isolate eigenvalues if possible. -C - IF ( LPERM ) THEN - ILOOLD = 0 -C WHILE ( ILO.NE.ILOOLD ) - 20 IF ( ILO.NE.ILOOLD ) THEN - ILOOLD = ILO -C -C Scan columns ILO .. N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 40 J = ILO, I-1 - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 40 CONTINUE - DO 50 J = I+1, N - IF ( A(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 50 CONTINUE - DO 60 J = ILO, I-1 - IF ( QG(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 60 CONTINUE - DO 70 J = I+1, N - IF ( QG(J,I).NE.ZERO ) THEN - I = I + 1 - GOTO 30 - END IF - 70 CONTINUE -C -C Exchange columns/rows ILO <-> I. -C - SCALE(ILO) = DBLE( I ) - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - IF ( I.LT.N ) - $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), - $ LDQG ) - END IF -C - CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - IF ( N.GT.I ) - $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), - $ LDQG ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, - $ QG(ILO+1,I+1), 1 ) - END IF - CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 30 -C -C Scan columns N+ILO .. 2*N. -C - I = ILO -C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) - 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN - DO 90 J = ILO, I-1 - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 90 CONTINUE - DO 100 J = I+1, N - IF ( A(I,J).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 100 CONTINUE - DO 110 J = ILO, I-1 - IF ( QG(J,I+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 110 CONTINUE - DO 120 J = I+1, N - IF ( QG(I,J+1).NE.ZERO ) THEN - I = I + 1 - GOTO 80 - END IF - 120 CONTINUE - SCALE(ILO) = DBLE( N+I ) -C -C Exchange columns/rows I <-> I+N with a symplectic -C generalized permutation. -C - CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) - CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) - CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) - CALL DSCAL( N-I, -ONE, QG(I+1,I), 1 ) - CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) - CALL DSCAL( I-1, -ONE, A(1,I), 1 ) - CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) - CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) -C -C Exchange columns/rows ILO <-> I. -C - IF ( ILO.NE.I ) THEN -C - CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) - CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) -C - IF ( I.LT.N ) - $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), - $ LDQG ) - END IF -C - CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) - IF ( N.GT.I ) - $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), - $ LDQG ) - IF ( I.GT.ILO+1 ) THEN - CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) - CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, - $ QG(ILO+1,I+1), 1 ) - END IF - CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) - END IF - ILO = ILO + 1 - END IF -C END WHILE 80 - GOTO 20 - END IF -C END WHILE 20 - END IF -C - DO 130 I = ILO, N - SCALE(I) = ONE - 130 CONTINUE -C -C Scale to reduce the 1-norm of the remaining blocks. -C - IF ( LSCAL ) THEN - SCLFAC = DLAMCH( 'B' ) - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C -C Scale the rows and columns one at a time to minimize the -C 1-norm of the skew-Hamiltonian submatrix. -C Stop when the 1-norm is very roughly minimal. -C - 140 CONTINUE - CONV = .TRUE. - DO 190 I = ILO, N -C -C Compute 1-norm of row and column I without diagonal -C elements. -C - R = DASUM( I-ILO, A(I,ILO), LDA ) + - $ DASUM( N-I, A(I,I+1), LDA ) + - $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + - $ DASUM( N-I, QG(I,I+2), LDQG ) - C = DASUM( I-ILO, A(ILO,I), 1 ) + - $ DASUM( N-I, A(I+1,I), 1 ) + - $ DASUM( I-ILO, QG(I,ILO), LDQG ) + - $ DASUM( N-I, QG(I+1,I), 1 ) -C -C Compute inf-norms of row and column I. -C - IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) - MAXR = ABS( A(I,IC+ILO-1) ) - IF ( I.GT.1 ) THEN - IC = IDAMAX( I-1, QG(1,I+1), 1 ) - MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I,I+2), LDQG ) - MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) - END IF - IC = IDAMAX( N, A(1,I), 1 ) - MAXC = ABS( A(IC,I) ) - IF ( I.GT.ILO ) THEN - IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) - MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) - END IF - IF ( N.GT.I ) THEN - IC = IDAMAX( N-I, QG(I+1,I), 1 ) - MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) - END IF -C - IF ( C.EQ.ZERO .OR. R.EQ.ZERO ) - $ GOTO 190 - G = R / SCLFAC - F = ONE - S = C + R - 150 CONTINUE - IF ( C.GE.G .OR. MAX( F, C, MAXC ).GE.SFMAX2 .OR. - $ MIN( R, G, MAXR ).LE.SFMIN2 ) - $ GOTO 160 - F = F*SCLFAC - G = G / SCLFAC - C = C*SCLFAC - R = R / SCLFAC - MAXC = MAXC*SCLFAC - MAXR = MAXR / SCLFAC - GOTO 150 -C - 160 CONTINUE - G = C / SCLFAC - 170 CONTINUE - IF ( G.LT.R .OR. MAX( R, MAXR ).GE.SFMAX2 .OR. - $ MIN( F, C, G, MAXC ).LE.SFMIN2 ) - $ GOTO 180 - F = F / SCLFAC - G = G / SCLFAC - C = C / SCLFAC - R = R*SCLFAC - MAXC = MAXC / SCLFAC - MAXR = MAXR*SCLFAC - GOTO 170 -C - 180 CONTINUE -C -C Now balance if necessary. -C - IF ( ( C+R ).GE.FACTOR*S ) - $ GOTO 190 - IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN - IF ( F*SCALE(I).LE.SFMIN1 ) - $ GOTO 190 - END IF - IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN - IF ( SCALE(I).GE.SFMAX1 / F ) - $ GOTO 190 - END IF - CONV = .FALSE. - SCALE(I) = SCALE(I)*F - CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) - CALL DRSCL( N-I, F, A(I,I+1), LDA ) - CALL DSCAL( I-1, F, A(1,I), 1 ) - CALL DSCAL( N-I, F, A(I+1,I), 1 ) - CALL DRSCL( I-1, F, QG(1,I+1), 1 ) - CALL DRSCL( N-I, F, QG(I,I+2), LDQG ) - CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) - CALL DSCAL( N-I, F, QG(I+1,I), 1 ) - 190 CONTINUE - IF ( .NOT.CONV ) GOTO 140 - END IF - RETURN -C *** Last line of MB04DS *** - END diff --git a/slycot/src/MB04DY.f b/slycot/src/MB04DY.f deleted file mode 100644 index 6b8b3203..00000000 --- a/slycot/src/MB04DY.f +++ /dev/null @@ -1,329 +0,0 @@ - SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform a symplectic scaling on the Hamiltonian matrix -C -C ( A G ) -C H = ( T ), (1) -C ( Q -A ) -C -C i.e., perform either the symplectic scaling transformation -C -C -1 -C ( A' G' ) ( D 0 ) ( A G ) ( D 0 ) -C H' <-- ( T ) = ( ) ( T ) ( -1 ), (2) -C ( Q' -A' ) ( 0 D ) ( Q -A ) ( 0 D ) -C -C where D is a diagonal scaling matrix, or the symplectic norm -C scaling transformation -C -C ( A'' G'' ) 1 ( A G/tau ) -C H'' <-- ( T ) = --- ( T ), (3) -C ( Q'' -A'' ) tau ( tau Q -A ) -C -C where tau is a real scalar. Note that if tau is not equal to 1, -C then (3) is NOT a similarity transformation. The eigenvalues -C of H are then tau times the eigenvalues of H''. -C -C For symplectic scaling (2), D is chosen to give the rows and -C columns of A' approximately equal 1-norms and to give Q' and G' -C approximately equal norms. (See METHOD below for details.) For -C norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.|| -C denotes the 1-norm (column sum norm). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBSCL CHARACTER*1 -C Indicates which scaling strategy is used, as follows: -C = 'S' : do the symplectic scaling (2); -C = '1' or 'O': do the 1-norm scaling (3); -C = 'N' : do nothing; set INFO and return. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On input, if JOBSCL <> 'N', the leading N-by-N part of -C this array must contain the upper left block A of the -C Hamiltonian matrix H in (1). -C On output, if JOBSCL <> 'N', the leading N-by-N part of -C this array contains the leading N-by-N part of the scaled -C Hamiltonian matrix H' in (2) or H'' in (3), depending on -C the setting of JOBSCL. -C If JOBSCL = 'N', this array is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if JOBSCL <> 'N'; -C LDA >= 1, if JOBSCL = 'N'. -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On input, if JOBSCL <> 'N', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangle of the lower left symmetric block Q of the -C Hamiltonian matrix H in (1), and the N-by-N upper -C triangular part of the submatrix in the columns 2 to N+1 -C of this array must contain the upper triangle of the upper -C right symmetric block G of H in (1). -C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) -C and G(i,j) = G(j,i) is stored in QG(j,i+1). -C On output, if JOBSCL <> 'N', the leading N-by-N lower -C triangular part of this array contains the lower triangle -C of the lower left symmetric block Q' or Q'', and the -C N-by-N upper triangular part of the submatrix in the -C columns 2 to N+1 of this array contains the upper triangle -C of the upper right symmetric block G' or G'' of the scaled -C Hamiltonian matrix H' in (2) or H'' in (3), depending on -C the setting of JOBSCL. -C If JOBSCL = 'N', this array is not referenced. -C -C LDQG INTEGER -C The leading dimension of the array QG. -C LDQG >= MAX(1,N), if JOBSCL <> 'N'; -C LDQG >= 1, if JOBSCL = 'N'. -C -C D (output) DOUBLE PRECISION array, dimension (nd) -C If JOBSCL = 'S', then nd = N and D contains the diagonal -C elements of the diagonal scaling matrix in (2). -C If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau -C from (3). In this case, no other elements of D are -C referenced. -C If JOBSCL = 'N', this array is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C If JOBSCL = 'N', this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, then the i-th argument had an illegal -C value. -C -C METHOD -C -C 1. Symplectic scaling (JOBSCL = 'S'): -C -C First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms -C of the rows and columns of A using a diagonal scaling matrix D_A. -C Then, H is similarily transformed by the symplectic diagonal -C matrix D1 = diag(D_A,D_A**(-1)). Next, the off-diagonal blocks of -C the resulting Hamiltonian matrix are equilibrated in the 1-norm -C using the symplectic diagonal matrix D2 of the form -C -C ( I/rho 0 ) -C D2 = ( ) -C ( 0 rho*I ) -C -C where rho is a real scalar. Thus, in (2), D = D1*D2. -C -C 2. Norm scaling (JOBSCL = '1' or 'O'): -C -C The norm of the matrices A and G of (1) is reduced by setting -C A := A/tau and G := G/(tau**2) where tau is the power of the -C base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and -C ||.|| denotes the 1-norm. -C -C REFERENCES -C -C [1] Benner, P., Byers, R., and Barth, E. -C Fortran 77 Subroutines for Computing the Eigenvalues of -C Hamiltonian Matrices. I: The Square-Reduced Method. -C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. -C -C NUMERICAL ASPECTS -C -C For symplectic scaling, the complexity of the used algorithms is -C hard to estimate and depends upon how well the rows and columns of -C A in (1) are equilibrated. In one sweep, each row/column of A is -C scaled once, i.e., the cost of one sweep is N**2 multiplications. -C Usually, 3-6 sweeps are enough to equilibrate the norms of the -C rows and columns of a matrix. Roundoff errors are possible as -C LAPACK routine DGEBAL does NOT use powers of the machine base for -C scaling. The second stage (equilibrating ||G|| and ||Q||) requires -C N**2 multiplications. -C For norm scaling, 3*N**2 + O(N) multiplications are required and -C NO rounding errors occur as all multiplications are performed with -C powers of the machine base. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, and -C R. Byers, University of Kansas, Lawrence, USA. -C Aug. 1998, routine DHABL. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2009. -C -C KEYWORDS -C -C Balancing, Hamiltonian matrix, norms, symplectic similarity -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDQG, N - CHARACTER JOBSCL -C .. -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), D(*), DWORK(*), QG(LDQG,*) -C .. -C .. Local Scalars .. - DOUBLE PRECISION ANRM, BASE, EPS, GNRM, OFL, QNRM, - $ RHO, SFMAX, SFMIN, TAU, UFL, Y - INTEGER I, IERR, IHI, ILO, J - LOGICAL NONE, NORM, SYMP -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - LOGICAL LSAME - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEBAL, DLABAD, DLASCL, DRSCL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. -C .. Executable Statements .. -C - INFO = 0 - SYMP = LSAME( JOBSCL, 'S' ) - NORM = LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) - NONE = LSAME( JOBSCL, 'N' ) -C - IF( .NOT.SYMP .AND. .NOT.NORM .AND. .NOT.NONE ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.1 .OR. ( .NOT.NONE .AND. LDA.LT.N ) ) THEN - INFO = -4 - ELSE IF( LDQG.LT.1 .OR. ( .NOT.NONE .AND. LDQG.LT.N ) ) THEN - INFO = -6 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04DY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. NONE ) - $ RETURN -C -C Set some machine dependant constants. -C - BASE = DLAMCH( 'Base' ) - EPS = DLAMCH( 'Precision' ) - UFL = DLAMCH( 'Safe minimum' ) - OFL = ONE/UFL - CALL DLABAD( UFL, OFL ) - SFMAX = ( EPS/BASE )/UFL - SFMIN = ONE/SFMAX -C - IF ( NORM ) THEN -C -C Compute norms. -C - ANRM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) - QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) - Y = MAX( ONE, ANRM, GNRM, QNRM ) - TAU = ONE -C -C WHILE ( TAU < Y ) DO - 10 CONTINUE - IF ( ( TAU.LT.Y ) .AND. ( TAU.LT.SQRT( SFMAX ) ) ) THEN - TAU = TAU*BASE - GO TO 10 - END IF -C END WHILE 10 - IF ( TAU.GT.ONE ) THEN - IF ( ABS( TAU/BASE - Y ).LT.ABS( TAU - Y ) ) - $ TAU = TAU/BASE - CALL DLASCL( 'General', 0, 0, TAU, ONE, N, N, A, LDA, IERR ) - CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, - $ IERR ) - CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, - $ IERR ) - END IF -C - D(1) = TAU -C - ELSE - CALL DGEBAL( 'Scale', N, A, LDA, ILO, IHI, D, IERR ) -C - DO 30 J = 1, N -C - DO 20 I = J, N - QG(I,J) = QG(I,J)*D(J)*D(I) - 20 CONTINUE -C - 30 CONTINUE -C - DO 50 J = 2, N + 1 -C - DO 40 I = 1, J - 1 - QG(I,J) = QG(I,J)/D(J-1)/D(I) - 40 CONTINUE -C - 50 CONTINUE -C - GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) - QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) - IF ( GNRM.EQ.ZERO ) THEN - IF ( QNRM.EQ.ZERO ) THEN - RHO = ONE - ELSE - RHO = SFMAX - END IF - ELSE IF ( QNRM.EQ.ZERO ) THEN - RHO = SFMIN - ELSE - RHO = SQRT( QNRM )/SQRT( GNRM ) - END IF -C - CALL DLASCL( 'Lower', 0, 0, RHO, ONE, N, N, QG, LDQG, IERR ) - CALL DLASCL( 'Upper', 0, 0, ONE, RHO, N, N, QG(1,2), LDQG, - $ IERR ) - CALL DRSCL( N, SQRT( RHO ), D, 1 ) - END IF -C - RETURN -C *** Last line of MB04DY *** - END diff --git a/slycot/src/MB04GD.f b/slycot/src/MB04GD.f deleted file mode 100644 index fa7502ec..00000000 --- a/slycot/src/MB04GD.f +++ /dev/null @@ -1,258 +0,0 @@ - SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an RQ factorization with row pivoting of a -C real m-by-n matrix A: P*A = R*Q. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the m-by-n matrix A. -C On exit, -C if m <= n, the upper triangle of the subarray -C A(1:m,n-m+1:n) contains the m-by-m upper triangular -C matrix R; -C if m >= n, the elements on and above the (m-n)-th -C subdiagonal contain the m-by-n upper trapezoidal matrix R; -C the remaining elements, with the array TAU, represent the -C orthogonal matrix Q as a product of min(m,n) elementary -C reflectors (see METHOD). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C JPVT (input/output) INTEGER array, dimension (M) -C On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted -C to the bottom of P*A (a trailing row); if JPVT(i) = 0, -C the i-th row of A is a free row. -C On exit, if JPVT(i) = k, then the i-th row of P*A -C was the k-th row of A. -C -C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -C The scalar factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit -C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Based on LAPACK Library routines DGEQPF and DGERQ2. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Factorization, matrix algebra, matrix operations, orthogonal -C transformation, triangular form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -C .. -C .. Array Arguments .. - INTEGER JPVT( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), TAU( * ) -C .. -C .. Local Scalars .. - INTEGER I, ITEMP, J, K, MA, MKI, NFREE, NKI, PVT - DOUBLE PRECISION AII, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DGERQ2, DLARF, DLARFG, DORMR2, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - 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( 'MB04GD', -INFO ) - RETURN - END IF -C - K = MIN( M, N ) -C -C Move non-free rows bottom. -C - ITEMP = M - DO 10 I = M, 1, -1 - IF( JPVT( I ).NE.0 ) THEN - IF( I.NE.ITEMP ) THEN - CALL DSWAP( N, A( I, 1 ), LDA, A( ITEMP, 1 ), LDA ) - JPVT( I ) = JPVT( ITEMP ) - JPVT( ITEMP ) = I - ELSE - JPVT( I ) = I - END IF - ITEMP = ITEMP - 1 - ELSE - JPVT( I ) = I - END IF - 10 CONTINUE - NFREE = M - ITEMP -C -C Compute the RQ factorization and update remaining rows. -C - IF( NFREE.GT.0 ) THEN - MA = MIN( NFREE, N ) - CALL DGERQ2( MA, N, A(M-MA+1,1), LDA, TAU(K-MA+1), DWORK, - $ INFO ) - CALL DORMR2( 'Right', 'Transpose', M-MA, N, MA, A(M-MA+1,1), - $ LDA, TAU(K-MA+1), A, LDA, DWORK, INFO ) - END IF -C - IF( NFREE.LT.K ) THEN -C -C Initialize partial row norms. The first ITEMP elements of -C DWORK store the exact row norms. (Here, ITEMP is the number of -C free rows, which have been permuted to be the first ones.) -C - DO 20 I = 1, ITEMP - DWORK( I ) = DNRM2( N-NFREE, A( I, 1 ), LDA ) - DWORK( M+I ) = DWORK( I ) - 20 CONTINUE -C -C Compute factorization. -C - DO 40 I = K-NFREE, 1, -1 -C -C Determine ith pivot row and swap if necessary. -C - MKI = M - K + I - NKI = N - K + I - PVT = IDAMAX( MKI, DWORK, 1 ) -C - IF( PVT.NE.MKI ) THEN - CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( MKI ) - JPVT( MKI ) = ITEMP - DWORK( PVT ) = DWORK( MKI ) - DWORK( M+PVT ) = DWORK( M+MKI ) - END IF -C -C Generate elementary reflector H(i) to annihilate -C A(m-k+i,1:n-k+i-1), k = min(m,n). -C - CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) - $ ) -C -C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. -C - AII = A( MKI, NKI ) - A( MKI, NKI ) = ONE - CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, - $ TAU( I ), A, LDA, DWORK( 2*M+1 ) ) - A( MKI, NKI ) = AII -C -C Update partial row norms. -C - DO 30 J = 1, MKI - 1 - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - ( ABS( A( J, NKI ) ) / DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( M+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), LDA ) - DWORK( M+J ) = DWORK( J ) - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - 40 CONTINUE - END IF -C - RETURN -C *** Last line of MB04GD *** - END diff --git a/slycot/src/MB04ID.f b/slycot/src/MB04ID.f deleted file mode 100644 index d28929f2..00000000 --- a/slycot/src/MB04ID.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a QR factorization of an n-by-m matrix A (A = Q * R), -C having a p-by-min(p,m) zero triangle in the lower left-hand side -C corner, as shown below, for n = 8, m = 7, and p = 2: -C -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C A = [ x x x x x x x ], -C [ x x x x x x x ] -C [ 0 x x x x x x ] -C [ 0 0 x x x x x ] -C -C and optionally apply the transformations to an n-by-l matrix B -C (from the left). The problem structure is exploited. This -C computation is useful, for instance, in combined measurement and -C time update of one iteration of the time-invariant Kalman filter -C (square root information filter). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix A. M >= 0. -C -C P (input) INTEGER -C The order of the zero triagle. P >= 0. -C -C L (input) INTEGER -C The number of columns of the matrix B. L >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix A. The elements corresponding to the -C zero P-by-MIN(P,M) lower trapezoidal/triangular part -C (if P > 0) are not referenced. -C On exit, the elements on and above the diagonal of this -C array contain the MIN(N,M)-by-M upper trapezoidal matrix -C R (R is upper triangular, if N >= M) of the QR -C factorization, and the relevant elements below the -C diagonal contain the trailing components (the vectors v, -C see Method) of the elementary reflectors used in the -C factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,L) -C On entry, the leading N-by-L part of this array must -C contain the matrix B. -C On exit, the leading N-by-L part of this array contains -C the updated matrix B. -C If L = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if L > 0; -C LDB >= 1 if L = 0. -C -C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,M-1,M-P,L). -C For optimum performance LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses min(N,M) Householder transformations exploiting -C the zero pattern of the matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an (N-P+I-2)-vector. The components of v are stored -C i i -C in the i-th column of A, beginning from the location i+1, and -C tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009, -C Apr. 2009. -C -C KEYWORDS -C -C Elementary reflector, QR factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, NB, WRKOPT - DOUBLE PRECISION FIRST -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DGEQRF, DLARF, DLARFG, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LQUERY = ( LDWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -8 - ELSE - I = MAX( 1, M - 1, M - P, L ) - IF( LQUERY ) THEN - IF( M.GT.P ) THEN - NB = ILAENV( 1, 'DGEQRF', ' ', N-P, M-P, -1, -1 ) - WRKOPT = MAX( I, ( M - P )*NB ) - IF ( L.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', N-P, L, - $ MIN(N,M)-P, -1 ) ) - WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) - END IF - END IF - ELSE IF( LDWORK.LT.I ) THEN - INFO = -11 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04ID', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - ELSE IF( N.LE.P+1 ) THEN - DO 5 I = 1, MIN( N, M ) - TAU(I) = ZERO - 5 CONTINUE - DWORK(1) = ONE - RETURN - END IF -C -C Annihilate the subdiagonal elements of A and apply the -C transformations to B, if L > 0. -C Workspace: need MAX(M-1,L). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 10 I = 1, MIN( P, M ) -C -C Exploit the structure of the I-th column of A. -C - CALL DLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C - FIRST = A(I,I) - A(I,I) = ONE -C - IF ( I.LT.M ) CALL DLARF( 'Left', N-P, M-I, A(I,I), 1, - $ TAU(I), A(I,I+1), LDA, DWORK ) - IF ( L.GT.0 ) CALL DLARF( 'Left', N-P, L, A(I,I), 1, TAU(I), - $ B(I,1), LDB, DWORK ) -C - A(I,I) = FIRST - END IF - 10 CONTINUE -C - WRKOPT = MAX( 1, M - 1, L ) -C -C Fast QR factorization of the remaining right submatrix, if any. -C Workspace: need M-P; prefer (M-P)*NB. -C - IF( M.GT.P ) THEN - CALL DGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C - IF ( L.GT.0 ) THEN -C -C Apply the transformations to B. -C Workspace: need L; prefer L*NB. -C - CALL DORMQR( 'Left', 'Transpose', N-P, L, MIN(N,M)-P, - $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF - END IF -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of MB04ID *** - END diff --git a/slycot/src/MB04IY.f b/slycot/src/MB04IY.f deleted file mode 100644 index 4b07b2c3..00000000 --- a/slycot/src/MB04IY.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To overwrite the real n-by-m matrix C with Q' * C, Q * C, -C C * Q', or C * Q, according to the following table -C -C SIDE = 'L' SIDE = 'R' -C TRANS = 'N': Q * C C * Q -C TRANS = 'T': Q'* C C * Q' -C -C where Q is a real orthogonal matrix defined as the product of -C k elementary reflectors -C -C Q = H(1) H(2) . . . H(k) -C -C as returned by SLICOT Library routine MB04ID. Q is of order n -C if SIDE = 'L' and of order m if SIDE = 'R'. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specify if Q or Q' is applied from the left or right, -C as follows: -C = 'L': apply Q or Q' from the left; -C = 'R': apply Q or Q' from the right. -C -C TRANS CHARACTER*1 -C Specify if Q or Q' is to be applied, as follows: -C = 'N': apply Q (No transpose); -C = 'T': apply Q' (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix C. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix C. M >= 0. -C -C K (input) INTEGER -C The number of elementary reflectors whose product defines -C the matrix Q. -C N >= K >= 0, if SIDE = 'L'; -C M >= K >= 0, if SIDE = 'R'. -C -C P (input) INTEGER -C The order of the zero triagle (or the number of rows of -C the zero trapezoid) in the matrix triangularized by SLICOT -C Library routine MB04ID. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,K) -C On input, the elements in the rows i+1:min(n,n-p-1+i) of -C the i-th column, and TAU(i), represent the orthogonal -C reflector H(i), so that matrix Q is the product of -C elementary reflectors: Q = H(1) H(2) . . . H(k). -C A is modified by the routine but restored on exit. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,N), if SIDE = 'L'; -C LDA >= max(1,M), if SIDE = 'R'. -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C The scalar factors of the elementary reflectors. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix C. -C On exit, the leading N-by-M part of this array contains -C the updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,M), if SIDE = 'L'; -C LDWORK >= MAX(1,N), if SIDE = 'R'. -C For optimum performance LDWORK >= M*NB if SIDE = 'L', -C or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal -C block size. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If SIDE = 'L', each elementary reflector H(i) modifies -C n-p elements of each column of C, for i = 1:p+1, and -C n-i+1 elements, for i = p+2:k. -C If SIDE = 'R', each elementary reflector H(i) modifies -C m-p elements of each row of C, for i = 1:p+1, and -C m-i+1 elements, for i = p+2:k. -C -C NUMERICAL ASPECTS -C -C The implemented method is numerically stable. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix operations, QR decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER INFO, K, LDA, LDC, LDWORK, M, N, P - CHARACTER SIDE, TRANS -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * ) -C .. Local Scalars .. - LOGICAL LEFT, TRAN - INTEGER I - DOUBLE PRECISION AII, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C -C Check the scalar input arguments. -C - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - TRAN = LSAME( TRANS, 'T' ) -C - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR. - $ ( .NOT.LEFT .AND. K.GT.M ) ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04IY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P ) - $ .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF( LEFT ) THEN - WRKOPT = DBLE( M ) - IF( TRAN ) THEN -C - DO 10 I = 1, MIN( K, P ) -C -C Apply H(i) to C(i:i+n-p-1,1:m), from the left. -C Workspace: need M. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), - $ C( I, 1 ), LDC, DWORK ) - A( I, I ) = AII - 10 CONTINUE -C - IF ( P.LE.MIN( N, K ) ) THEN -C -C Apply H(i) to C, i = p+1:k, from the left. -C Workspace: need M; prefer M*NB. -C - CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - ELSE -C - IF ( P.LE.MIN( N, K ) ) THEN -C -C Apply H(i) to C, i = k:p+1:-1, from the left. -C Workspace: need M; prefer M*NB. -C - CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - DO 20 I = MIN( K, P ), 1, -1 -C -C Apply H(i) to C(i:i+n-p-1,1:m), from the left. -C Workspace: need M. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), - $ C( I, 1 ), LDC, DWORK ) - A( I, I ) = AII - 20 CONTINUE - END IF -C - ELSE -C - WRKOPT = DBLE( N ) - IF( TRAN ) THEN -C - IF ( P.LE.MIN( M, K ) ) THEN -C -C Apply H(i) to C, i = k:p+1:-1, from the right. -C Workspace: need N; prefer N*NB. -C - CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - DO 30 I = MIN( K, P ), 1, -1 -C -C Apply H(i) to C(1:n,i:i+m-p-1), from the right. -C Workspace: need N. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), - $ C( 1, I ), LDC, DWORK ) - A( I, I ) = AII - 30 CONTINUE -C - ELSE -C - DO 40 I = 1, MIN( K, P ) -C -C Apply H(i) to C(1:n,i:i+m-p-1), from the right. -C Workspace: need N. -C - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), - $ C( 1, I ), LDC, DWORK ) - A( I, I ) = AII - 40 CONTINUE -C - IF ( P.LE.MIN( M, K ) ) THEN -C -C Apply H(i) to C, i = p+1:k, from the right. -C Workspace: need N; prefer N*NB. -C - CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), - $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, - $ LDWORK, I ) - WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) - END IF -C - END IF - END IF -C - DWORK( 1 ) = WRKOPT - RETURN -C -C *** Last line of MB04IY *** - END diff --git a/slycot/src/MB04IZ.f b/slycot/src/MB04IZ.f deleted file mode 100644 index c9654a6a..00000000 --- a/slycot/src/MB04IZ.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a QR factorization of an n-by-m matrix A (A = Q * R), -C having a p-by-min(p,m) zero triangle in the lower left-hand side -C corner, as shown below, for n = 8, m = 7, and p = 2: -C -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C A = [ x x x x x x x ], -C [ x x x x x x x ] -C [ 0 x x x x x x ] -C [ 0 0 x x x x x ] -C -C and optionally apply the transformations to an n-by-l matrix B -C (from the left). The problem structure is exploited. This -C computation is useful, for instance, in combined measurement and -C time update of one iteration of the time-invariant Kalman filter -C (square root information filter). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix A. M >= 0. -C -C P (input) INTEGER -C The order of the zero triagle. P >= 0. -C -C L (input) INTEGER -C The number of columns of the matrix B. L >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix A. The elements corresponding to the -C zero P-by-MIN(P,M) lower trapezoidal/triangular part -C (if P > 0) are not referenced. -C On exit, the elements on and above the diagonal of this -C array contain the MIN(N,M)-by-M upper trapezoidal matrix -C R (R is upper triangular, if N >= M) of the QR -C factorization, and the relevant elements below the -C diagonal contain the trailing components (the vectors v, -C see Method) of the elementary reflectors used in the -C factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,L) -C On entry, the leading N-by-L part of this array must -C contain the matrix B. -C On exit, the leading N-by-L part of this array contains -C the updated matrix B. -C If L = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if L > 0; -C LDB >= 1 if L = 0. -C -C TAU (output) COMPLEX*16 array, dimension MIN(N,M) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK The length of the array ZWORK. -C LZWORK >= MAX(1,M-1,M-P,L). -C For optimum performance LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses min(N,M) Householder transformations exploiting -C the zero pattern of the matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an (N-P+I-2)-vector. The components of v are stored -C i i -C in the i-th column of A, beginning from the location i+1, and -C tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. -C -C KEYWORDS -C -C Elementary reflector, QR factorization, unitary transformation. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZERO, ONE - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), - $ ONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LZWORK, M, N, P -C .. Array Arguments .. - COMPLEX*16 A(LDA,*), B(LDB,*), TAU(*), ZWORK(*) -C .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, NB, WRKOPT - COMPLEX*16 FIRST -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL XERBLA, ZGEQRF, ZLARF, ZLARFG, ZUNMQR -C .. Intrinsic Functions .. - INTRINSIC DCONJG, INT, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LQUERY = ( LZWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -8 - ELSE - I = MAX( 1, M - 1, M - P, L ) - IF( LQUERY ) THEN - IF( M.GT.P ) THEN - NB = ILAENV( 1, 'ZGEQRF', ' ', N-P, M-P, -1, -1 ) - WRKOPT = MAX( I, ( M - P )*NB ) - IF ( L.GT.0 ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', N-P, L, - $ MIN(N,M)-P, -1 ) ) - WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) - END IF - END IF - ELSE IF( LZWORK.LT.I ) THEN - INFO = -11 - END IF - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04IZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) THEN - ZWORK(1) = ONE - RETURN - ELSE IF( N.LE.P+1 ) THEN - DO 5 I = 1, MIN( N, M ) - TAU(I) = ZERO - 5 CONTINUE - ZWORK(1) = ONE - RETURN - END IF -C -C Annihilate the subdiagonal elements of A and apply the -C transformations to B, if L > 0. -C Workspace: need MAX(M-1,L). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of complex workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 10 I = 1, MIN( P, M ) -C -C Exploit the structure of the I-th column of A. -C - CALL ZLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C - FIRST = A(I,I) - A(I,I) = ONE -C - IF ( I.LT.M ) CALL ZLARF( 'Left', N-P, M-I, A(I,I), 1, - $ DCONJG( TAU(I) ), A(I,I+1), LDA, - $ ZWORK ) - IF ( L.GT.0 ) CALL ZLARF( 'Left', N-P, L, A(I,I), 1, - $ DCONJG( TAU(I) ), B(I,1), LDB, - $ ZWORK ) -C - A(I,I) = FIRST - END IF - 10 CONTINUE -C - WRKOPT = MAX( 1, M - 1, L ) -C -C Fast QR factorization of the remaining right submatrix, if any. -C Workspace: need M-P; prefer (M-P)*NB. -C - IF( M.GT.P ) THEN - CALL ZGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), ZWORK, - $ LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) -C - IF ( L.GT.0 ) THEN -C -C Apply the transformations to B. -C Workspace: need L; prefer L*NB. -C - CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P, - $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, - $ ZWORK, LZWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) - END IF - END IF -C - ZWORK(1) = WRKOPT - RETURN -C *** Last line of MB04IZ *** - END diff --git a/slycot/src/MB04JD.f b/slycot/src/MB04JD.f deleted file mode 100644 index 8dc1a3b9..00000000 --- a/slycot/src/MB04JD.f +++ /dev/null @@ -1,248 +0,0 @@ - SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an LQ factorization of an n-by-m matrix A (A = L * Q), -C having a min(n,p)-by-p zero triangle in the upper right-hand side -C corner, as shown below, for n = 8, m = 7, and p = 2: -C -C [ x x x x x 0 0 ] -C [ x x x x x x 0 ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C A = [ x x x x x x x ], -C [ x x x x x x x ] -C [ x x x x x x x ] -C [ x x x x x x x ] -C -C and optionally apply the transformations to an l-by-m matrix B -C (from the right). The problem structure is exploited. This -C computation is useful, for instance, in combined measurement and -C time update of one iteration of the time-invariant Kalman filter -C (square root covariance filter). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of rows of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix A. M >= 0. -C -C P (input) INTEGER -C The order of the zero triagle. P >= 0. -C -C L (input) INTEGER -C The number of rows of the matrix B. L >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix A. The elements corresponding to the -C zero MIN(N,P)-by-P upper trapezoidal/triangular part -C (if P > 0) are not referenced. -C On exit, the elements on and below the diagonal of this -C array contain the N-by-MIN(N,M) lower trapezoidal matrix -C L (L is lower triangular, if N <= M) of the LQ -C factorization, and the relevant elements above the -C diagonal contain the trailing components (the vectors v, -C see Method) of the elementary reflectors used in the -C factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the matrix B. -C On exit, the leading L-by-M part of this array contains -C the updated matrix B. -C If L = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,L). -C -C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK The length of the array DWORK. -C LDWORK >= MAX(1,N-1,N-P,L). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine uses min(N,M) Householder transformations exploiting -C the zero pattern of the matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an (M-P+I-2)-vector. The components of v are stored -C i i -C in the i-th row of A, beginning from the location i+1, and tau -C i -C is stored in TAU(i). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, LQ factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION FIRST, WRKOPT -C .. External Subroutines .. - EXTERNAL DGELQF, DLARF, DLARFG, DORMLQ, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MAX( 1, N - 1, N - P, L ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - ELSE IF( M.LE.P+1 ) THEN - DO 5 I = 1, MIN( N, M ) - TAU(I) = ZERO - 5 CONTINUE - DWORK(1) = ONE - RETURN - END IF -C -C Annihilate the superdiagonal elements of A and apply the -C transformations to B, if L > 0. -C Workspace: need MAX(N-1,L). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 10 I = 1, MIN( N, P ) -C -C Exploit the structure of the I-th row of A. -C - CALL DLARFG( M-P, A(I,I), A(I,I+1), LDA, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C - FIRST = A(I,I) - A(I,I) = ONE -C - IF ( I.LT.N ) CALL DLARF( 'Right', N-I, M-P, A(I,I), LDA, - $ TAU(I), A(I+1,I), LDA, DWORK ) - IF ( L.GT.0 ) CALL DLARF( 'Right', L, M-P, A(I,I), LDA, - $ TAU(I), B(1,I), LDB, DWORK ) -C - A(I,I) = FIRST - END IF - 10 CONTINUE -C - WRKOPT = MAX( ONE, DBLE( N - 1 ), DBLE( L ) ) -C -C Fast LQ factorization of the remaining trailing submatrix, if any. -C Workspace: need N-P; prefer (N-P)*NB. -C - IF( N.GT.P ) THEN - CALL DGELQF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF ( L.GT.0 ) THEN -C -C Apply the transformations to B. -C Workspace: need L; prefer L*NB. -C - CALL DORMLQ( 'Right', 'Transpose', L, M-P, MIN(N,M)-P, - $ A(P+1,P+1), LDA, TAU(P+1), B(1,P+1), LDB, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of MB04JD *** - END diff --git a/slycot/src/MB04KD.f b/slycot/src/MB04KD.f deleted file mode 100644 index adcdcb6f..00000000 --- a/slycot/src/MB04KD.f +++ /dev/null @@ -1,209 +0,0 @@ - SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a QR factorization of the first block column and -C apply the orthogonal transformations (from the left) also to the -C second block column of a structured matrix, as follows -C _ -C [ R 0 ] [ R C ] -C Q' * [ ] = [ ] -C [ A B ] [ 0 D ] -C _ -C where R and R are upper triangular. The matrix A can be full or -C upper trapezoidal/triangular. The problem structure is exploited. -C This computation is useful, for instance, in combined measurement -C and time update of one iteration of the Kalman filter (square -C root information filter). -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'U': Matrix A is upper trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices R and R. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B, C and D. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices A, B and D. P >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C _ -C array contains the upper triangular matrix R. -C The strict lower triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'F', the leading P-by-N part of this -C array must contain the matrix A. If UPLO = 'U', the -C leading MIN(P,N)-by-N part of this array must contain the -C upper trapezoidal (upper triangular if P >= N) matrix A, -C and the elements below the diagonal are not referenced. -C On exit, the leading P-by-N part (upper trapezoidal or -C triangular, if UPLO = 'U') of this array contains the -C trailing components (the vectors v, see Method) of the -C elementary reflectors used in the factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,P). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading P-by-M part of this array must -C contain the matrix B. -C On exit, the leading P-by-M part of this array contains -C the computed matrix D. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,P). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array contains the -C computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is a P-vector, if UPLO = 'F', or an min(i,P)-vector, if -C i -C UPLO = 'U'. The components of v are stored in the i-th column -C i -C of A, and tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, QR factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ R(LDR,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C - IF( MIN( N, P ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'U' ) - IM = P -C - DO 10 I = 1, N -C -C Annihilate the I-th column of A and apply the transformations -C to the entire block matrix, exploiting its structure. -C - IF( LUPLO ) IM = MIN( I, P ) - CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C -C [ R(I,I+1:N) 0 ] -C [ w C(I,:) ] := [ 1 v' ] * [ ] -C [ A(1:IM,I+1:N) B(1:IM,:) ] -C - IF( I.LT.N ) THEN - CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 ) - CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA, - $ A(1,I), 1, ONE, DWORK, 1 ) - END IF - CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1, - $ ZERO, C(I,1), LDC ) -C -C [ R(I,I+1:N) C(I,:) ] [ R(I,I+1:N) 0 ] -C [ ] := [ ] -C [ A(1:IM,I+1:N) D(1:IM,:) ] [ A(1:IM,I+1:N) B(1:IM,:) ] -C -C [ 1 ] -C - tau * [ ] * [ w C(I,:) ] -C [ v ] -C - IF( I.LT.N ) THEN - CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR ) - CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1, - $ A(1,I+1), LDA ) - END IF - CALL DSCAL( M, -TAU(I), C(I,1), LDC ) - CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB ) - END IF - 10 CONTINUE -C - RETURN -C *** Last line of MB04KD *** - END diff --git a/slycot/src/MB04LD.f b/slycot/src/MB04LD.f deleted file mode 100644 index 7931437f..00000000 --- a/slycot/src/MB04LD.f +++ /dev/null @@ -1,209 +0,0 @@ - SUBROUTINE MB04LD( UPLO, N, M, P, L, LDL, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate an LQ factorization of the first block row and apply -C the orthogonal transformations (from the right) also to the second -C block row of a structured matrix, as follows -C _ -C [ L A ] [ L 0 ] -C [ ]*Q = [ ] -C [ 0 B ] [ C D ] -C _ -C where L and L are lower triangular. The matrix A can be full or -C lower trapezoidal/triangular. The problem structure is exploited. -C This computation is useful, for instance, in combined measurement -C and time update of one iteration of the Kalman filter (square -C root covariance filter). -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'L': Matrix A is lower trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices L and L. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices A, B and D. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices B, C and D. P >= 0. -C -C L (input/output) DOUBLE PRECISION array, dimension (LDL,N) -C On entry, the leading N-by-N lower triangular part of this -C array must contain the lower triangular matrix L. -C On exit, the leading N-by-N lower triangular part of this -C _ -C array contains the lower triangular matrix L. -C The strict upper triangular part of this array is not -C referenced. -C -C LDL INTEGER -C The leading dimension of array L. LDL >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, if UPLO = 'F', the leading N-by-M part of this -C array must contain the matrix A. If UPLO = 'L', the -C leading N-by-MIN(N,M) part of this array must contain the -C lower trapezoidal (lower triangular if N <= M) matrix A, -C and the elements above the diagonal are not referenced. -C On exit, the leading N-by-M part (lower trapezoidal or -C triangular, if UPLO = 'L') of this array contains the -C trailing components (the vectors v, see Method) of the -C elementary reflectors used in the factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading P-by-M part of this array must -C contain the matrix B. -C On exit, the leading P-by-M part of this array contains -C the computed matrix D. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,P). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ), -C H = I - tau *u *u', u = ( v ) -C i i i i i ( i) -C -C where v is an M-vector, if UPLO = 'F', or an min(i,M)-vector, if -C i -C UPLO = 'L'. The components of v are stored in the i-th row of A, -C i -C and tau is stored in TAU(i). -C i -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, LQ factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDL, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ L(LDL,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C - IF( MIN( M, N ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'L' ) - IM = M -C - DO 10 I = 1, N -C -C Annihilate the I-th row of A and apply the transformations to -C the entire block matrix, exploiting its structure. -C - IF( LUPLO ) IM = MIN( I, M ) - CALL DLARFG( IM+1, L(I,I), A(I,1), LDA, TAU(I) ) - IF( TAU(I).NE.ZERO ) THEN -C -C [ w ] [ L(I+1:N,I) A(I+1:N,1:IM) ] [ 1 ] -C [ ] := [ ] * [ ] -C [ C(:,I) ] [ 0 B(:,1:IM) ] [ v ] -C - IF( I.LT.N ) THEN - CALL DCOPY( N-I, L(I+1,I), 1, DWORK, 1 ) - CALL DGEMV( 'No transpose', N-I, IM, ONE, A(I+1,1), LDA, - $ A(I,1), LDA, ONE, DWORK, 1 ) - END IF - CALL DGEMV( 'No transpose', P, IM, ONE, B, LDB, A(I,1), - $ LDA, ZERO, C(1,I), 1 ) -C -C [ L(I+1:N,I) A(I+1:N,1:IM) ] [ L(I+1:N,I) A(I+1:N,1:IM) ] -C [ ] := [ ] -C [ C(:,I) D(:,1:IM) ] [ 0 B(:,1:IM) ] -C -C [ w ] -C - tau * [ ] * [ 1 , v'] -C [ C(:,I) ] -C - IF( I.LT.N ) THEN - CALL DAXPY( N-I, -TAU(I), DWORK, 1, L(I+1,I), 1 ) - CALL DGER( N-I, IM, -TAU(I), DWORK, 1, A(I,1), LDA, - $ A(I+1,1), LDA ) - END IF - CALL DSCAL( P, -TAU(I), C(1,I), 1 ) - CALL DGER( P, IM, ONE, C(1,I), 1, A(I,1), LDA, B, LDB ) - END IF - 10 CONTINUE -C - RETURN -C *** Last line of MB04LD *** - END diff --git a/slycot/src/MB04MD.f b/slycot/src/MB04MD.f deleted file mode 100644 index 8a9055af..00000000 --- a/slycot/src/MB04MD.f +++ /dev/null @@ -1,290 +0,0 @@ - SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the 1-norm of a general real matrix A by balancing. -C This involves diagonal similarity transformations applied -C iteratively to A to make the rows and columns as close in norm as -C possible. -C -C This routine can be used instead LAPACK Library routine DGEBAL, -C when no reduction of the 1-norm of the matrix is possible with -C DGEBAL, as for upper triangular matrices. LAPACK Library routine -C DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should -C be used to apply the backward transformation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C MAXRED (input/output) DOUBLE PRECISION -C On entry, the maximum allowed reduction in the 1-norm of -C A (in an iteration) if zero rows or columns are -C encountered. -C If MAXRED > 0.0, MAXRED must be larger than one (to enable -C the norm reduction). -C If MAXRED <= 0.0, then the value 10.0 for MAXRED is -C used. -C On exit, if the 1-norm of the given matrix A is non-zero, -C the ratio between the 1-norm of the given matrix and the -C 1-norm of the balanced matrix. Usually, this ratio will be -C larger than one, but it can sometimes be one, or even less -C than one (for instance, for some companion matrices). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the input matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to A. If D(j) is the scaling -C factor applied to row and column j, then SCALE(j) = D(j), -C for j = 1,...,N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation inv(D) * A * D to make the 1-norms of each row -C of A and its corresponding column nearly equal. -C -C Information about the diagonal matrix D is returned in the vector -C SCALE. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04AD by T.W.C. Williams, -C Kingston Polytechnic, United Kingdom, October 1984. -C This subroutine is based on LAPACK routine DGEBAL, and routine -C BALABC (A. Varga, German Aerospace Research Establishment, DLR). -C -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) - DOUBLE PRECISION FACTOR, MAXR - PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, N - DOUBLE PRECISION MAXRED -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), SCALE( * ) -C .. -C .. Local Scalars .. - LOGICAL NOCONV - INTEGER I, ICA, IRA, J - DOUBLE PRECISION ANORM, C, CA, F, G, MAXNRM, R, RA, S, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2, SRED -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04MD', -INFO ) - RETURN - END IF -C - IF( N.EQ.0 ) - $ RETURN -C - DO 10 I = 1, N - SCALE( I ) = ONE - 10 CONTINUE -C -C Compute the 1-norm of matrix A and exit if it is zero. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, SCALE ) - IF( ANORM.EQ.ZERO ) - $ RETURN -C -C Set some machine parameters and the maximum reduction in the -C 1-norm of A if zero rows or columns are encountered. -C - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C - SRED = MAXRED - IF( SRED.LE.ZERO ) SRED = MAXR -C - MAXNRM = MAX( ANORM/SRED, SFMIN1 ) -C -C Balance the matrix. -C -C Iterative loop for norm reduction. -C - 20 CONTINUE - NOCONV = .FALSE. -C - DO 80 I = 1, N - C = ZERO - R = ZERO -C - DO 30 J = 1, N - IF( J.EQ.I ) - $ GO TO 30 - C = C + ABS( A( J, I ) ) - R = R + ABS( A( I, J ) ) - 30 CONTINUE - ICA = IDAMAX( N, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IDAMAX( N, A( I, 1 ), LDA ) - RA = ABS( A( I, IRA ) ) -C -C Special case of zero C and/or R. -C - IF( C.EQ.ZERO .AND. R.EQ.ZERO ) - $ GO TO 80 - IF( C.EQ.ZERO ) THEN - IF( R.LE.MAXNRM) - $ GO TO 80 - C = MAXNRM - END IF - IF( R.EQ.ZERO ) THEN - IF( C.LE.MAXNRM ) - $ GO TO 80 - R = MAXNRM - END IF -C -C Guard against zero C or R due to underflow. -C - G = R / SCLFAC - F = ONE - S = C + R - 40 CONTINUE - IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. - $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 50 - F = F*SCLFAC - C = C*SCLFAC - CA = CA*SCLFAC - R = R / SCLFAC - G = G / SCLFAC - RA = RA / SCLFAC - GO TO 40 -C - 50 CONTINUE - G = C / SCLFAC - 60 CONTINUE - IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. - $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 70 - F = F / SCLFAC - C = C / SCLFAC - G = G / SCLFAC - CA = CA / SCLFAC - R = R*SCLFAC - RA = RA*SCLFAC - GO TO 60 -C -C Now balance. -C - 70 CONTINUE - IF( ( C+R ).GE.FACTOR*S ) - $ GO TO 80 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 80 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 80 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -C - CALL DSCAL( N, G, A( I, 1 ), LDA ) - CALL DSCAL( N, F, A( 1, I ), 1 ) -C - 80 CONTINUE -C - IF( NOCONV ) - $ GO TO 20 -C -C Set the norm reduction parameter. -C - MAXRED = ANORM/DLANGE( '1-norm', N, N, A, LDA, SCALE ) -C - RETURN -C *** End of MB04MD *** - END diff --git a/slycot/src/MB04ND.f b/slycot/src/MB04ND.f deleted file mode 100644 index 2a7e0725..00000000 --- a/slycot/src/MB04ND.f +++ /dev/null @@ -1,257 +0,0 @@ - SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate an RQ factorization of the first block row and -C apply the orthogonal transformations (from the right) also to the -C second block row of a structured matrix, as follows -C _ -C [ A R ] [ 0 R ] -C [ ] * Q' = [ _ _ ] -C [ C B ] [ C B ] -C _ -C where R and R are upper triangular. The matrix A can be full or -C upper trapezoidal/triangular. The problem structure is exploited. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'U': Matrix A is upper trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices R and R. N >= 0. -C -C M (input) INTEGER -C The number of rows of the matrices B and C. M >= 0. -C -C P (input) INTEGER -C The number of columns of the matrices A and C. P >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C _ -C array contains the upper triangular matrix R. -C The strict lower triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,P) -C On entry, if UPLO = 'F', the leading N-by-P part of this -C array must contain the matrix A. For UPLO = 'U', if -C N <= P, the upper triangle of the subarray A(1:N,P-N+1:P) -C must contain the N-by-N upper triangular matrix A, and if -C N >= P, the elements on and above the (N-P)-th subdiagonal -C must contain the N-by-P upper trapezoidal matrix A. -C On exit, if UPLO = 'F', the leading N-by-P part of this -C array contains the trailing components (the vectors v, see -C METHOD) of the elementary reflectors used in the -C factorization. If UPLO = 'U', the upper triangle of the -C subarray A(1:N,P-N+1:P) (if N <= P), or the elements on -C and above the (N-P)-th subdiagonal (if N >= P), contain -C the trailing components (the vectors v, see METHOD) of the -C elementary reflectors used in the factorization. -C The remaining elements are not referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix B. -C On exit, the leading M-by-N part of this array contains -C _ -C the computed matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) -C On entry, the leading M-by-P part of this array must -C contain the matrix C. -C On exit, the leading M-by-P part of this array contains -C _ -C the computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ) -C H = I - tau *u *u', u = ( v ), -C i i i i i ( i) -C -C where v is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector, -C i -C if UPLO = 'U'. The components of v are stored in the i-th row -C i -C of A, and tau is stored in TAU(i), i = N,N-1,...,1. -C i -C In-line code for applying Householder transformations is used -C whenever possible (see MB04NY routine). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary reflector, RQ factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ R(LDR,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM, IP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, MB04NY -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - IF( MIN( N, P ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'U' ) - IF ( LUPLO ) THEN -C - DO 10 I = N, 1, -1 -C -C Annihilate the I-th row of A and apply the transformations -C to the entire block matrix, exploiting its structure. -C - IM = MIN( N-I+1, P ) - IP = MAX( P-N+I, 1 ) - CALL DLARFG( IM+1, R(I,I), A(I,IP), LDA, TAU(I) ) -C -C Compute -C [ 1 ] -C w := [ R(1:I-1,I) A(1:I-1,IP:P) ] * [ ], -C [ v ] -C -C [ R(1:I-1,I) A(1:I-1,IP:P) ] = -C [ R(1:I-1,I) A(1:I-1,IP:P) ] - tau * w * [ 1 v' ]. -C - IF ( I.GT.0 ) -C - $ CALL MB04NY( I-1, IM, A(I,IP), LDA, TAU(I), R(1,I), LDR, - $ A(1,IP), LDA, DWORK ) -C -C Compute -C [ 1 ] -C w := [ B(:,I) C(:,IP:P) ] * [ ], -C [ v ] -C -C [ B(:,I) C(:,IP:P) ] = [ B(:,I) C(:,IP:P) ] - -C tau * w * [ 1 v' ]. -C - IF ( M.GT.0 ) - $ CALL MB04NY( M, IM, A(I,IP), LDA, TAU(I), B(1,I), LDB, - $ C(1,IP), LDC, DWORK ) - 10 CONTINUE -C - ELSE -C - DO 20 I = N, 2 , -1 -C -C Annihilate the I-th row of A and apply the transformations -C to the first block row, exploiting its structure. -C - CALL DLARFG( P+1, R(I,I), A(I,1), LDA, TAU(I) ) -C -C Compute -C [ 1 ] -C w := [ R(1:I-1,I) A(1:I-1,:) ] * [ ], -C [ v ] -C -C [ R(1:I-1,I) A(1:I-1,:) ] = [ R(1:I-1,I) A(1:I-1,:) ] - -C tau * w * [ 1 v' ]. -C - CALL MB04NY( I-1, P, A(I,1), LDA, TAU(I), R(1,I), LDR, A, - $ LDA, DWORK ) - 20 CONTINUE -C - CALL DLARFG( P+1, R(1,1), A(1,1), LDA, TAU(1) ) - IF ( M.GT.0 ) THEN -C -C Apply the transformations to the second block row. -C - DO 30 I = N, 1, -1 -C -C Compute -C [ 1 ] -C w := [ B(:,I) C ] * [ ], -C [ v ] -C -C [ B(:,I) C ] = [ B(:,I) C ] - tau * w * [ 1 v' ]. -C - CALL MB04NY( M, P, A(I,1), LDA, TAU(I), B(1,I), LDB, C, - $ LDC, DWORK ) - 30 CONTINUE -C - END IF - END IF - RETURN -C *** Last line of MB04ND *** - END diff --git a/slycot/src/MB04NY.f b/slycot/src/MB04NY.f deleted file mode 100644 index 4e884454..00000000 --- a/slycot/src/MB04NY.f +++ /dev/null @@ -1,437 +0,0 @@ - SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a real elementary reflector H to a real m-by-(n+1) -C matrix C = [ A B ], from the right, where A has one column. H is -C represented in the form -C ( 1 ) -C H = I - tau * u *u', u = ( ), -C ( v ) -C where tau is a real scalar and v is a real n-vector. -C -C If tau = 0, then H is taken to be the unit matrix. -C -C In-line code is used if H has order < 11. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix B. N >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (1+(N-1)*ABS( INCV )) -C The vector v in the representation of H. -C -C INCV (input) INTEGER -C The increment between the elements of v. INCV <> 0. -C -C TAU (input) DOUBLE PRECISION -C The scalar factor of the elementary reflector H. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,1) -C On entry, the leading M-by-1 part of this array must -C contain the matrix A. -C On exit, the leading M-by-1 part of this array contains -C the updated matrix A (the first column of C * H). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix B. -C On exit, the leading M-by-N part of this array contains -C the updated matrix B (the last n columns of C * H). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (M) -C DWORK is not referenced if H has order less than 11. -C -C METHOD -C -C The routine applies the elementary reflector H, taking the special -C structure of C into account. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. -C Based on LAPACK routines DLARFX and DLATZM. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, elementary reflector, orthogonal -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INCV, LDA, LDB, M, N - DOUBLE PRECISION TAU -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) -C .. Local Scalars .. - INTEGER IV, J - DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, - $ V3, V4, V5, V6, V7, V8, V9 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -C -C .. Executable Statements .. -C - IF( TAU.EQ.ZERO ) - $ RETURN -C -C Form C * H, where H has order n+1. -C - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 ) N+1 -C -C Code for general N. Compute -C -C w := C*u, C := C - tau * w * u'. -C - CALL DCOPY( M, A, 1, DWORK, 1 ) - CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE, - $ DWORK, 1 ) - CALL DAXPY( M, -TAU, DWORK, 1, A, 1 ) - CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB ) - GO TO 210 - 10 CONTINUE -C -C Special code for 1 x 1 Householder -C - T1 = ONE - TAU - DO 20 J = 1, M - A( J, 1 ) = T1*A( J, 1 ) - 20 CONTINUE - GO TO 210 - 30 CONTINUE -C -C Special code for 2 x 2 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - DO 40 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - 40 CONTINUE - GO TO 210 - 50 CONTINUE -C -C Special code for 3 x 3 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - DO 60 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - 60 CONTINUE - GO TO 210 - 70 CONTINUE -C -C Special code for 4 x 4 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - DO 80 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - 80 CONTINUE - GO TO 210 - 90 CONTINUE -C -C Special code for 5 x 5 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - DO 100 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - 100 CONTINUE - GO TO 210 - 110 CONTINUE -C -C Special code for 6 x 6 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - DO 120 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - 120 CONTINUE - GO TO 210 - 130 CONTINUE -C -C Special code for 7 x 7 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - DO 140 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - 140 CONTINUE - GO TO 210 - 150 CONTINUE -C -C Special code for 8 x 8 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - IV = IV + INCV - V7 = V( IV ) - T7 = TAU*V7 - DO 160 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + - $ V7*B( J, 7 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - B( J, 7 ) = B( J, 7 ) - SUM*T7 - 160 CONTINUE - GO TO 210 - 170 CONTINUE -C -C Special code for 9 x 9 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - IV = IV + INCV - V7 = V( IV ) - T7 = TAU*V7 - IV = IV + INCV - V8 = V( IV ) - T8 = TAU*V8 - DO 180 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + - $ V7*B( J, 7 ) + V8*B( J, 8 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - B( J, 7 ) = B( J, 7 ) - SUM*T7 - B( J, 8 ) = B( J, 8 ) - SUM*T8 - 180 CONTINUE - GO TO 210 - 190 CONTINUE -C -C Special code for 10 x 10 Householder -C - IV = 1 - IF( INCV.LT.0 ) - $ IV = (-N+1)*INCV + 1 - V1 = V( IV ) - T1 = TAU*V1 - IV = IV + INCV - V2 = V( IV ) - T2 = TAU*V2 - IV = IV + INCV - V3 = V( IV ) - T3 = TAU*V3 - IV = IV + INCV - V4 = V( IV ) - T4 = TAU*V4 - IV = IV + INCV - V5 = V( IV ) - T5 = TAU*V5 - IV = IV + INCV - V6 = V( IV ) - T6 = TAU*V6 - IV = IV + INCV - V7 = V( IV ) - T7 = TAU*V7 - IV = IV + INCV - V8 = V( IV ) - T8 = TAU*V8 - IV = IV + INCV - V9 = V( IV ) - T9 = TAU*V9 - DO 200 J = 1, M - SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + - $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + - $ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 ) - A( J, 1 ) = A( J, 1 ) - SUM*TAU - B( J, 1 ) = B( J, 1 ) - SUM*T1 - B( J, 2 ) = B( J, 2 ) - SUM*T2 - B( J, 3 ) = B( J, 3 ) - SUM*T3 - B( J, 4 ) = B( J, 4 ) - SUM*T4 - B( J, 5 ) = B( J, 5 ) - SUM*T5 - B( J, 6 ) = B( J, 6 ) - SUM*T6 - B( J, 7 ) = B( J, 7 ) - SUM*T7 - B( J, 8 ) = B( J, 8 ) - SUM*T8 - B( J, 9 ) = B( J, 9 ) - SUM*T9 - 200 CONTINUE - 210 CONTINUE - RETURN -C *** Last line of MB04NY *** - END diff --git a/slycot/src/MB04OD.f b/slycot/src/MB04OD.f deleted file mode 100644 index 694c81d7..00000000 --- a/slycot/src/MB04OD.f +++ /dev/null @@ -1,257 +0,0 @@ - SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, - $ TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate a QR factorization of the first block column and -C apply the orthogonal transformations (from the left) also to the -C second block column of a structured matrix, as follows -C _ _ -C [ R B ] [ R B ] -C Q' * [ ] = [ _ ] -C [ A C ] [ 0 C ] -C _ -C where R and R are upper triangular. The matrix A can be full or -C upper trapezoidal/triangular. The problem structure is exploited. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates if the matrix A is or not triangular as follows: -C = 'U': Matrix A is upper trapezoidal/triangular; -C = 'F': Matrix A is full. -C -C Input/Output Parameters -C -C N (input) INTEGER _ -C The order of the matrices R and R. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrices B and C. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrices A and C. P >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C _ -C array contains the upper triangular matrix R. -C The strict lower triangular part of this array is not -C referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if UPLO = 'F', the leading P-by-N part of this -C array must contain the matrix A. If UPLO = 'U', the -C leading MIN(P,N)-by-N part of this array must contain the -C upper trapezoidal (upper triangular if P >= N) matrix A, -C and the elements below the diagonal are not referenced. -C On exit, the leading P-by-N part (upper trapezoidal or -C triangular, if UPLO = 'U') of this array contains the -C trailing components (the vectors v, see Method) of the -C elementary reflectors used in the factorization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,P). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix B. -C On exit, the leading N-by-M part of this array contains -C _ -C the computed matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading P-by-M part of this array must -C contain the matrix C. -C On exit, the leading P-by-M part of this array contains -C _ -C the computed matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The scalar factors of the elementary reflectors used. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) -C -C METHOD -C -C The routine uses N Householder transformations exploiting the zero -C pattern of the block matrix. A Householder matrix has the form -C -C ( 1 ) -C H = I - tau *u *u', u = ( v ), -C i i i i i ( i) -C -C where v is a P-vector, if UPLO = 'F', or a min(i,P)-vector, if -C i -C UPLO = 'U'. The components of v are stored in the i-th column -C i -C of A, and tau is stored in TAU(i). -C i -C In-line code for applying Householder transformations is used -C whenever possible (see MB04OY routine). -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Elementary reflector, QR factorization, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, LDC, LDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ R(LDR,*), TAU(*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, MB04OY -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - IF( MIN( N, P ).EQ.0 ) - $ RETURN -C - LUPLO = LSAME( UPLO, 'U' ) - IF ( LUPLO ) THEN -C - DO 10 I = 1, N -C -C Annihilate the I-th column of A and apply the -C transformations to the entire block matrix, exploiting -C its structure. -C - IM = MIN( I, P ) - CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) -C -C Compute -C [ R(I,I+1:N) ] -C w := [ 1 v' ] * [ ], -C [ A(1:IM,I+1:N) ] -C -C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w . -C [ A(1:IM,I+1:N) ] [ A(1:IM,I+1:N) ] [ v ] -C - IF ( N-I.GT.0 ) - $ CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR, - $ A(1,I+1), LDA, DWORK ) -C -C Compute -C [ B(I,:) ] -C w := [ 1 v' ] * [ ], -C [ C(1:IM,:) ] -C -C [ B(I,:) ] [ B(I,:) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w. -C [ C(1:IM,:) ] [ C(1:IM,:) ] [ v ] -C -C - IF ( M.GT.0 ) - $ CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, - $ DWORK ) - 10 CONTINUE -C - ELSE -C - DO 20 I = 1, N - 1 -C -C Annihilate the I-th column of A and apply the -C transformations to the first block column, exploiting its -C structure. -C - CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) ) -C -C Compute -C [ R(I,I+1:N) ] -C w := [ 1 v' ] * [ ], -C [ A(:,I+1:N) ] -C -C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w . -C [ A(:,I+1:N) ] [ A(:,I+1:N) ] [ v ] -C - CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR, - $ A(1,I+1), LDA, DWORK ) - 20 CONTINUE -C - CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) ) - IF ( M.GT.0 ) THEN -C -C Apply the transformations to the second block column. -C - DO 30 I = 1, N -C -C Compute -C [ B(I,:) ] -C w := [ 1 v' ] * [ ], -C [ C ] -C -C [ B(I,:) ] [ B(I,:) ] [ 1 ] -C [ ] := [ ] - tau * [ ] * w. -C [ C ] [ C ] [ v ] -C - CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, - $ DWORK ) - 30 CONTINUE -C - END IF - END IF - RETURN -C *** Last line of MB04OD *** - END diff --git a/slycot/src/MB04OW.f b/slycot/src/MB04OW.f deleted file mode 100644 index ab594094..00000000 --- a/slycot/src/MB04OW.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB, - $ C, LDC, D, INCD ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the QR factorization -C -C ( U ) = Q*( R ), where U = ( U1 U2 ), R = ( R1 R2 ), -C ( x' ) ( 0 ) ( 0 T ) ( 0 R3 ) -C -C where U and R are (m+n)-by-(m+n) upper triangular matrices, x is -C an m+n element vector, U1 is m-by-m, T is n-by-n, stored -C separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix. -C -C The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper -C trapezoidal part of the array A and this is overwritten by the -C corresponding part ( R1 R2 ) of R. The remaining upper triangular -C part of R, R3, is overwritten on the array T. -C -C The transformations performed are also applied to the (m+n+1)-by-p -C matrix ( B' C' d )' (' denotes transposition), where B, C, and d' -C are m-by-p, n-by-p, and 1-by-p matrices, respectively. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix ( U1 U2 ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix T. N >= 0. -C -C P (input) INTEGER -C The number of columns of the matrices B and C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-(M+N) upper trapezoidal part of -C this array must contain the upper trapezoidal matrix -C ( U1 U2 ). -C On exit, the leading M-by-(M+N) upper trapezoidal part of -C this array contains the upper trapezoidal matrix ( R1 R2 ). -C The strict lower triangle of A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix T. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular matrix R3. -C The strict lower triangle of T is not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0. -C On entry, the incremented array X must contain the -C vector x. On exit, the content of X is changed. -C -C INCX (input) INTEGER -C Specifies the increment for the elements of X. INCX > 0. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,P) -C On entry, the leading M-by-P part of this array must -C contain the matrix B. -C On exit, the leading M-by-P part of this array contains -C the transformed matrix B. -C If M = 0 or P = 0, this array is not referenced. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= max(1,M), if P > 0; -C LDB >= 1, if P = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) -C On entry, the leading N-by-P part of this array must -C contain the matrix C. -C On exit, the leading N-by-P part of this array contains -C the transformed matrix C. -C If N = 0 or P = 0, this array is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= max(1,N), if P > 0; -C LDC >= 1, if P = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0. -C On entry, the incremented array D must contain the -C vector d. -C On exit, this incremented array contains the transformed -C vector d. -C If P = 0, this array is not referenced. -C -C INCD (input) INTEGER -C Specifies the increment for the elements of D. INCD > 0. -C -C METHOD -C -C Let q = m+n. The matrix Q is formed as a sequence of plane -C rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the -C rotation in the (j, q+1)th plane, Q(j), being chosen to -C annihilate the jth element of x. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0((M+N)*(M+N+P)) operations and is backward -C stable. -C -C FURTHER COMMENTS -C -C For P = 0, this routine produces the same result as SLICOT Library -C routine MB04OX, but matrix T may not be stored in the array A. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCD, INCX, LDA, LDB, LDC, LDT, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*), T(LDT,*), - $ X(*) -C .. Local Scalars .. - DOUBLE PRECISION CI, SI, TEMP - INTEGER I, IX, MN -C .. External Subroutines .. - EXTERNAL DLARTG, DROT -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - MN = M + N - IF ( INCX.GT.1 ) THEN -C -C Code for increment INCX > 1. -C - IX = 1 - IF ( M.GT.0 ) THEN -C - DO 10 I = 1, M - 1 - CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) - A(I,I) = TEMP - IX = IX + INCX - CALL DROT( MN-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) - 10 CONTINUE -C - CALL DLARTG( A(M,M), X(IX), CI, SI, TEMP ) - A(M,M) = TEMP - IX = IX + INCX - IF ( N.GT.0 ) - $ CALL DROT( N, A(M,M+1), LDA, X(IX), INCX, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) - END IF -C - IF ( N.GT.0 ) THEN -C - DO 20 I = 1, N - 1 - CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) - T(I,I) = TEMP - IX = IX + INCX - CALL DROT( N-I, T(I,I+1), LDT, X(IX), INCX, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) - 20 CONTINUE -C - CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) - T(N,N) = TEMP - IF ( P.GT.0 ) - $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) - END IF -C - ELSEIF ( INCX.EQ.1 ) THEN -C -C Code for increment INCX = 1. -C - IF ( M.GT.0 ) THEN -C - DO 30 I = 1, M - 1 - CALL DLARTG( A(I,I), X(I), CI, SI, TEMP ) - A(I,I) = TEMP - CALL DROT( MN-I, A(I,I+1), LDA, X(I+1), 1, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) - 30 CONTINUE -C - CALL DLARTG( A(M,M), X(M), CI, SI, TEMP ) - A(M,M) = TEMP - IF ( N.GT.0 ) - $ CALL DROT( N, A(M,M+1), LDA, X(M+1), 1, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) - END IF -C - IF ( N.GT.0 ) THEN - IX = M + 1 -C - DO 40 I = 1, N - 1 - CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) - T(I,I) = TEMP - IX = IX + 1 - CALL DROT( N-I, T(I,I+1), LDT, X(IX), 1, CI, SI ) - IF ( P.GT.0 ) - $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) - 40 CONTINUE -C - CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) - T(N,N) = TEMP - IF ( P.GT.0 ) - $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) - END IF - END IF -C - RETURN -C *** Last line of MB04OW *** - END diff --git a/slycot/src/MB04OX.f b/slycot/src/MB04OX.f deleted file mode 100644 index b8d02919..00000000 --- a/slycot/src/MB04OX.f +++ /dev/null @@ -1,106 +0,0 @@ - SUBROUTINE MB04OX( N, A, LDA, X, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the QR factorization -C -C (U ) = Q*(R), -C (x') (0) -C -C where U and R are n-by-n upper triangular matrices, x is an -C n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix. -C -C U must be supplied in the n-by-n upper triangular part of the -C array A and this is overwritten by R. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of elements of X and the order of the square -C matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix U. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular matrix R. -C The strict lower triangle of A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, the incremented array X must contain the -C vector x. On exit, the content of X is changed. -C -C INCX (input) INTEGER. -C Specifies the increment for the elements of X. INCX > 0. -C -C METHOD -C -C The matrix Q is formed as a sequence of plane rotations in planes -C (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th -C plane, Q(j), being chosen to annihilate the jth element of x. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine DUTUPD. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCX, LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), X(*) -C .. Local Scalars .. - DOUBLE PRECISION CI, SI, TEMP - INTEGER I, IX -C .. External Subroutines .. - EXTERNAL DLARTG, DROT -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - IX = 1 -C - DO 20 I = 1, N - 1 - CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) - A(I,I) = TEMP - IX = IX + INCX - CALL DROT( N-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) - 20 CONTINUE -C - CALL DLARTG( A(N,N), X(IX), CI, SI, TEMP ) - A(N,N) = TEMP -C - RETURN -C *** Last line of MB04OX *** - END diff --git a/slycot/src/MB04OY.f b/slycot/src/MB04OY.f deleted file mode 100644 index d77d2837..00000000 --- a/slycot/src/MB04OY.f +++ /dev/null @@ -1,370 +0,0 @@ - SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a real elementary reflector H to a real (m+1)-by-n -C matrix C = [ A ], from the left, where A has one row. H is -C [ B ] -C represented in the form -C ( 1 ) -C H = I - tau * u *u', u = ( ), -C ( v ) -C where tau is a real scalar and v is a real m-vector. -C -C If tau = 0, then H is taken to be the unit matrix. -C -C In-line code is used if H has order < 11. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices A and B. N >= 0. -C -C V (input) DOUBLE PRECISION array, dimension (M) -C The vector v in the representation of H. -C -C TAU (input) DOUBLE PRECISION -C The scalar factor of the elementary reflector H. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading 1-by-N part of this array must -C contain the matrix A. -C On exit, the leading 1-by-N part of this array contains -C the updated matrix A (the first row of H * C). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= 1. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix B. -C On exit, the leading M-by-N part of this array contains -C the updated matrix B (the last m rows of H * C). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C DWORK is not referenced if H has order less than 11. -C -C METHOD -C -C The routine applies the elementary reflector H, taking the special -C structure of C into account. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. -C Based on LAPACK routines DLARFX and DLATZM. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Elementary matrix operations, elementary reflector, orthogonal -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER LDA, LDB, M, N - DOUBLE PRECISION TAU -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) -C .. Local Scalars .. - INTEGER J - DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, - $ V3, V4, V5, V6, V7, V8, V9 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -C -C .. Executable Statements .. -C - IF( TAU.EQ.ZERO ) - $ RETURN -C -C Form H * C, where H has order m+1. -C - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 ) M+1 -C -C Code for general M. Compute -C -C w := C'*u, C := C - tau * u * w'. -C - CALL DCOPY( N, A, LDA, DWORK, 1 ) - CALL DGEMV( 'Transpose', M, N, ONE, B, LDB, V, 1, ONE, DWORK, 1 ) - CALL DAXPY( N, -TAU, DWORK, 1, A, LDA ) - CALL DGER( M, N, -TAU, V, 1, DWORK, 1, B, LDB ) - GO TO 210 - 10 CONTINUE -C -C Special code for 1 x 1 Householder -C - T1 = ONE - TAU - DO 20 J = 1, N - A( 1, J ) = T1*A( 1, J ) - 20 CONTINUE - GO TO 210 - 30 CONTINUE -C -C Special code for 2 x 2 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - DO 40 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - 40 CONTINUE - GO TO 210 - 50 CONTINUE -C -C Special code for 3 x 3 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 60 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - 60 CONTINUE - GO TO 210 - 70 CONTINUE -C -C Special code for 4 x 4 Householder -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 80 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - 80 CONTINUE - GO TO 210 - 90 CONTINUE -C -C Special code for 5 x 5 Householder -C - 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 100 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - 100 CONTINUE - GO TO 210 - 110 CONTINUE -C -C Special code for 6 x 6 Householder -C - 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 120 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - 120 CONTINUE - GO TO 210 - 130 CONTINUE -C -C Special code for 7 x 7 Householder -C - 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 140 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - 140 CONTINUE - GO TO 210 - 150 CONTINUE -C -C Special code for 8 x 8 Householder -C - 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 160 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + - $ V7*B( 7, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - B( 7, J ) = B( 7, J ) - SUM*T7 - 160 CONTINUE - GO TO 210 - 170 CONTINUE -C -C Special code for 9 x 9 Householder -C - 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 180 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + - $ V7*B( 7, J ) + V8*B( 8, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - B( 7, J ) = B( 7, J ) - SUM*T7 - B( 8, J ) = B( 8, J ) - SUM*T8 - 180 CONTINUE - GO TO 210 - 190 CONTINUE -C -C Special code for 10 x 10 Householder -C - 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 200 J = 1, N - SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + - $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + - $ V7*B( 7, J ) + V8*B( 8, J ) + V9*B( 9, J ) - A( 1, J ) = A( 1, J ) - SUM*TAU - B( 1, J ) = B( 1, J ) - SUM*T1 - B( 2, J ) = B( 2, J ) - SUM*T2 - B( 3, J ) = B( 3, J ) - SUM*T3 - B( 4, J ) = B( 4, J ) - SUM*T4 - B( 5, J ) = B( 5, J ) - SUM*T5 - B( 6, J ) = B( 6, J ) - SUM*T6 - B( 7, J ) = B( 7, J ) - SUM*T7 - B( 8, J ) = B( 8, J ) - SUM*T8 - B( 9, J ) = B( 9, J ) - SUM*T9 - 200 CONTINUE - 210 CONTINUE - RETURN -C *** Last line of MB04OY *** - END diff --git a/slycot/src/MB04PA.f b/slycot/src/MB04PA.f deleted file mode 100644 index 8ee27d01..00000000 --- a/slycot/src/MB04PA.f +++ /dev/null @@ -1,1105 +0,0 @@ - SUBROUTINE MB04PA( LHAM, N, K, NB, A, LDA, QG, LDQG, XA, LDXA, - $ XG, LDXG, XQ, LDXQ, YA, LDYA, CS, TAU, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a Hamiltonian like matrix -C -C [ A G ] T T -C H = [ T ] , G = G , Q = Q, -C [ Q -A ] -C -C or a skew-Hamiltonian like matrix -C -C [ A G ] T T -C W = [ T ] , G = -G , Q = -Q, -C [ Q A ] -C -C so that elements below the (k+1)-th subdiagonal in the first nb -C columns of the (k+n)-by-n matrix A, and offdiagonal elements -C in the first nb columns and rows of the n-by-n matrix Q are zero. -C -C The reduction is performed by an orthogonal symplectic -C transformation UU'*H*UU and matrices U, XA, XG, XQ, and YA are -C returned so that -C -C [ Aout + U*XA'+ YA*U' Gout + U*XG'+ XG*U' ] -C UU'*H*UU = [ ]. -C [ Qout + U*XQ'+ XQ*U' -Aout'- XA*U'- U*YA' ] -C -C Similarly, -C -C [ Aout + U*XA'+ YA*U' Gout + U*XG'- XG*U' ] -C UU'*W*UU = [ ]. -C [ Qout + U*XQ'- XQ*U' Aout'+ XA*U'+ U*YA' ] -C -C This is an auxiliary routine called by MB04PB. -C -C ARGUMENTS -C -C Mode Parameters -C -C LHAM LOGICAL -C Specifies the type of matrix to be reduced: -C = .FALSE. : skew-Hamiltonian like W; -C = .TRUE. : Hamiltonian like H. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C K (input) INTEGER -C The offset of the reduction. Elements below the (K+1)-th -C subdiagonal in the first NB columns of A are reduced -C to zero. K >= 0. -C -C NB (input) INTEGER -C The number of columns/rows to be reduced. N > NB >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading (K+N)-by-N part of this array must -C contain the matrix A. -C On exit, the leading (K+N)-by-N part of this array -C contains the matrix Aout and in the zero part -C information about the elementary reflectors used to -C compute the reduction. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,K+N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N+K-by-N+1 part of this array must -C contain in the bottom left part the lower triangular part -C of the N-by-N matrix Q and in the remainder the upper -C trapezoidal part of the last N columns of the N+K-by-N+K -C matrix G. -C On exit, the leading N+K-by-N+1 part of this array -C contains parts of the matrices Q and G in the same fashion -C as on entry only that the zero parts of Q contain -C information about the elementary reflectors used to -C compute the reduction. Note that if LHAM = .FALSE. then -C the (K-1)-th and K-th subdiagonals are not referenced. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N+K). -C -C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XA. -C -C LDXA INTEGER -C The leading dimension of the array XA. LDXA >= MAX(1,N). -C -C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix XG. -C -C LDXG INTEGER -C The leading dimension of the array XG. LDXG >= MAX(1,K+N). -C -C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) -C On exit, the leading N-by-(2*NB) part of this array -C contains the matrix XQ. -C -C LDXQ INTEGER -C The leading dimension of the array XQ. LDXQ >= MAX(1,N). -C -C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) -C On exit, the leading (K+N)-by-(2*NB) part of this array -C contains the matrix YA. -C -C LDYA INTEGER -C The leading dimension of the array YA. LDYA >= MAX(1,K+N). -C -C CS (output) DOUBLE PRECISION array, dimension (2*NB) -C On exit, the first 2*NB elements of this array contain the -C cosines and sines of the symplectic Givens rotations used -C to compute the reduction. -C -C TAU (output) DOUBLE PRECISION array, dimension (NB) -C On exit, the first NB elements of this array contain the -C scalar factors of some of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*NB) -C -C METHOD -C -C For details regarding the representation of the orthogonal -C symplectic matrix UU within the arrays A, QG, CS, TAU see the -C description of MB04PU. -C -C The contents of A and QG on exit are illustrated by the following -C example with n = 5, k = 2 and nb = 2: -C -C ( a r r a a ) ( g g r r g g ) -C ( a r r a a ) ( g g r r g g ) -C ( a r r a a ) ( q g r r g g ) -C A = ( r r r r r ), QG = ( t r r r r r ), -C ( u2 r r r r ) ( u1 t r r r r ) -C ( u2 u2 r a a ) ( u1 u1 r q g g ) -C ( u2 u2 r a a ) ( u1 u1 r q q g ) -C -C where a, g and q denote elements of the original matrices, r -C denotes a modified element, t denotes a scalar factor of an -C applied elementary reflector and ui denote elements of the -C matrix U. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] D. KRESSNER: -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DLAPVL). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix, -C skew-Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D+0 ) -C .. Scalar Arguments .. - LOGICAL LHAM - INTEGER K, LDA, LDQG, LDXA, LDXG, LDXQ, LDYA, N, NB -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*), - $ XA(LDXA,*), XG(LDXG,*), XQ(LDXQ,*), YA(LDYA,*) -C .. Local Scalars .. - INTEGER I, J, NB1, NB2 - DOUBLE PRECISION AKI, ALPHA, C, S, TAUQ, TEMP, TTEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL, - $ DSYMV, MB01MD -C .. Intrinsic Functions .. - INTRINSIC MIN -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( N+K.LE.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - NB1 = NB + 1 - NB2 = NB + NB1 -C - IF ( LHAM ) THEN - DO 50 I = 1, NB -C -C Transform i-th columns of A and Q. See routine MB04PU. -C - ALPHA = QG(K+I+1,I) - CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) - QG(K+I+1,I) = ONE - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - AKI = A(K+I+1,I) - CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) - AKI = A(K+I+1,I) - CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) - A(K+I+1,I) = ONE -C -C Update XA with first Householder reflection. -C -C xa = H(1:n,1:n)'*u1 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) -C w1 = U1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, - $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) -C w2 = U2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) -C temp = YA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C xa = -tauq*xa - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update YA with first Householder reflection. -C -C ya = H(1:n,1:n)*u1 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) -C temp = XA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) -C ya = -tauq*ya - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C temp = -tauq*ya'*u1 - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C ya = ya + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C -C Update (i+1)-th column of A. -C -C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, - $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, - $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) - END IF -C -C Annihilate updated parts in YA. -C - DO 10 J = 1, I - YA(K+I+1,J) = ZERO - 10 CONTINUE - DO 20 J = 1, I-1 - YA(K+I+1,NB+J) = ZERO - 20 CONTINUE -C -C Update XQ with first Householder reflection. -C -C xq = Q*u1 - CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C xq = -tauq*xq - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C xq = xq + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C -C Update (i+1)-th column and row of Q. -C -C Q(:,i+1) = Q(:,i+1) + U1 * XQ1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XQ(I+1,1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) -C Q(:,i+1) = Q(:,i+1) + U2 * XQ2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XQ(I+1,NB1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, - $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+1), 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+1), 1 ) -C -C Update XG with first Householder reflection. -C -C xg = G*u1 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) - CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) -C temp = XG1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C temp = XG2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), - $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C xg = -tauq*xg - CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), - $ 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) -C -C Update (i+1)-th column and row of G. -C -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, - $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, - $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, - $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+2), LDQG ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XG(K+I+1,NB1), - $ LDXG, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+2), - $ LDQG ) -C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) -C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) -C -C Annihilate updated parts in XG. -C - DO 30 J = 1, I - XG(K+I+1,J) = ZERO - 30 CONTINUE - DO 40 J = 1, I-1 - XG(K+I+1,NB+J) = ZERO - 40 CONTINUE -C -C Apply orthogonal symplectic Givens rotation. -C - CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) - IF ( N.GT.I+1 ) THEN - CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, - $ C, S ) - CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, C, - $ S ) - END IF - TEMP = A(K+I+1,I+1) - TTEMP = QG(K+I+1,I+2) - A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+1) - QG(K+I+1,I+2) = C*TTEMP - S*TEMP - QG(K+I+1,I+1) = -S*TEMP + C*QG(K+I+1,I+1) - TTEMP = -S*TTEMP - C*TEMP - TEMP = A(K+I+1,I+1) - QG(K+I+1,I+1) = C*QG(K+I+1,I+1) + S*TTEMP - A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+2) - QG(K+I+1,I+2) = -S*TEMP + C*QG(K+I+1,I+2) - CS(2*I-1) = C - CS(2*I) = S - QG(K+I+1,I) = TAUQ -C -C Update XA with second Householder reflection. -C -C xa = H(1:n,1:n)'*u2 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C w1 = U1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) -C w2 = U2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) - END IF -C xa = -tau*xa - CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) -C -C Update YA with second Householder reflection. -C -C ya = H(1:n,1:n)*u2 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) - END IF -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,NB+I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) -C ya = -tau*ya - CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) -C temp = -tau*ya'*u2 - TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C ya = ya + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column of A. -C -C H(1:n,i+1) = H(1:n,i+1) + ya - CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) -C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 - CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), - $ 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; - CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), - $ LDA ) -C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' - CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, - $ A(K+I+1,I+2), LDA ) - END IF -C -C Annihilate updated parts in YA. -C - YA(K+I+1,NB+I) = ZERO -C -C Update XQ with second Householder reflection. -C -C xq = Q*u2 - CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), - $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) - END IF -C xq = -tauq*xq - CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) -C temp = -tauq/2*xq'*u2 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), - $ 1 ) -C xq = xq + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of Q. -C - CALL DAXPY( N-I, ONE, XQ(I+1,NB+I), 1, QG(K+I+1,I+1), 1 ) -C H(1:n,n+i+1) = H(1:n,n+i+1) + U * XQ(i+1,:)'; - CALL DAXPY( N-I, XQ(I+1,NB+I), A(K+I+1,I), 1, - $ QG(K+I+1,I+1), 1 ) -C -C Update XG with second Householder reflection. -C -C xg = G*u2 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) - CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,NB+I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XG1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) -C temp = XG2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) - END IF -C xg = -tauq*xg - CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) -C temp = -tauq/2*xg'*u1 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, - $ XG(K+I+1,NB+I), 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of G. -C - CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) - CALL DAXPY( N-I, ONE, XG(K+I+1,NB+I), 1, QG(K+I+1,I+2), - $ LDQG ) - CALL DAXPY( N-I, XG(K+I+1,NB+I), A(K+I+1,I), 1, - $ QG(K+I+1,I+2), LDQG ) -C -C Annihilate updated parts in XG. -C - XG(K+I+1,NB+I) = ZERO -C - A(K+I+1,I) = AKI - 50 CONTINUE - ELSE - DO 100 I = 1, NB -C -C Transform i-th columns of A and Q. -C - ALPHA = QG(K+I+1,I) - CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) - QG(K+I+1,I) = ONE - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) - AKI = A(K+I+1,I) - CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) - AKI = A(K+I+1,I) - CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) - A(K+I+1,I) = ONE -C -C Update XA with first Householder reflection. -C -C xa = H(1:n,1:n)'*u1 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) -C w1 = U1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, - $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ DWORK, 1, ONE, XA(I+1,I), 1 ) -C w2 = U2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) -C temp = YA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, - $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) -C xa = -tauq*xa - CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) -C -C Update YA with first Householder reflection. -C -C ya = H(1:n,1:n)*u1 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) -C temp = XA1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) -C ya = -tauq*ya - CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) -C temp = -tauq*ya'*u1 - TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C ya = ya + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) -C -C Update (i+1)-th column of A. -C -C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, - $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, - $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, - $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) -C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, - $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) -C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), - $ LDA ) - END IF -C -C Annihilate updated parts in YA. -C - DO 60 J = 1, I - YA(K+I+1,J) = ZERO - 60 CONTINUE - DO 70 J = 1, I-1 - YA(K+I+1,NB+J) = ZERO - 70 CONTINUE -C -C Update XQ with first Householder reflection. -C -C xq = Q*u1 - CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ DWORK, 1, ONE, XQ(I+1,I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq - U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), - $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C temp = XQ2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) -C xq = xq - U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, - $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) -C xq = -tauq*xq - CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C xq = xq + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) -C -C Update (i+1)-th column and row of Q. -C - IF ( N.GT.I+1 ) THEN -C Q(:,i+1) = Q(:,i+1) - U1 * XQ1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, -ONE, QG(K+I+2,1), - $ LDQG, XQ(I+1,1), LDXQ, ONE, QG(K+I+2,I+1), - $ 1 ) -C Q(:,i+1) = Q(:,i+1) - U2 * XQ2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, A(K+I+2,1), - $ LDA, XQ(I+1,NB1), LDXQ, ONE, QG(K+I+2,I+1), - $ 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), - $ LDXQ, QG(K+I+1,1), LDQG, ONE, QG(K+I+2,I+1), - $ 1 ) -C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+2,I+1), - $ 1 ) - END IF -C -C Update XG with first Householder reflection. -C -C xg = G*u1 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) - CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) -C temp = XG1'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, - $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U1*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C temp = XG2'*u1 - CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), - $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U2*temp - CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, - $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) -C xg = -tauq*xg - CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) -C temp = -tauq/2*xq'*u1 - TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), - $ 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) -C -C Update (i+1)-th column and row of G. -C -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, - $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, - $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) - IF ( N.GT.I+1 ) THEN -C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, -ONE, XG(K+I+2,1), - $ LDXG, QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+3), - $ LDQG ) -C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, - $ XG(K+I+2,NB1), LDXG, A(K+I+1,1), LDA, ONE, - $ QG(K+I+1,I+3), LDQG ) -C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+3), - $ LDQG ) -C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+3), - $ LDQG ) - END IF -C -C Annihilate updated parts in XG. -C - DO 80 J = 1, I - XG(K+I+1,J) = ZERO - 80 CONTINUE - DO 90 J = 1, I-1 - XG(K+I+1,NB+J) = ZERO - 90 CONTINUE -C -C Apply orthogonal symplectic Givens rotation. -C - CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) - IF ( N.GT.I+1 ) THEN - CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, - $ C, -S ) - CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, - $ C, -S ) - END IF - CS(2*I-1) = C - CS(2*I) = S - QG(K+I+1,I) = TAUQ -C -C Update XA with second Householder reflection. -C -C xa = H(1:n,1:n)'*u2 - CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C w1 = U1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) -C xa = xa + XA1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), - $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) -C w2 = U2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) -C xa = xa + XA2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) -C temp = YA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), - $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) -C xa = xa + U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) - END IF -C xa = -tau*xa - CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) -C -C Update YA with second Householder reflection. -C -C ya = H(1:n,1:n)*u2 - CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, - $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XA1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, - $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U1*temp - CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) -C temp = XA2'*u1 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), - $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C ya = ya + U2*temp - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) - END IF -C ya = ya + YA1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, - $ DWORK, 1, ONE, YA(1,NB+I), 1 ) -C ya = ya + YA2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, - $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) -C ya = -tau*ya - CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) -C temp = -tau*ya'*u2 - TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C ya = ya + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column of A. -C -C H(1:n,i+1) = H(1:n,i+1) + ya - CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) -C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 - CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), - $ 1 ) -C -C Update (i+1)-th row of A. -C - IF ( N.GT.I+1 ) THEN -C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; - CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), - $ LDA ) -C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' - CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, - $ A(K+I+1,I+2), LDA ) - END IF -C -C Annihilate updated parts in YA. -C - YA(K+I+1,NB+I) = ZERO -C -C Update XQ with second Householder reflection. -C -C xq = Q*u2 - CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, - $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C xq = xq + XQ1*w1 - CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), - $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) -C xq = xq + XQ2*w2 - CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, - $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq - U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), - $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) -C temp = XQ2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) -C xq = xq - U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), - $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) - END IF -C xq = -tauq*xq - CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) -C temp = -tauq/2*xq'*u2 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), - $ 1 ) -C xq = xq + temp*u2 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of Q. -C - IF ( N.GT.I+1 ) THEN - CALL DAXPY( N-I-1, ONE, XQ(I+2,NB+I), 1, QG(K+I+2,I+1), - $ 1 ) -C H(1:n,n+i+1) = H(1:n,n+i+1) - U * XQ(i+1,:)'; - CALL DAXPY( N-I-1, -XQ(I+1,NB+I), A(K+I+2,I), 1, - $ QG(K+I+2,I+1), 1 ) - END IF -C -C Update XG with second Householder reflection. -C -C xg = G*u2 - CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) - CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, - $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) -C xg = xg + XG1*w1 - CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, - $ DWORK, 1, ONE, XG(1,NB+I), 1 ) -C xg = xg + XG2*w2 - CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), - $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) - IF ( N.GT.I+1 ) THEN -C temp = XG1'*u2 - CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U1*temp - CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), - $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) -C temp = XG2'*u2 - CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), - $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) -C xg = xg - U2*temp - CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), - $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) - END IF -C xg = -tauq*xg - CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) -C temp = -tauq/2*xg'*u1 - TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, - $ XG(K+I+1,NB+I), 1 ) -C xg = xg + temp*u1 - CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) -C -C Update (i+1)-th column and row of G. -C - CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) - IF ( N.GT.I+1 ) THEN - CALL DAXPY( N-I-1, -ONE, XG(K+I+2,NB+I), 1, - $ QG(K+I+1,I+3), LDQG ) - CALL DAXPY( N-I-1, XG(K+I+1,NB+I), A(K+I+2,I), 1, - $ QG(K+I+1,I+3), LDQG ) - END IF -C -C Annihilate updated parts in XG. -C - XG(K+I+1,NB+I) = ZERO -C - A(K+I+1,I) = AKI - 100 CONTINUE - END IF -C - RETURN -C *** Last line of MB04PA *** - END diff --git a/slycot/src/MB04PB.f b/slycot/src/MB04PB.f deleted file mode 100644 index 3948eee1..00000000 --- a/slycot/src/MB04PB.f +++ /dev/null @@ -1,333 +0,0 @@ - SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a Hamiltonian matrix, -C -C [ A G ] -C H = [ T ] , -C [ Q -A ] -C -C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, -C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U -C is computed so that -C -C T [ Aout Gout ] -C U H U = [ T ] , -C [ Qout -Aout ] -C -C where Aout is upper Hessenberg and Qout is diagonal. -C Blocked version. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that A is already upper triangular and Q is -C zero in rows and columns 1:ILO-1. ILO is normally set by a -C previous call to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Aout and, in the zero part of Aout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain the lower triangular part of the matrix Q and -C the upper triangular part of the matrix G. -C On exit, the leading N-by-N+1 part of this array contains -C the diagonal of the matrix Qout, the upper triangular part -C of the matrix Gout and, in the zero parts of Qout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C CS (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations used -C to compute the PVL factorization. -C -C TAU (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal -C block size determined by the function UE01MD. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N-1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix U is represented as a product of symplectic reflectors -C and Givens rotators -C -C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). -C -C Each H(i) has the form -C -C H(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C QG(i+2:n,i), and tau in QG(i+1,i). -C -C Each F(i) has the form -C -C F(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C A(i+2:n,i), and nu in TAU(i). -C -C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, -C where the cosine is stored in CS(2*i-1) and the sine in -C CS(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C strongly backward stable. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] D. KRESSNER: -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVB). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER ILO, INFO, LDA, LDQG, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) -C .. Local Scalars .. - INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, - $ PXA, PXG, PXQ, PYA, WRKOPT -C .. External Functions .. - INTEGER UE01MD - EXTERNAL UE01MD -C .. External Subroutines .. - EXTERNAL DGEMM, DSYR2K, MB04PA, MB04PU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - 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 ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN - DWORK(1) = DBLE( MAX( 1, N-1 ) ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04PB', -INFO ) - RETURN - END IF -C -C Set elements 1:ILO-1 of TAU and CS. -C - DO 10 I = 1, ILO - 1 - TAU( I ) = ZERO - CS(2*I-1) = ONE - CS(2*I) = ZERO - 10 CONTINUE -C -C Quick return if possible. -C - IF ( N.LE.ILO ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Determine the block size. -C - NH = N - ILO + 1 - NB = UE01MD( 1, 'MB04PB', ' ', N, ILO, -1 ) - NBMIN = 2 - WRKOPT = N-1 - IF ( NB.GT.1 .AND. NB.LT.NH ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( NB, UE01MD( 3, 'MB04PB', ' ', N, ILO, -1 ) ) - IF ( NX.LT.NH ) THEN -C -C Check whether workspace is large enough for blocked code. -C - WRKOPT = 8*N*NB + 3*NB - IF ( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace available. Determine minimum value -C of NB, and reduce NB. -C - NBMIN = MAX( 2, UE01MD( 2, 'MB04PB', ' ', N, ILO, -1 ) ) - NB = LDWORK / ( 8*N + 3 ) - END IF - END IF - END IF -C - NNB = N*NB - PXA = 1 - PYA = PXA + 2*NNB - PXQ = PYA + 2*NNB - PXG = PXQ + 2*NNB - PDW = PXG + 2*NNB -C - IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN -C -C Use unblocked code. -C - I = ILO -C - ELSE - DO 20 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to PVL form and return the -C matrices XA, XG, XQ, and YA which are needed to update the -C unreduced parts of the matrices. -C - CALL MB04PA( .TRUE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I), - $ LDQG, DWORK(PXA), N, DWORK(PXG), N, - $ DWORK(PXQ), N, DWORK(PYA), N, CS(2*I-1), - $ TAU(I), DWORK(PDW) ) - IF ( N.GT.I+IB ) THEN -C -C Update the submatrix A(1:n,i+ib+1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, - $ IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1), - $ N, ONE, A(I+IB+1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, - $ IB, ONE, A(I+IB+1,I), LDA, - $ DWORK(PXA+NIB+IB+1), N, ONE, - $ A(I+IB+1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE, - $ A(1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA, - $ ONE, A(1,I+IB+1), LDA ) -C -C Update the submatrix Q(i+ib+1:n,i+ib+1:n). -C - CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE, - $ QG(I+IB+1,I+IB+1), LDQG ) - CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA, - $ ONE, QG(I+IB+1,I+IB+1), LDQG ) -C -C Update the submatrix G(1:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, - $ IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG, - $ ONE, QG(1,I+IB+2), LDQG ) - CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, - $ IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), LDA, - $ ONE, QG(1,I+IB+2), LDQG ) - CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE, - $ QG(I+IB+1,I+IB+2), LDQG ) - CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, - $ DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA, - $ ONE, QG(I+IB+1,I+IB+2), LDQG ) - END IF - 20 CONTINUE - END IF -C -C Unblocked code to reduce the rest of the matrices. -C - CALL MB04PU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, - $ IERR ) -C - DWORK( 1 ) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04PB *** - END diff --git a/slycot/src/MB04PU.f b/slycot/src/MB04PU.f deleted file mode 100644 index 2c13e663..00000000 --- a/slycot/src/MB04PU.f +++ /dev/null @@ -1,369 +0,0 @@ - SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a Hamiltonian matrix, -C -C [ A G ] -C H = [ T ] , -C [ Q -A ] -C -C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, -C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U -C is computed so that -C -C T [ Aout Gout ] -C U H U = [ T ] , -C [ Qout -Aout ] -C -C where Aout is upper Hessenberg and Qout is diagonal. -C Unblocked version. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that A is already upper triangular and Q is -C zero in rows and columns 1:ILO-1. ILO is normally set by a -C previous call to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Aout and, in the zero part of Aout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On entry, the leading N-by-N+1 part of this array must -C contain the lower triangular part of the matrix Q and -C the upper triangular part of the matrix G. -C On exit, the leading N-by-N+1 part of this array contains -C the diagonal of the matrix Qout, the upper triangular part -C of the matrix Gout and, in the zero parts of Qout, -C information about the elementary reflectors used to -C compute the PVL factorization. -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C CS (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations used -C to compute the PVL factorization. -C -C TAU (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N-1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix U is represented as a product of symplectic reflectors -C and Givens rotators -C -C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). -C -C Each H(i) has the form -C -C H(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C QG(i+2:n,i), and tau in QG(i+1,i). -C -C Each F(i) has the form -C -C F(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C A(i+2:n,i), and nu in TAU(i). -C -C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, -C where the cosine is stored in CS(2*i-1) and the sine in -C CS(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires 40/3 N**3 + O(N) floating point operations -C and is strongly backward stable. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVL). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER ILO, INFO, LDA, LDQG, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ALPHA, C, MU, NU, S, TEMP, TTEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DLARF, DLARFG, DLARTG, DROT, DSYMV, - $ DSYR2, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - 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 ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN - DWORK(1) = DBLE( MAX( 1, N-1 ) ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04PU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.LE.ILO ) THEN - DWORK(1) = ONE - RETURN - END IF -C - DO 10 I = ILO, N-1 -C -C Generate elementary reflector H(i) to annihilate QG(i+2:n,i). -C - ALPHA = QG(I+1,I) - CALL DLARFG( N-I, ALPHA, QG(MIN( I+2,N ),I), 1, NU ) - IF ( NU.NE.ZERO ) THEN - QG(I+1,I) = ONE -C -C Apply H(i) from both sides to QG(i+1:n,i+1:n). -C Compute x := nu * QG(i+1:n,i+1:n) * v. -C - CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * nu * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) - CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG := QG - v * w' - w * v'. -C - CALL DSYR2( 'Lower', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+1), LDQG ) -C -C Apply H(i) from the right hand side to QG(1:i,i+2:n+1). -C - CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2), - $ LDQG, DWORK ) -C -C Apply H(i) from both sides to QG(i+1:n,i+2:n+1). -C Compute x := nu * QG(i+1:n,i+2:n+1) * v. -C - CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * nu * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) - CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. -C - CALL DSYR2( 'Upper', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+2), LDQG ) -C -C Apply H(i) from the left hand side to A(i+1:n,i:n). -C - CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, - $ A(I+1,I), LDA, DWORK ) -C -C Apply H(i) from the right hand side to A(1:n,i+1:n). -C - CALL DLARF( 'Right', N, N-I, QG(I+1,I), 1, NU, - $ A(1,I+1), LDA, DWORK ) - END IF - QG(I+1,I) = NU -C -C Generate symplectic Givens rotation G(i) to annihilate -C QG(i+1,i). -C - TEMP = A(I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) ) -C -C Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)']. -C - CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, S ) -C -C Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)]. -C - CALL DROT(I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) -C -C Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right. -C - CALL DROT(N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, S ) -C -C Fix the diagonal part. -C - TEMP = A(I+1,I+1) - TTEMP = QG(I+1,I+2) - A(I+1,I+1) = C*TEMP + S*QG(I+1,I+1) - QG(I+1,I+2) = C*TTEMP - S * TEMP - QG(I+1,I+1) = -S*TEMP + C*QG(I+1,I+1) - TTEMP = -S*TTEMP - C*TEMP - TEMP = A(I+1,I+1) - QG(I+1,I+1) = C*QG(I+1,I+1) + S*TTEMP - A(I+1,I+1) = C*TEMP + S*QG(I+1,I+2) - QG(I+1,I+2) = -S*TEMP + C*QG(I+1,I+2) - CS(2*I-1) = C - CS(2*I) = S -C -C Generate elementary reflector F(i) to annihilate A(i+2:n,i). -C - CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2,N ),I), 1, NU ) - IF ( NU.NE.ZERO ) THEN - TEMP = A(I+1,I) - A(I+1,I) = ONE -C -C Apply F(i) from the left hand side to A(i+1:n,i+1:n). -C - CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1), - $ LDA, DWORK ) -C -C Apply G(i) from the right hand side to A(1:n,i+1:n). -C - CALL DLARF( 'Right', N, N-I, A(I+1,I), 1, NU, - $ A(1,I+1), LDA, DWORK ) -C -C Apply G(i) from both sides to QG(i+1:n,i+1:n). -C Compute x := nu * QG(i+1:n,i+1:n) * v. -C - CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * tau * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) - CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG := QG - v * w' - w * v'. -C - CALL DSYR2( 'Lower', N-I, -ONE, A(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+1), LDQG ) -C -C Apply G(i) from the right hand side to QG(1:i,i+2:n+1). -C - CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2), - $ LDQG, DWORK ) -C -C Apply G(i) from both sides to QG(i+1:n,i+2:n+1). -C Compute x := nu * QG(i+1:n,i+2:n+1) * v. -C - CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I), - $ 1, ZERO, DWORK, 1 ) -C -C Compute w := x - 1/2 * tau * (x'*v) * v. -C - MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) - CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) -C -C Apply the transformation as a rank-2 update: -C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. -C - CALL DSYR2( 'Upper', N-I, -ONE, A(I+1,I), 1, DWORK, 1, - $ QG(I+1,I+2), LDQG ) - A(I+1,I) = TEMP - END IF - TAU(I) = NU - 10 CONTINUE - DWORK(1) = DBLE( MAX( 1, N-1 ) ) - RETURN -C *** Last line of MB04PU *** - END diff --git a/slycot/src/MB04PY.f b/slycot/src/MB04PY.f deleted file mode 100644 index 09b5a17d..00000000 --- a/slycot/src/MB04PY.f +++ /dev/null @@ -1,648 +0,0 @@ - SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a real elementary reflector H to a real m-by-n matrix -C C, from either the left or the right. H is represented in the form -C ( 1 ) -C H = I - tau * u *u', u = ( ), -C ( v ) -C where tau is a real scalar and v is a real vector. -C -C If tau = 0, then H is taken to be the unit matrix. -C -C In-line code is used if H has order < 11. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Indicates whether the elementary reflector should be -C applied from the left or from the right, as follows: -C = 'L': Compute H * C; -C = 'R': Compute C * H. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix C. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix C. N >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (M-1), if SIDE = 'L', or -C (N-1), if SIDE = 'R'. -C The vector v in the representation of H. -C -C TAU (input) DOUBLE PRECISION -C The scalar factor of the elementary reflector H. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix C. -C On exit, the leading M-by-N part of this array contains -C the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or -C (M), if SIDE = 'R'. -C DWORK is not referenced if H has order less than 11. -C -C METHOD -C -C The routine applies the elementary reflector H, taking its special -C structure into account. The multiplications by the first component -C of u (which is 1) are avoided, to increase the efficiency. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C This is a modification of LAPACK Library routine DLARFX. -* -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, elementary reflector, orthogonal -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER SIDE - INTEGER LDC, M, N - DOUBLE PRECISION TAU -C .. -C .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), DWORK( * ), V( * ) -C .. -C .. Local Scalars .. - INTEGER J - DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, - $ V1, V2, V3, V4, V5, V6, V7, V8, V9 -C .. -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -C .. -C .. Executable Statements .. -C - IF( TAU.EQ.ZERO ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -C -C Form H * C, where H has order m. -C - GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, - $ 170, 190 ) M -C -C Code for general M. -C -C w := C'*u. -C - CALL DCOPY( N, C, LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', M-1, N, ONE, C( 2, 1 ), LDC, V, 1, - $ ONE, DWORK, 1 ) -C -C C := C - tau * u * w'. -C - CALL DAXPY( N, -TAU, DWORK, 1, C, LDC ) - CALL DGER( M-1, N, -TAU, V, 1, DWORK, 1, C( 2, 1 ), LDC ) - GO TO 410 - 10 CONTINUE -C -C Special code for 1 x 1 Householder. -C - T1 = ONE - TAU - DO 20 J = 1, N - C( 1, J ) = T1*C( 1, J ) - 20 CONTINUE - GO TO 410 - 30 CONTINUE -C -C Special code for 2 x 2 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - DO 40 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - 40 CONTINUE - GO TO 410 - 50 CONTINUE -C -C Special code for 3 x 3 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 60 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - 60 CONTINUE - GO TO 410 - 70 CONTINUE -C -C Special code for 4 x 4 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 80 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - 80 CONTINUE - GO TO 410 - 90 CONTINUE -C -C Special code for 5 x 5 Householder. -C - 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 100 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - 100 CONTINUE - GO TO 410 - 110 CONTINUE -C -C Special code for 6 x 6 Householder. -C - 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 120 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - 120 CONTINUE - GO TO 410 - 130 CONTINUE -C -C Special code for 7 x 7 Householder. -C - 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 140 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - 140 CONTINUE - GO TO 410 - 150 CONTINUE -C -C Special code for 8 x 8 Householder. -C - 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 160 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) + V7*C( 8, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - C( 8, J ) = C( 8, J ) - SUM*T7 - 160 CONTINUE - GO TO 410 - 170 CONTINUE -C -C Special code for 9 x 9 Householder. -C - 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 180 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - C( 8, J ) = C( 8, J ) - SUM*T7 - C( 9, J ) = C( 9, J ) - SUM*T8 - 180 CONTINUE - GO TO 410 - 190 CONTINUE -C -C Special code for 10 x 10 Householder. -C - 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 200 J = 1, N - SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + - $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + - $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + - $ V9*C( 10, J ) - C( 1, J ) = C( 1, J ) - SUM*TAU - C( 2, J ) = C( 2, J ) - SUM*T1 - C( 3, J ) = C( 3, J ) - SUM*T2 - C( 4, J ) = C( 4, J ) - SUM*T3 - C( 5, J ) = C( 5, J ) - SUM*T4 - C( 6, J ) = C( 6, J ) - SUM*T5 - C( 7, J ) = C( 7, J ) - SUM*T6 - C( 8, J ) = C( 8, J ) - SUM*T7 - C( 9, J ) = C( 9, J ) - SUM*T8 - C( 10, J ) = C( 10, J ) - SUM*T9 - 200 CONTINUE - GO TO 410 - ELSE -C -C Form C * H, where H has order n. -C - GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, - $ 370, 390 ) N -C -C Code for general N. -C -C w := C * u. -C - CALL DCOPY( M, C, 1, DWORK, 1 ) - CALL DGEMV( 'No transpose', M, N-1, ONE, C( 1, 2 ), LDC, V, 1, - $ ONE, DWORK, 1 ) -C -C C := C - tau * w * u'. -C - CALL DAXPY( M, -TAU, DWORK, 1, C, 1 ) - CALL DGER( M, N-1, -TAU, DWORK, 1, V, 1, C( 1, 2 ), LDC ) - GO TO 410 - 210 CONTINUE -C -C Special code for 1 x 1 Householder. -C - T1 = ONE - TAU - DO 220 J = 1, M - C( J, 1 ) = T1*C( J, 1 ) - 220 CONTINUE - GO TO 410 - 230 CONTINUE -C -C Special code for 2 x 2 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - DO 240 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - 240 CONTINUE - GO TO 410 - 250 CONTINUE -C -C Special code for 3 x 3 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - DO 260 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - 260 CONTINUE - GO TO 410 - 270 CONTINUE -C -C Special code for 4 x 4 Householder. -C - V1 = V( 1 ) - T1 = TAU*V1 - V2 = V( 2 ) - T2 = TAU*V2 - V3 = V( 3 ) - T3 = TAU*V3 - DO 280 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - 280 CONTINUE - GO TO 410 - 290 CONTINUE -C -C Special code for 5 x 5 Householder. -C - 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 300 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - 300 CONTINUE - GO TO 410 - 310 CONTINUE -C -C Special code for 6 x 6 Householder. -C - 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 320 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - 320 CONTINUE - GO TO 410 - 330 CONTINUE -C -C Special code for 7 x 7 Householder. -C - 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 340 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - 340 CONTINUE - GO TO 410 - 350 CONTINUE -C -C Special code for 8 x 8 Householder. -C - 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 360 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) + V7*C( J, 8 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - C( J, 8 ) = C( J, 8 ) - SUM*T7 - 360 CONTINUE - GO TO 410 - 370 CONTINUE -C -C Special code for 9 x 9 Householder. -C - 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 380 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - C( J, 8 ) = C( J, 8 ) - SUM*T7 - C( J, 9 ) = C( J, 9 ) - SUM*T8 - 380 CONTINUE - GO TO 410 - 390 CONTINUE -C -C Special code for 10 x 10 Householder. -C - 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 400 J = 1, M - SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + - $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + - $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + - $ V9*C( J, 10 ) - C( J, 1 ) = C( J, 1 ) - SUM*TAU - C( J, 2 ) = C( J, 2 ) - SUM*T1 - C( J, 3 ) = C( J, 3 ) - SUM*T2 - C( J, 4 ) = C( J, 4 ) - SUM*T3 - C( J, 5 ) = C( J, 5 ) - SUM*T4 - C( J, 6 ) = C( J, 6 ) - SUM*T5 - C( J, 7 ) = C( J, 7 ) - SUM*T6 - C( J, 8 ) = C( J, 8 ) - SUM*T7 - C( J, 9 ) = C( J, 9 ) - SUM*T8 - C( J, 10 ) = C( J, 10 ) - SUM*T9 - 400 CONTINUE - GO TO 410 - END IF - 410 CONTINUE - RETURN -C -C *** Last line of MB04PY *** - END diff --git a/slycot/src/MB04QB.f b/slycot/src/MB04QB.f deleted file mode 100644 index 6cb9e677..00000000 --- a/slycot/src/MB04QB.f +++ /dev/null @@ -1,454 +0,0 @@ - SUBROUTINE MB04QB( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, - $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To overwrite general real m-by-n matrices C and D, or their -C transposes, with -C -C [ op(C) ] -C Q * [ ] if TRANQ = 'N', or -C [ op(D) ] -C -C T [ op(C) ] -C Q * [ ] if TRANQ = 'T', -C [ op(D) ] -C -C where Q is defined as the product of symplectic reflectors and -C Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C Blocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANC CHARACTER*1 -C Specifies the form of op( C ) as follows: -C = 'N': op( C ) = C; -C = 'T': op( C ) = C'; -C = 'C': op( C ) = C'. -C -C TRAND CHARACTER*1 -C Specifies the form of op( D ) as follows: -C = 'N': op( D ) = D; -C = 'T': op( D ) = D'; -C = 'C': op( D ) = D'. -C -C TRANQ CHARACTER*1 -C = 'N': apply Q; -C = 'T': apply Q'. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in V are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in W are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices op(C) and op(D). -C M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices op(C) and op(D). -C N >= 0. -C -C K (input) INTEGER -C The number of elementary reflectors whose product defines -C the matrix Q. M >= K >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,M) if STOREV = 'R' -C On entry with STOREV = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors F(i). -C On entry with STOREV = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors F(i). -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if STOREV = 'C'; -C LDV >= MAX(1,K), if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,M) if STOREW = 'R' -C On entry with STOREW = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors H(i). -C On entry with STOREW = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors H(i). -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,M), if STOREW = 'C'; -C LDW >= MAX(1,K), if STOREW = 'R'. -C -C C (input/output) DOUBLE PRECISION array, dimension -C (LDC,N) if TRANC = 'N', -C (LDC,M) if TRANC = 'T' or TRANC = 'C' -C On entry with TRANC = 'N', the leading M-by-N part of -C this array must contain the matrix C. -C On entry with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix C. -C On exit with TRANC = 'N', the leading M-by-N part of -C this array contains the updated matrix C. -C On exit with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= MAX(1,M), if TRANC = 'N'; -C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,N) if TRAND = 'N', -C (LDD,M) if TRAND = 'T' or TRAND = 'C' -C On entry with TRAND = 'N', the leading M-by-N part of -C this array must contain the matrix D. -C On entry with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix D. -C On exit with TRAND = 'N', the leading M-by-N part of -C this array contains the updated matrix D. -C On exit with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= MAX(1,M), if TRAND = 'N'; -C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -20, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSB). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ - INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*), - $ V(LDV,*), W(LDW,*) -C .. Local Scalars .. - LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ - INTEGER I, IB, IC, ID, IERR, JC, JD, KI, KK, NB, NBMIN, - $ NX, PDRS, PDT, PDW, WRKOPT -C .. External Functions .. - INTEGER UE01MD - LOGICAL LSAME - EXTERNAL LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL MB04QC, MB04QF, MB04QU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) - LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) - LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) - LTRQ = LSAME( TRANQ, 'T' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN - INFO = -3 - ELSE IF ( .NOT.( LCOLV .OR. LSAME( STOREV, 'R' ) ) ) THEN - INFO = -4 - ELSE IF ( .NOT.( LCOLW .OR. LSAME( STOREW, 'R' ) ) ) THEN - INFO = -5 - ELSE IF ( M.LT.0 ) THEN - INFO = -6 - ELSE IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN - INFO = -8 - ELSE IF ( ( LCOLV .AND. LDV.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLV .AND. LDV.LT.MAX( 1, K ) ) ) THEN - INFO = -10 - ELSE IF ( ( LCOLW .AND. LDW.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLW .AND. LDW.LT.MAX( 1, K ) ) ) THEN - INFO = -12 - ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN - INFO = -14 - ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN - INFO = -16 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -20 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04QB', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( K, M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - NBMIN = 2 - NX = 0 - WRKOPT = N - NB = UE01MD( 1, 'MB04QB', TRANC // TRAND // TRANQ, M, N, K ) - IF ( NB.GT.1 .AND. NB.LT.K ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( 0, UE01MD( 3, 'MB04QB', TRANC // TRAND // TRANQ, M, - $ N, K ) ) - IF ( NX.LT.K ) THEN -C -C Determine if workspace is large enough for blocked code. -C - WRKOPT = MAX( WRKOPT, 9*N*NB + 15*NB*NB ) - IF ( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace to use optimal NB: reduce NB and -C determine the minimum value of NB. -C - NB = INT( ( SQRT( DBLE( 81*N*N + 60*LDWORK ) ) - $ - DBLE( 9*N ) ) / 30.0D0 ) - NBMIN = MAX( 2, UE01MD( 2, 'MB04QB', TRANC // TRAND // - $ TRANQ, M, N, K ) ) - END IF - END IF - END IF -C - PDRS = 1 - PDT = PDRS + 6*NB*NB - PDW = PDT + 9*NB*NB - IC = 1 - JC = 1 - ID = 1 - JD = 1 -C - IF ( LTRQ ) THEN -C -C Use blocked code initially. -C - IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, - $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ DWORK(PDW) ) -C -C Apply SH' to [ op(C)(i:m,:); op(D)(i:m,:) ] from the -C left. -C - IF ( LTRC ) THEN - JC = I - ELSE - IC = I - END IF - IF ( LTRD ) THEN - JD = I - ELSE - ID = I - END IF - CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, - $ 'Forward', STOREV, STOREW, M-I+1, N, IB, - $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, - $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), - $ LDD, DWORK(PDW) ) - 10 CONTINUE - ELSE - I = 1 - END IF -C -C Use unblocked code to update last or only block. -C - IF ( I.LE.K ) THEN - IF ( LTRC ) THEN - JC = I - ELSE - IC = I - END IF - IF ( LTRD ) THEN - JD = I - ELSE - ID = I - END IF - CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-I+1, N, - $ K-I+1, V(I,I), LDV, W(I,I), LDW, C(IC,JC), LDC, - $ D(ID,JD), LDD, CS(2*I-1), TAU(I), DWORK, - $ LDWORK, IERR ) - END IF - ELSE - IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -C -C Use blocked code after the last block. -C The first kk columns are handled by the block method. -C - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) - ELSE - KK = 0 - END IF -C -C Use unblocked code for the last or only block. -C - IF ( KK.LT.K ) THEN - IF ( LTRC ) THEN - JC = KK + 1 - ELSE - IC = KK + 1 - END IF - IF ( LTRD ) THEN - JD = KK + 1 - ELSE - ID = KK + 1 - END IF - CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-KK, N, - $ K-KK, V(KK+1,KK+1), LDV, W(KK+1,KK+1), LDW, - $ C(IC,JC), LDC, D(ID,JD), LDD, CS(2*KK+1), - $ TAU(KK+1), DWORK, LDWORK, IERR ) - END IF -C -C Blocked code. -C - IF ( KK.GT.0 ) THEN - DO 20 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, - $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ DWORK(PDW) ) -C -C Apply SH to [ op(C)(i:m,:); op(D)(i:m,:) ] from -C the left. -C - IF ( LTRC ) THEN - JC = I - ELSE - IC = I - END IF - IF ( LTRD ) THEN - JD = I - ELSE - ID = I - END IF - CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, - $ 'Forward', STOREV, STOREW, M-I+1, N, IB, - $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, - $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), - $ LDD, DWORK(PDW) ) - 20 CONTINUE - END IF - END IF - DWORK(1) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04QB *** - END diff --git a/slycot/src/MB04QC.f b/slycot/src/MB04QC.f deleted file mode 100644 index 44d6a9eb..00000000 --- a/slycot/src/MB04QC.f +++ /dev/null @@ -1,1223 +0,0 @@ - SUBROUTINE MB04QC( STRUCT, TRANA, TRANB, TRANQ, DIRECT, STOREV, - $ STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T, - $ LDT, A, LDA, B, LDB, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the orthogonal symplectic block reflector -C -C [ I+V*T*V' V*R*S*V' ] -C Q = [ ] -C [ -V*R*S*V' I+V*T*V' ] -C -C or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from -C the left. -C The k-by-k upper triangular blocks of the matrices -C -C [ S1 ] [ T11 T12 T13 ] -C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], -C [ S3 ] [ T31 T32 T33 ] -C -C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, -C are stored rowwise in the arrays RS and T, respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C STRUCT CHARACTER*1 -C Specifies the structure of the first blocks of A and B: -C = 'Z': the leading K-by-N submatrices of op(A) and op(B) -C are (implicitly) assumed to be zero; -C = 'N'; no structure to mention. -C -C TRANA CHARACTER*1 -C Specifies the form of op( A ) as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op( B ) as follows: -C = 'N': op( B ) = B; -C = 'T': op( B ) = B'; -C = 'C': op( B ) = B'. -C -C DIRECT CHARACTER*1 -C This is a dummy argument, which is reserved for future -C extensions of this subroutine. Not referenced. -C -C TRANQ CHARACTER*1 -C = 'N': apply Q; -C = 'T': apply Q'. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in V are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in W are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices op(A) and op(B). -C M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices op(A) and op(B). -C N >= 0. -C -C K (input) INTEGER -C The order of the triangular matrices defining R, S and T. -C M >= K >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,M) if STOREV = 'R' -C On entry with STOREV = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflector used to form parts of Q. -C On entry with STOREV = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflector used to form parts of Q. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if STOREV = 'C'; -C LDV >= MAX(1,K), if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,M) if STOREW = 'R' -C On entry with STOREW = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflector used to form parts of Q. -C On entry with STOREW = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflector used to form parts of Q. -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,M), if STOREW = 'C'; -C LDW >= MAX(1,K), if STOREW = 'R'. -C -C RS (input) DOUBLE PRECISION array, dimension (K,6*K) -C On entry, the leading K-by-6*K part of this array must -C contain the upper triangular matrices defining the factors -C R and S of the symplectic block reflector Q. The -C (strictly) lower portions of this array are not -C referenced. -C -C LDRS INTEGER -C The leading dimension of the array RS. LDRS >= MAX(1,K). -C -C T (input) DOUBLE PRECISION array, dimension (K,9*K) -C On entry, the leading K-by-9*K part of this array must -C contain the upper triangular matrices defining the factor -C T of the symplectic block reflector Q. The (strictly) -C lower portions of this array are not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,K). -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,N) if TRANA = 'N', -C (LDA,M) if TRANA = 'C' or TRANA = 'T' -C On entry with TRANA = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANA = 'T' or TRANA = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,M), if TRANA = 'N'; -C LDA >= MAX(1,N), if TRANA = 'C' or TRANA = 'T'. -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,N) if TRANB = 'N', -C (LDB,M) if TRANB = 'C' or TRANB = 'T' -C On entry with TRANB = 'N', the leading M-by-N part of this -C array must contain the matrix B. -C On entry with TRANB = 'T' or TRANB = 'C', the leading -C N-by-M part of this array must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,M), if TRANB = 'N'; -C LDB >= MAX(1,N), if TRANB = 'C' or TRANB = 'T'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK), where -C LDWORK >= 8*N*K, if STRUCT = 'Z', -C LDWORK >= 9*N*K, if STRUCT = 'N'. -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating -C point operations if STRUCT = 'Z' and additional ( 12*K + 2 )*K*N -C floating point operations if STRUCT = 'N'. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DIRECT, STOREV, STOREW, STRUCT, TRANA, TRANB, - $ TRANQ - INTEGER K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*), - $ T(LDT,*), V(LDV,*), W(LDW,*) -C .. Local Scalars .. - LOGICAL LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ - INTEGER I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6, - $ PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3, - $ PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32, - $ PT33 - DOUBLE PRECISION FACT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DLASET, DTRMM -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN - LA1B1 = LSAME( STRUCT, 'N' ) - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) - LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - LTRQ = LSAME( TRANQ, 'T' ) .OR. LSAME( TRANQ, 'C' ) -C - PR1 = 1 - PR2 = PR1 + K - PR3 = PR2 + K - PS1 = PR3 + K - PS2 = PS1 + K - PS3 = PS2 + K - PT11 = 1 - PT12 = PT11 + K - PT13 = PT12 + K - PT21 = PT13 + K - PT22 = PT21 + K - PT23 = PT22 + K - PT31 = PT23 + K - PT32 = PT31 + K - PT33 = PT32 + K - PDW1 = 1 - PDW2 = PDW1 + N*K - PDW3 = PDW2 + N*K - PDW4 = PDW3 + N*K - PDW5 = PDW4 + N*K - PDW6 = PDW5 + N*K - PDW7 = PDW6 + N*K - PDW8 = PDW7 + N*K - PDW9 = PDW8 + N*K -C -C Update the matrix A. -C - IF ( LA1B1 ) THEN -C -C NZ1) DW7 := A1' -C - IF ( LTRA ) THEN - DO 10 I = 1, K - CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 ) - 10 CONTINUE - ELSE - DO 20 I = 1, N - CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N ) - 20 CONTINUE - END IF -C -C NZ2) DW1 := DW7*W1 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 ) - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - END IF -C -C NZ3) DW2 := DW7*V1 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 ) - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW2), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW2), N ) - END IF - FACT = ONE - ELSE - FACT = ZERO - END IF -C -C 1) DW1 := A2'*W2 -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) - END IF -C -C 2) DW2 := A2'*V2 -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), - $ N ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), - $ N ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N ) - END IF -C - IF ( LTRQ ) THEN -C -C 3) DW3 := DW1*T11 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 4) DW4 := DW2*T31 -C - CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) -C -C 5) DW3 := DW3 + DW4 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ4) DW8 := DW7*T21 -C - CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) -C -C NZ5) DW3 := DW3 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) - END IF -C -C 6) DW4 := DW1*T12 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT12), LDT, DWORK(PDW4), N ) -C -C 7) DW5 := DW2*T32 -C - CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) -C -C 8) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ6) DW8 := DW7*T22 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ7) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 9) DW5 := DW2*T33 -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) -C -C 10) DW6 := DW1*T13 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT13), LDT, DWORK(PDW6), N ) -C -C 11) DW5 := DW5 + DW6 -C - CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ8) DW8 := DW7*T23 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT23), LDT, DWORK(PDW8), N ) -C -C NZ9) DW5 := DW5 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) - END IF -C -C 12) DW1 := DW1*R1 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW1), N ) -C -C 13) DW2 := DW2*R3 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N ) -C -C 14) DW1 := DW1 + DW2 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ10) DW7 := DW7*R2 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) -C -C NZ11) DW1 := DW1 + DW7 -C - CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 ) - END IF -C -C Swap Pointers PDW1 <-> PDW2 -C - ITEMP = PDW2 - PDW2 = PDW1 - PDW1 = ITEMP - ELSE -C -C 3) DW3 := DW1*T11' -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 4) DW4 := DW2*T13' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) -C -C 5) DW3 := DW3 + DW4 -C - CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ4) DW8 := DW7*T12' -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) -C -C NZ5) DW3 := DW3 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) - END IF -C -C 6) DW4 := DW2*T23' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) -C -C 7) DW5 := DW1*T21' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) -C -C 8) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ6) DW8 := DW7*T22' -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ7) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 9) DW5 := DW2*T33' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) -C -C 10) DW6 := DW1*T31' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT31+1), LDT, DWORK(PDW6), N ) -C -C 11) DW5 := DW5 + DW6 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ8) DW8 := DW7*T32' -C - CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N ) -C -C NZ9) DW5 := DW5 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) - END IF -C -C 12) DW1 := DW1*S1' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N ) -C -C 13) DW2 := DW2*S3' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) -C -C 14) DW2 := DW1 + DW2 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ10) DW7 := DW7*S2' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) -C -C NZ11) DW2 := DW2 + DW7 -C - CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 ) - END IF - END IF -C - IF ( LA1B1 ) THEN -C -C NZ12) DW9 := B1' -C - IF ( LTRB ) THEN - DO 30 I = 1, K - CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 ) - 30 CONTINUE - ELSE - DO 40 I = 1, N - CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N ) - 40 CONTINUE - END IF -C -C NZ13) DW1 := DW9*W1 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 ) - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, W, LDW, DWORK(PDW1), N ) - END IF -C -C NZ14) DW6 := DW9*V1 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 ) - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW6), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, - $ K, ONE, V, LDV, DWORK(PDW6), N ) - END IF - END IF -C -C 15) DW1 := B2'*W2 -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LTRB ) THEN -C -C Critical Position -C - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) - END IF -C -C 16) DW6 := B2'*V2 -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), - $ N ) - ELSE IF ( LTRB ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, - $ B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), - $ N ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), - $ N ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), - $ N ) - END IF - ELSE IF ( .NOT.LA1B1 ) THEN - CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N ) - END IF -C - IF ( LTRQ ) THEN -C -C 17) DW7 := DW1*R1 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW7), N ) -C -C 18) DW8 := DW6*R3 -C - CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) -C -C 19) DW7 := DW7 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ15) DW8 := DW9*R2 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW8), N ) -C -C NZ16) DW7 := DW7 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) - END IF -C -C 20) DW8 := DW7*S1 -C - CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) -C -C 21) DW3 := DW3 - DW8 -C - CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) -C -C 22) DW8 := DW7*S3 -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N ) -C -C 23) DW5 := DW5 - DW8 -C - CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) -C -C 24) DW7 := DW7*S2 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) - ELSE -C -C 17) DW7 := DW6*S3' -C - CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS3), LDRS, DWORK(PDW7), N ) -C -C 18) DW8 := DW1*S1' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) -C -C 19) DW7 := DW7 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ15) DW8 := DW9*S2' -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS2), LDRS, DWORK(PDW8), N ) -C -C NZ16) DW7 := DW7 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) - END IF -C -C 20) DW8 := DW7*R1' -C - CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW8), N ) -C -C 21) DW3 := DW3 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) -C -C 22) DW8 := DW7*R3' -C - CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) -C -C 23) DW5 := DW5 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) -C -C 24) DW7 := DW7*R2' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) - END IF -C -C 25) A2 := A2 + W2*DW3' -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), - $ LDA ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), - $ LDA ) - END IF - END IF -C -C 26) A2 := A2 + V2*DW5' -C - IF ( M.GT.K ) THEN - IF ( LTRA.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LTRA ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1), - $ LDA ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), - $ LDA ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), - $ LDA ) - END IF - END IF -C -C 27) DW4 := DW4 + DW7 -C - CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 ) -C -C 28) DW3 := DW3*W1' -C - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ W, LDW, DWORK(PDW3), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, W, LDW, DWORK(PDW3), N ) - END IF -C -C 29) DW4 := DW4 + DW3 -C - CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) -C -C 30) DW5 := DW5*V1' -C - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ V, LDV, DWORK(PDW5), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, V, LDV, DWORK(PDW5), N ) - END IF -C -C 31) DW4 := DW4 + DW5 -C - CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C -C 32) A1 := A1 + DW4' -C - IF ( LA1B1 ) THEN - IF ( LTRA ) THEN - DO 50 I = 1, K - CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) - 50 CONTINUE - ELSE - DO 60 I = 1, N - CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 ) - 60 CONTINUE - END IF - ELSE - IF ( LTRA ) THEN - DO 70 I = 1, K - CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) - 70 CONTINUE - ELSE - DO 80 I = 1, N - CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 ) - 80 CONTINUE - END IF - END IF -C -C Update the matrix B. -C - IF ( LTRQ ) THEN -C -C 33) DW3 := DW1*T11 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 34) DW4 := DW6*T31 -C - CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) -C -C 35) DW3 := DW3 + DW4 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ17) DW8 := DW9*T21 -C - CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) -C -C NZ18) DW3 := DW3 + DW8 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) - END IF -C -C 36) DW4 := DW2*S1 -C - CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N ) -C -C 37) DW3 := DW3 + DW4 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) -C -C 38) DW4 := DW1*T12 -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT12), LDT, DWORK(PDW4), N ) -C -C 38) DW5 := DW6*T32 -C - CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) -C -C 40) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW8 := DW9*T22 -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ20) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 41) DW5 := DW2*S2 -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS2), LDRS, DWORK(PDW5), N ) -C -C 42) DW4 := DW4 + DW5 -C - CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C -C 43) DW6 := DW6*T33 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) -C -C 44) DW1 := DW1*T13 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT13), LDT, DWORK(PDW1), N ) -C -C 45) DW6 := DW6 + DW1 -C - CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW9 := DW9*T23 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, - $ K, ONE, T(1,PT23), LDT, DWORK(PDW9), N ) -C -C NZ20) DW6 := DW6 + DW9 -C - CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 ) - END IF -C -C 46) DW2 := DW2*S3 -C - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) -C -C 45) DW6 := DW6 + DW2 -C - CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 ) - ELSE -C -C 33) DW3 := DW1*T11' -C - CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) -C -C 34) DW4 := DW6*T13' -C - CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) -C -C 35) DW3 := DW3 + DW4 -C - CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ17) DW8 := DW9*T12' -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) -C -C NZ18) DW3 := DW3 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) - END IF -C -C 36) DW4 := DW2*R1' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, RS(1,PR1), LDRS, DWORK(PDW4), N ) -C -C 37) DW3 := DW3 - DW4 -C - CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) -C -C 38) DW4 := DW6*T23' -C - CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) -C -C 39) DW5 := DW1*T21' -C - CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) -C -C 40) DW4 := DW4 + DW5 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW8 := DW9*T22' -C - CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) -C -C NZ20) DW4 := DW4 + DW8 -C - CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) - END IF -C -C 41) DW5 := DW2*R2' -C - CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, RS(1,PR2), LDRS, DWORK(PDW5), N ) -C -C 42) DW4 := DW4 - DW5 -C - CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) -C -C 43) DW6 := DW6*T33' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, - $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) -C -C 44) DW1 := DW1*T31' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N ) -C -C 45) DW6 := DW6 + DW1 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) -C - IF ( LA1B1 ) THEN -C -C NZ19) DW9 := DW9*T32' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, - $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N ) -C -C NZ20) DW6 := DW6 + DW9 -C - CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 ) - END IF -C -C 46) DW2 := DW2*R3' -C - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, - $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N ) -C -C 45) DW6 := DW6 - DW2 -C - CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 ) - END IF -C -C 46) B2 := B2 + W2*DW3' -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LTRB ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LCOLW ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), - $ LDB ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), - $ LDB ) - END IF - END IF -C -C 47) B2 := B2 + V2*DW6' -C - IF ( M.GT.K ) THEN - IF ( LTRB.AND.LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, - $ DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LTRB ) THEN - CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, - $ DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1), - $ LDB ) - ELSE IF ( LCOLV ) THEN - CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, - $ V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), - $ LDB ) - ELSE - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, - $ V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), - $ LDB ) - END IF - END IF -C -C 48) DW3 := DW3*W1' -C - IF ( LCOLW ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ W, LDW, DWORK(PDW3), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, W, LDW, DWORK(PDW3), N ) - END IF -C -C 49) DW4 := DW4 + DW3 -C - CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) -C -C 50) DW6 := DW6*V1' -C - IF ( LCOLV ) THEN - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, - $ V, LDV, DWORK(PDW6), N ) - ELSE - CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, - $ ONE, V, LDV, DWORK(PDW6), N ) - END IF -C -C 51) DW4 := DW4 + DW6 -C - CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 ) -C -C 52) B1 := B1 + DW4' -C - IF ( LA1B1 ) THEN - IF ( LTRB ) THEN - DO 90 I = 1, K - CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) - 90 CONTINUE - ELSE - DO 100 I = 1, N - CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 ) - 100 CONTINUE - END IF - ELSE - IF ( LTRB ) THEN - DO 110 I = 1, K - CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) - 110 CONTINUE - ELSE - DO 120 I = 1, N - CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 ) - 120 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of MB04QC *** - END diff --git a/slycot/src/MB04QF.f b/slycot/src/MB04QF.f deleted file mode 100644 index f2be26ce..00000000 --- a/slycot/src/MB04QF.f +++ /dev/null @@ -1,532 +0,0 @@ - SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW, - $ CS, TAU, RS, LDRS, T, LDT, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To form the triangular block factors R, S and T of a symplectic -C block reflector SH, which is defined as a product of 2k -C concatenated Householder reflectors and k Givens rotators, -C -C SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C The upper triangular blocks of the matrices -C -C [ S1 ] [ T11 T12 T13 ] -C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], -C [ S3 ] [ T31 T32 T33 ] -C -C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, -C are stored rowwise in the arrays RS and T, respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C DIRECT CHARACTER*1 -C This is a dummy argument, which is reserved for future -C extensions of this subroutine. Not referenced. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder F(i) reflectors are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder H(i) reflectors are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the Householder reflectors F(i) and H(i). -C N >= 0. -C -C K (input) INTEGER -C The number of Givens rotators. K >= 1. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,N) if STOREV = 'R' -C On entry with STOREV = 'C', the leading N-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector F(i). -C On entry with STOREV = 'R', the leading K-by-N part of -C this array must contain in its i-th row the vector -C which defines the elementary reflector F(i). -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,N), if STOREV = 'C'; -C LDV >= K, if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,N) if STOREW = 'R' -C On entry with STOREW = 'C', the leading N-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector H(i). -C On entry with STOREV = 'R', the leading K-by-N part of -C this array must contain in its i-th row the vector -C which defines the elementary reflector H(i). -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,N), if STOREW = 'C'; -C LDW >= K, if STOREW = 'R'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C RS (output) DOUBLE PRECISION array, dimension (K,6*K) -C On exit, the leading K-by-6*K part of this array contains -C the upper triangular matrices defining the factors R and -C S of the symplectic block reflector SH. The (strictly) -C lower portions of this array are not used. -C -C LDRS INTEGER -C The leading dimension of the array RS. LDRS >= K. -C -C T (output) DOUBLE PRECISION array, dimension (K,9*K) -C On exit, the leading K-by-9*K part of this array contains -C the upper triangular matrices defining the factor T of the -C symplectic block reflector SH. The (strictly) lower -C portions of this array are not used. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= K. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*K) -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C NUMERICAL ASPECTS -C -C The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K -C + 43/6*K - 4 floating point operations. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAEST). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DIRECT, STOREV, STOREW - INTEGER K, LDRS, LDT, LDV, LDW, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), RS(LDRS,*), T(LDT,*), - $ TAU(*), V(LDV,*), W(LDW,*) -C .. Local Scalars .. - LOGICAL LCOLV, LCOLW - INTEGER I, J, K2, PR1, PR2, PR3, PS1, PS2, PS3, PT11, - $ PT12, PT13, PT21, PT22, PT23, PT31, PT32, PT33 - DOUBLE PRECISION CM1, TAUI, VII, WII -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DSCAL, DTRMV -C -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) -C - K2 = K + K - PR1 = 0 - PR2 = PR1 + K - PR3 = PR2 + K - PS1 = PR3 + K - PS2 = PS1 + K - PS3 = PS2 + K -C - PT11 = 0 - PT12 = PT11 + K - PT13 = PT12 + K - PT21 = PT13 + K - PT22 = PT21 + K - PT23 = PT22 + K - PT31 = PT23 + K - PT32 = PT31 + K - PT33 = PT32 + K -C - DO 90 I = 1, K - TAUI = TAU(I) - VII = V(I,I) - V(I,I) = ONE - WII = W(I,I) - W(I,I) = ONE - IF ( WII.EQ.ZERO ) THEN - DO 10 J = 1, I - T(J,PT11+I) = ZERO - 10 CONTINUE - DO 20 J = 1, I-1 - T(J,PT21+I) = ZERO - 20 CONTINUE - DO 30 J = 1, I-1 - T(J,PT31+I) = ZERO - 30 CONTINUE - DO 40 J = 1, I-1 - RS(J,PS1+I) = ZERO - 40 CONTINUE - ELSE -C -C Treat first Householder reflection. -C - IF ( LCOLV.AND.LCOLW ) THEN -C -C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, - $ W(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(i:n,1:i-1)' * W(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, - $ W(I,I), 1, ZERO, DWORK(K+1), 1 ) - ELSE IF ( LCOLV ) THEN -C -C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), - $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(i:n,1:i-1)' * W(i,i:n)'. -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, - $ W(I,I), LDW, ZERO, DWORK(K+1), 1 ) - ELSE IF ( LCOLW ) THEN -C -C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, - $ W(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(1:i-1,i:n) * W(i:n,i). -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), - $ LDV, W(I,I), 1, ZERO, DWORK(K+1), 1 ) - ELSE -C -C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), - $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) -C -C Compute t2 = -wii * V(1:i-1,i:n) * W(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), - $ LDV, W(I,I), LDW, ZERO, DWORK(K+1), 1 ) - END IF -C -C T11(1:i-1,i) := T11(1:i-1,1:i-1)*t1 + T13(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-1, DWORK, 1, T(1,PT11+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT11+1), LDT, T(1,PT11+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, T(1,PT11+I), 1 ) - T(I,PT11+I) = -WII -C - IF ( I.GT.1 ) THEN -C -C T21(1:i-1,i) := T21(1:i-1,1:i-1)*t1 + T23(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-2, DWORK(2), 1, T(1,PT21+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, - $ T(1,PT21+2), LDT, T(1,PT21+I), 1 ) - T(I-1, PT21+I) = ZERO - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, T(1,PT21+I), 1 ) -C -C T31(1:i-1,i) := T31(1:i-1,1:i-1)*t1 + T33(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-2, DWORK(2), 1, T(1,PT31+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, - $ T(1,PT31+2), LDT, T(1,PT31+I), 1 ) - T(I-1, PT31+I) = ZERO - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, T(1,PT31+I), 1 ) -C -C S1(1:i-1,i) := S1(1:i-1,1:i-1)*t1 + S3(1:i-1,1:i-1)*t2 -C - CALL DCOPY( I-2, DWORK(2), 1, RS(1,PS1+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, - $ RS(1,PS1+2), LDRS, RS(1,PS1+I), 1 ) - RS(I-1, PS1+I) = ZERO - CALL DCOPY( I-1, DWORK(K+1), 1, RS(1,PS3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) - CALL DAXPY( I-1, ONE, RS(1,PS3+I), 1, RS(1,PS1+I), 1 ) - END IF - END IF -C -C Treat Givens rotation. -C - CM1 = CS(2*I-1) - ONE - IF ( LCOLW ) THEN - CALL DCOPY( I, W(I,1), LDW, DWORK, 1 ) - ELSE - CALL DCOPY( I, W(1,I), 1, DWORK, 1 ) - END IF - IF ( LCOLV ) THEN - CALL DCOPY( I-1, V(I,1), LDV, DWORK(K+1), 1 ) - ELSE - CALL DCOPY( I-1, V(1,I), 1, DWORK(K+1), 1 ) - END IF -C -C R1(1:i,i) = T11(1:i,1:i) * dwork(1:i) -C + [ T13(1:i-1,1:i-1) * dwork(k+1:k+i-1); 0 ] -C - CALL DCOPY( I, DWORK, 1, RS(1,PR1+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, - $ T(1,PT11+1), LDT, RS(1,PR1+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, RS(1,PR1+I), 1 ) -C -C R2(1:i-1,i) = T21(1:i-1,2:i) * W(i,2:i) -C + T23(1:i-1,1:i-1) * V(i,1:i-1) -C - CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR2+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT21+2), LDT, RS(1,PR2+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, RS(1,PR2+I), 1 ) -C -C R3(1:i-1,i) = T31(1:i-1,2:i) * dwork(2:i) -C + T33(1:i-1,1:i-1) * dwork(k+1:k+i-1) -C - CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT31+2), LDT, RS(1,PR3+I), 1 ) - CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) - CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, RS(1,PR3+I), 1 ) -C -C S2(1:i-1,i) = S1(1:i-1,2:i) * dwork(2:i) -C + S3(1:i-1,1:i-1) * dwork(k+1:k+i-1) -C - CALL DCOPY( I-1, DWORK(2), 1, RS(1,PS2+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS1+2), LDRS, RS(1,PS2+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS3+1), LDRS, DWORK(K+1), 1 ) - CALL DAXPY( I-1, ONE, DWORK(K+1), 1, RS(1,PS2+I), 1 ) - RS(I,PS2+I) = -CS(2*I) -C -C T12(1:i,i) = [ R1(1:i-1,1:i-1)*S2(1:i-1,i); 0 ] -C + (c-1) * R1(1:i,i) -C - CALL DCOPY( I-1, RS(1,PS2+I), 1, T(1,PT12+I), 1 ) - CALL DSCAL( I-1, CM1, RS(1,PS2+I), 1) - CALL DSCAL( I-1, CS(2*I), T(1,PT12+I), 1 ) - CALL DCOPY( I-1, T(1,PT12+I), 1, T(1,PT22+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PR1+1), LDRS, T(1,PT12+I), 1 ) - T(I,PT12+I) = ZERO - CALL DAXPY( I, CM1, RS(1,PR1+I), 1, T(1,PT12+I), 1 ) -C -C T22(1:i-1,i) = R2(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R2(1:i-1,i) -C - IF (I.GT.1) - $ CALL DCOPY( I-2, T(2,PT22+I), 1, T(1,PT32+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Unit diagonal', I-1, - $ RS(1,PR2+1), LDRS, T(1,PT22+I), 1 ) - CALL DAXPY( I-1, CM1, RS(1,PR2+I), 1, T(1,PT22+I), 1 ) - T(I,PT22+I) = CM1 -C -C T32(1:i-1,i) = R3(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R3(1:i-1,i) -C - IF ( I.GT.1 ) THEN - CALL DTRMV( 'Upper', 'No transpose', 'Non-Unit', I-2, - $ RS(1,PR3+2), LDRS, T(1,PT32+I), 1 ) - T(I-1,PT32+I) = ZERO - CALL DAXPY( I-1, CM1, RS(1,PR3+I), 1, T(1,PT32+I), 1 ) - END IF -C - IF ( TAUI.EQ.ZERO ) THEN - DO 50 J = 1, I - T(J,PT13+I) = ZERO - 50 CONTINUE - DO 60 J = 1, I - T(J,PT23+I) = ZERO - 60 CONTINUE - DO 70 J = 1, I - T(J,PT33+I) = ZERO - 70 CONTINUE - DO 80 J = 1, I - RS(J,PS3+I) = ZERO - 80 CONTINUE - ELSE -C -C Treat second Householder reflection. -C - IF ( LCOLV.AND.LCOLW ) THEN -C -C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), - $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), - $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) - ELSE IF ( LCOLV ) THEN -C -C Compute t1 = -tau(i) * W(1:i,i:n) * V(i:n,i). -C - CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), - $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). -C - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), - $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) - ELSE IF ( LCOLW ) THEN -C -C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i,i:n)'. -C - CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), - $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), - $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) - ELSE -C -C Compute t1 = -tau(i) * W(1:i,i:n) * V(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), - $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) -C -C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. -C - CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), - $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) - END IF -C -C T13(1:i,i) := T11(1:i,1:i)*t1 - tau(i)*T12(1:i,i) -C + [T13(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT13+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) - T(I,PT13+I) = ZERO - CALL DCOPY( I, DWORK, 1, DWORK(K+1), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, - $ T(1,PT11+1), LDT, DWORK(K+1), 1 ) - CALL DAXPY( I, ONE, DWORK(K+1), 1, T(1,PT13+I), 1 ) - CALL DAXPY( I, -TAUI, T(1,PT12+I), 1, T(1,PT13+I), 1 ) -C -C T23(1:i,i) := T21(1:i,1:i)*t1 - tau(i)*T22(1:i,i) -C + [T23(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT23+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) - T(I,PT23+I) = ZERO - CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT21+2), LDT, DWORK(K+1), 1 ) - CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT23+I), 1 ) - CALL DAXPY( I, -TAUI, T(1,PT22+I), 1, T(1,PT23+I), 1 ) -C -C T33(1:i,i) := T31(1:i,1:i)*t1 - tau(i)*T32(1:i,i) -C + [T33(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT33+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) - CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ T(1,PT31+2), LDT, DWORK(K+1), 1 ) - CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT33+I), 1 ) - CALL DAXPY( I-1, -TAUI, T(1,PT32+I), 1, T(1,PT33+I), 1 ) - T(I,PT33+I) = -TAUI -C -C S3(1:i,i) := S1(1:i,1:i)*t1 - tau(i)*S2(1:i,i) -C + [S3(1:i-1,1:i-1)*t2;0] -C - CALL DCOPY( I-1, DWORK(K2+1), 1, RS(1,PS3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, - $ RS(1,PS1+2), LDRS, DWORK(2), 1 ) - CALL DAXPY( I-1, ONE, DWORK(2), 1, RS(1,PS3+I), 1 ) - RS(I,PS3+I) = ZERO - CALL DAXPY( I, -TAUI, RS(1,PS2+I), 1, RS(1,PS3+I), 1 ) - END IF - W(I,I) = WII - V(I,I) = VII - 90 CONTINUE -C - RETURN -C *** Last line of MB04QF *** - END diff --git a/slycot/src/MB04QU.f b/slycot/src/MB04QU.f deleted file mode 100644 index 6ae814da..00000000 --- a/slycot/src/MB04QU.f +++ /dev/null @@ -1,472 +0,0 @@ - SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, - $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To overwrite general real m-by-n matrices C and D, or their -C transposes, with -C -C [ op(C) ] -C Q * [ ] if TRANQ = 'N', or -C [ op(D) ] -C -C T [ op(C) ] -C Q * [ ] if TRANQ = 'T', -C [ op(D) ] -C -C where Q is defined as the product of symplectic reflectors and -C Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C Unblocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANC CHARACTER*1 -C Specifies the form of op( C ) as follows: -C = 'N': op( C ) = C; -C = 'T': op( C ) = C'; -C = 'C': op( C ) = C'. -C -C STOREV CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in V are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C STOREW CHARACTER*1 -C Specifies how the vectors which define the concatenated -C Householder reflectors contained in W are stored: -C = 'C': columnwise; -C = 'R': rowwise. -C -C TRAND CHARACTER*1 -C Specifies the form of op( D ) as follows: -C = 'N': op( D ) = D; -C = 'T': op( D ) = D'; -C = 'C': op( D ) = D'. -C -C TRANQ CHARACTER*1 -C = 'N': apply Q; -C = 'T': apply Q'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices op(C) and op(D). -C M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices op(C) and op(D). -C N >= 0. -C -C K (input) INTEGER -C The number of elementary reflectors whose product defines -C the matrix Q. M >= K >= 0. -C -C V (input) DOUBLE PRECISION array, dimension -C (LDV,K) if STOREV = 'C', -C (LDV,M) if STOREV = 'R' -C On entry with STOREV = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors F(i). -C On entry with STOREV = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors F(i). -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if STOREV = 'C'; -C LDV >= MAX(1,K), if STOREV = 'R'. -C -C W (input) DOUBLE PRECISION array, dimension -C (LDW,K) if STOREW = 'C', -C (LDW,M) if STOREW = 'R' -C On entry with STOREW = 'C', the leading M-by-K part of -C this array must contain in its columns the vectors which -C define the elementary reflectors H(i). -C On entry with STOREW = 'R', the leading K-by-M part of -C this array must contain in its rows the vectors which -C define the elementary reflectors H(i). -C -C LDW INTEGER -C The leading dimension of the array W. -C LDW >= MAX(1,M), if STOREW = 'C'; -C LDW >= MAX(1,K), if STOREW = 'R'. -C -C C (input/output) DOUBLE PRECISION array, dimension -C (LDC,N) if TRANC = 'N', -C (LDC,M) if TRANC = 'T' or TRANC = 'C' -C On entry with TRANC = 'N', the leading M-by-N part of -C this array must contain the matrix C. -C On entry with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix C. -C On exit with TRANC = 'N', the leading M-by-N part of -C this array contains the updated matrix C. -C On exit with TRANC = 'C' or TRANC = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= MAX(1,M), if TRANC = 'N'; -C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,N) if TRAND = 'N', -C (LDD,M) if TRAND = 'T' or TRAND = 'C' -C On entry with TRAND = 'N', the leading M-by-N part of -C this array must contain the matrix D. -C On entry with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array must contain the transpose of -C the matrix D. -C On exit with TRAND = 'N', the leading M-by-N part of -C this array contains the updated matrix D. -C On exit with TRAND = 'C' or TRAND = 'T', the leading -C N-by-M part of this array contains the transpose of the -C updated matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. -C LDD >= MAX(1,M), if TRAND = 'N'; -C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -20, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSQ). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ - INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), C(LDC,*), D(LDD,*), V(LDV,*), - $ W(LDW,*), TAU(*) -C .. Local Scalars .. - LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ - INTEGER I - DOUBLE PRECISION NU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LCOLV = LSAME( STOREV, 'C' ) - LCOLW = LSAME( STOREW, 'C' ) - LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) - LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) - LTRQ = LSAME( TRANQ, 'T' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRC.OR.LSAME( TRANC, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN - INFO = -3 - ELSE IF ( .NOT.( LCOLV.OR. LSAME( STOREV, 'R' ) ) ) THEN - INFO = -4 - ELSE IF ( .NOT.( LCOLW.OR. LSAME( STOREW, 'R' ) ) ) THEN - INFO = -5 - ELSE IF ( M.LT.0 ) THEN - INFO = -6 - ELSE IF ( N.LT.0 ) THEN - INFO = -7 - ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN - INFO = -8 - ELSE IF ( ( LCOLV.AND.LDV.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLV.AND.LDV.LT.MAX( 1, K ) ) ) THEN - INFO = -10 - ELSE IF ( ( LCOLW.AND.LDW.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LCOLW.AND.LDW.LT.MAX( 1, K ) ) ) THEN - INFO = -12 - ELSE IF ( ( LTRC.AND.LDC.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRC.AND.LDC.LT.MAX( 1, M ) ) ) THEN - INFO = -14 - ELSE IF ( ( LTRD.AND.LDD.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRD.AND.LDD.LT.MAX( 1, M ) ) ) THEN - INFO = -16 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -20 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04QU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( K, M, N ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - IF ( LTRQ ) THEN - DO 10 I = 1, K -C -C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = W(I,I) - W(I,I) = ONE - IF ( LCOLW ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), - $ LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), - $ LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), - $ LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), - $ LDD, DWORK ) - END IF - END IF - W(I,I) = NU -C -C Apply G(i) to C(I,:) and D(I,:) from the left. -C - IF ( LTRC.AND.LTRD ) THEN - CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), CS(2*I) ) - ELSE IF ( LTRC ) THEN - CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), - $ CS(2*I) ) - ELSE IF ( LTRD ) THEN - CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), - $ CS(2*I) ) - ELSE - CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), - $ CS(2*I) ) - END IF -C -C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = V(I,I) - V(I,I) = ONE - IF ( LCOLV ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - END IF - V(I,I) = NU - 10 CONTINUE - ELSE - DO 20 I = K, 1, -1 -C -C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = V(I,I) - V(I,I) = ONE - IF ( LCOLV ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ C(I,1), LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), - $ D(I,1), LDD, DWORK ) - END IF - END IF - V(I,I) = NU -C -C Apply G(i) to C(I,:) and D(I,:) from the left. -C - IF ( LTRC.AND.LTRD ) THEN - CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), -CS(2*I) ) - ELSE IF ( LTRC ) THEN - CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), - $ -CS(2*I) ) - ELSE IF ( LTRD ) THEN - CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), - $ -CS(2*I) ) - ELSE - CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), - $ -CS(2*I) ) - END IF -C -C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. -C - NU = W(I,I) - W(I,I) = ONE - IF ( LCOLW ) THEN - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), - $ LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), - $ LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), - $ LDD, DWORK ) - END IF - ELSE - IF ( LTRC ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ C(1,I), LDC, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), - $ LDC, DWORK ) - END IF - IF ( LTRD ) THEN - CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, - $ D(1,I), LDD, DWORK ) - ELSE - CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), - $ LDD, DWORK ) - END IF - END IF - W(I,I) = NU - 20 CONTINUE - END IF -C - DWORK(1) = DBLE( MAX( 1, N ) ) -C *** Last line of MB04QU *** - END diff --git a/slycot/src/MB04TB.f b/slycot/src/MB04TB.f deleted file mode 100644 index 3d5ad661..00000000 --- a/slycot/src/MB04TB.f +++ /dev/null @@ -1,677 +0,0 @@ - SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, - $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a symplectic URV (SURV) decomposition of a real -C 2N-by-2N matrix H, -C -C [ op(A) G ] [ op(R11) R12 ] -C H = [ ] = U R V' = U * [ ] * V' , -C [ Q op(B) ] [ 0 op(R22) ] -C -C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real -C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower -C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic -C matrices. Blocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op( A ) as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op( B ) as follows: -C = 'N': op( B ) = B; -C = 'T': op( B ) = B'; -C = 'C': op( B ) = B'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that op(A) is already upper triangular, -C op(B) is lower triangular and Q is zero in rows and -C columns 1:ILO-1. ILO is normally set by a previous call -C to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the triangular matrix R11, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix B. -C On exit, the leading N-by-N part of this array contains -C the Hessenberg matrix R22, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix G. -C On exit, the leading N-by-N part of this array contains -C the matrix R12. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix Q. -C On exit, the leading N-by-N part of this array contains -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C CSL (output) DOUBLE PRECISION array, dimension (2N) -C On exit, the first 2N elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the left-hand side used to compute the SURV -C decomposition. -C -C CSR (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the right-hand side used to compute the SURV -C decomposition. -C -C TAUL (output) DOUBLE PRECISION array, dimension (N) -C On exit, the first N elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the left-hand side. -C -C TAUR (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied form the right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK, (16*N + 5)*NB, where NB is the optimal -C block size determined by the function UE01MD. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices U and V are represented as products of symplectic -C reflectors and Givens rotators -C -C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) -C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) -C .... -C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), -C -C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) -C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) -C .... -C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). -C -C Each HU(i) has the form -C -C HU(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in -C Q(i+1:n,i), and tau in Q(i,i). -C -C Each FU(i) has the form -C -C FU(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in -C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The -C scalar nu is stored in TAUL(i). -C -C Each GU(i) is a Givens rotator acting on rows i and n+i, -C where the cosine is stored in CSL(2*i-1) and the sine in -C CSL(2*i). -C -C Each HV(i) has the form -C -C HV(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C Q(i,i+2:n), and tau in Q(i,i+1). -C -C Each FV(i) has the form -C -C FV(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. -C The scalar nu is stored in TAUR(i). -C -C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, -C where the cosine is stored in CSR(2*i-1) and the sine in -C CSR(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 + -C ( -16*NB + 48 )*NB*N + O(N) floating point operations, where -C NB is the used block size, and is numerically backward stable. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. -C -C [2] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUB). -C -C KEYWORDS -C -C Elementary matrix operations, Matrix decompositions, Hamiltonian -C matrix -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), - $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) -C .. Local Scalars .. - LOGICAL LTRA, LTRB - INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, - $ PXA, PXB, PXG, PXQ, PYA, PYB, PYG, PYQ, WRKOPT -C .. External Functions .. - LOGICAL LSAME - INTEGER UE01MD - EXTERNAL LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL DGEMM, MB03XU, MB04TS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) 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 ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -18 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04TB', -INFO ) - RETURN - END IF -C -C Set elements 1:ILO-1 of CSL, CSR, TAUL and TAUR to their default -C values. -C - DO 10 I = 1, ILO - 1 - CSL(2*I-1) = ONE - CSL(2*I) = ZERO - CSR(2*I-1) = ONE - CSR(2*I) = ZERO - TAUL(I) = ZERO - TAUR(I) = ZERO - 10 CONTINUE -C -C Quick return if possible. -C - NH = N - ILO + 1 - IF ( NH.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Determine the block size. -C - NB = UE01MD( 1, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) - NBMIN = 2 - WRKOPT = N - IF ( NB.GT.1 .AND. NB.LT.NH ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( NB, UE01MD( 3, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) - $ ) - IF ( NX.LT.NH ) THEN -C -C Check whether workspace is large enough for blocked code. -C - WRKOPT = 16*N*NB + 5*NB - IF ( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace available. Determine minimum value -C of NB, and reduce NB. -C - NBMIN = MAX( 2, UE01MD( 2, 'MB04TB', TRANA // TRANB, N, - $ ILO, -1 ) ) - NB = LDWORK / ( 16*N + 5 ) - END IF - END IF - END IF -C - NNB = N*NB - PYB = 1 - PYQ = PYB + 2*NNB - PYA = PYQ + 2*NNB - PYG = PYA + 2*NNB - PXQ = PYG + 2*NNB - PXA = PXQ + 2*NNB - PXG = PXA + 2*NNB - PXB = PXG + 2*NNB - PDW = PXB + 2*NNB -C - IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN -C -C Use unblocked code. -C - I = ILO -C - ELSE IF ( LTRA .AND. LTRB ) THEN - DO 20 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, - $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(i+1+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, - $ ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, - $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, - $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, - $ A(I+IB+1,1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, B(I+IB+1,I), LDB, DWORK(PYA+NIB), N, ONE, - $ A(I+IB+1,1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(1:n,i+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, - $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, - $ ONE, B(1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB+1, IB, - $ ONE, DWORK(PXB+NIB), N, A(I,I+IB), LDA, ONE, - $ B(1,I+IB), LDB ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - 20 CONTINUE -C - ELSE IF ( LTRA ) THEN - DO 30 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, - $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(i+1+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, - $ ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, - $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, - $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, - $ A(I+IB+1,1), LDA ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, - $ ONE, B(I,I+IB+1), LDB, DWORK(PYA+NIB), N, ONE, - $ A(I+IB+1,1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(i+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, - $ ONE, B(I+IB,1), LDB ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I,I+IB), LDA, DWORK(PXB+NIB), N, ONE, - $ B(I+IB,1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), - $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) - 30 CONTINUE -C - ELSE IF ( LTRB ) THEN - DO 40 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, - $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(1:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, - $ A(1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA+NIB), N, B(I+IB+1,I), LDB, ONE, - $ A(1,I+IB+1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No Transpose', 'Transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(1:n,i+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, - $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, - $ ONE, B(1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, IB, - $ ONE, DWORK(PXB+NIB), N, A(I+IB,I), LDA, ONE, - $ B(1,I+IB), LDB ) - CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, - $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, - $ ONE, B(I+IB+1,I+IB), LDB ) - 40 CONTINUE -C - ELSE - DO 50 I = ILO, N-NX-1, NB - IB = MIN( NB, N-I ) - NIB = N*IB -C -C Reduce rows and columns i:i+nb-1 to symplectic URV form and -C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which -C are needed to update the unreduced parts of the matrices. -C - CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, - $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), - $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, - $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, - $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), - $ TAUR(I), DWORK(PDW) ) -C -C Update the submatrix A(1:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, - $ ONE, A(I+IB,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, - $ A(1,I+IB+1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYA+NIB), N, B(I,I+IB+1), LDB, ONE, - $ A(1,I+IB+1), LDA ) -C -C Update the submatrix Q(i+ib:n,i+1+ib:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, - $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, - $ ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, - $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) -C -C Update the matrix G. -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, - $ G(I+IB,1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, - $ G(1,I+IB+1), LDG ) - CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, - $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, - $ G(1,I+IB+1), LDG ) -C -C Update the submatrix B(i+ib:n,1:n). -C - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, - $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, - $ ONE, B(I+IB,1), LDB ) - CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, - $ ONE, A(I+IB,I), LDA, DWORK(PXB+NIB), N, ONE, - $ B(I+IB,1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), - $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) - CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, - $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, - $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) - 50 CONTINUE - END IF -C -C Unblocked code to reduce the rest of the matrices. -C - CALL MB04TS( TRANA, TRANB, N, I, A, LDA, B, LDB, G, LDG, Q, LDQ, - $ CSL, CSR, TAUL, TAUR, DWORK, LDWORK, IERR ) -C - DWORK(1) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04TB *** - END diff --git a/slycot/src/MB04TS.f b/slycot/src/MB04TS.f deleted file mode 100644 index 66f085f5..00000000 --- a/slycot/src/MB04TS.f +++ /dev/null @@ -1,519 +0,0 @@ - SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, - $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a symplectic URV (SURV) decomposition of a real -C 2N-by-2N matrix H: -C -C [ op(A) G ] T [ op(R11) R12 ] T -C H = [ ] = U R V = U * [ ] * V , -C [ Q op(B) ] [ 0 op(R22) ] -C -C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real -C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower -C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic -C matrices. Unblocked version. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op( A ) as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C TRANB CHARACTER*1 -C Specifies the form of op( B ) as follows: -C = 'N': op( B ) = B; -C = 'T': op( B ) = B'; -C = 'C': op( B ) = B'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C ILO (input) INTEGER -C It is assumed that op(A) is already upper triangular, -C op(B) is lower triangular and Q is zero in rows and -C columns 1:ILO-1. ILO is normally set by a previous call -C to MB04DD; otherwise it should be set to 1. -C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the triangular matrix R11, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix B. -C On exit, the leading N-by-N part of this array contains -C the Hessenberg matrix R22, and in the zero part -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix G. -C On exit, the leading N-by-N part of this array contains -C the matrix R12. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix Q. -C On exit, the leading N-by-N part of this array contains -C information about the elementary reflectors used to -C compute the SURV decomposition. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDG >= MAX(1,N). -C -C CSL (output) DOUBLE PRECISION array, dimension (2N) -C On exit, the first 2N elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the left-hand side used to compute the SURV -C decomposition. -C -C CSR (output) DOUBLE PRECISION array, dimension (2N-2) -C On exit, the first 2N-2 elements of this array contain the -C cosines and sines of the symplectic Givens rotations -C applied from the right-hand side used to compute the SURV -C decomposition. -C -C TAUL (output) DOUBLE PRECISION array, dimension (N) -C On exit, the first N elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied from the left-hand side. -C -C TAUR (output) DOUBLE PRECISION array, dimension (N-1) -C On exit, the first N-1 elements of this array contain the -C scalar factors of some of the elementary reflectors -C applied from the right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -16, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrices U and V are represented as products of symplectic -C reflectors and Givens rotators -C -C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) -C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) -C .... -C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), -C -C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) -C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) -C .... -C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). -C -C Each HU(i) has the form -C -C HU(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in -C Q(i+1:n,i), and tau in Q(i,i). -C -C Each FU(i) has the form -C -C FU(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in -C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The -C scalar nu is stored in TAUL(i). -C -C Each GU(i) is a Givens rotator acting on rows i and n+i, -C where the cosine is stored in CSL(2*i-1) and the sine in -C CSL(2*i). -C -C Each HV(i) has the form -C -C HV(i) = I - tau * v * v' -C -C where tau is a real scalar, and v is a real vector with -C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in -C Q(i,i+2:n), and tau in Q(i,i+1). -C -C Each FV(i) has the form -C -C FV(i) = I - nu * w * w' -C -C where nu is a real scalar, and w is a real vector with -C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in -C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. -C The scalar nu is stored in TAUR(i). -C -C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, -C where the cosine is stored in CSR(2*i-1) and the sine in -C CSR(2*i). -C -C NUMERICAL ASPECTS -C -C The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point -C operations and is numerically backward stable. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUV). -C -C KEYWORDS -C -C Elementary matrix operations, Matrix decompositions, Hamiltonian -C matrix -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), - $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) -C .. Local Scalars .. - LOGICAL LTRA, LTRB - INTEGER I - DOUBLE PRECISION ALPHA, C, NU, S, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) - LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) - IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) 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 ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN - DWORK(1) = DBLE( MAX( 1, N ) ) - INFO = -18 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04TS', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - DO 10 I = ILO, N - ALPHA = Q(I,I) - IF ( I.LT.N ) THEN -C -C Generate elementary reflector HU(i) to annihilate Q(i+1:n,i) -C - CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, NU ) -C -C Apply HU(i) from the left. -C - Q(I,I) = ONE - CALL DLARF( 'Left', N-I+1, N-I, Q(I,I), 1, NU, Q(I,I+1), - $ LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Right', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), - $ LDA, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), - $ LDA, DWORK ) - END IF - IF ( LTRB ) THEN - CALL DLARF( 'Right', N, N-I+1, Q(I,I), 1, NU, B(1,I), - $ LDB, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, B(I,1), LDB, - $ DWORK ) - END IF - CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, G(I,1), LDG, - $ DWORK ) - Q(I,I) = NU - ELSE - Q(I,I) = ZERO - END IF -C -C Generate symplectic Givens rotator GU(i) to annihilate Q(i,i). -C - TEMP = A(I,I) - CALL DLARTG( TEMP, ALPHA, C, S, A(I,I) ) -C -C Apply G(i) from the left. -C - IF ( LTRA ) THEN - CALL DROT( N-I, A(I+1,I), 1, Q(I,I+1), LDQ, C, S ) - ELSE - CALL DROT( N-I, A(I,I+1), LDA, Q(I,I+1), LDQ, C, S ) - END IF - IF ( LTRB ) THEN - CALL DROT( N, G(I,1), LDG, B(1,I), 1, C, S ) - ELSE - CALL DROT( N, G(I,1), LDG, B(I,1), LDB, C, S ) - END IF - CSL(2*I-1) = C - CSL(2*I) = S -C - IF ( I.LT.N ) THEN - IF ( LTRA ) THEN -C -C Generate elementary reflector FU(i) to annihilate -C A(i,i+1:n). -C - CALL DLARFG( N-I+1, A(I,I), A(I,I+1), LDA, TAUL(I) ) -C -C Apply FU(i) from the left. -C - TEMP = A(I,I) - A(I,I) = ONE - CALL DLARF( 'Right', N-I, N-I+1, A(I,I), LDA, TAUL(I), - $ A(I+1,I), LDA, DWORK ) - CALL DLARF( 'Left', N-I+1, N-I, A(I,I), LDA, TAUL(I), - $ Q(I,I+1), LDQ, DWORK ) - IF ( LTRB ) THEN - CALL DLARF( 'Right', N, N-I+1, A(I,I), LDA, TAUL(I), - $ B(1,I), LDB, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), - $ B(I,1), LDB, DWORK ) - END IF - CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), - $ G(I,1), LDG, DWORK ) - A(I,I) = TEMP - ELSE -C -C Generate elementary reflector FU(i) to annihilate -C A(i+1:n,i). -C - CALL DLARFG( N-I+1, A(I,I), A(I+1,I), 1, TAUL(I) ) -C -C Apply FU(i) from the left. -C - TEMP = A(I,I) - A(I,I) = ONE - CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), - $ A(I,I+1), LDA, DWORK ) - CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), - $ Q(I,I+1), LDQ, DWORK ) - IF ( LTRB ) THEN - CALL DLARF( 'Right', N, N-I+1, A(I,I), 1, TAUL(I), - $ B(1,I), LDB, DWORK ) - ELSE - CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), - $ B(I,1), LDB, DWORK ) - END IF - CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), G(I,1), - $ LDG, DWORK ) - A(I,I) = TEMP - END IF - ELSE - TAUL(I) = ZERO - END IF - IF ( I.LT.N ) - $ ALPHA = Q(I,I+1) - IF ( I.LT.N-1 ) THEN -C -C Generate elementary reflector HV(i) to annihilate Q(i,i+2:n) -C - CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, NU ) -C -C Apply HV(i) from the right. -C - Q(I,I+1) = ONE - CALL DLARF( 'Right', N-I, N-I, Q(I,I+1), LDQ, NU, - $ Q(I+1,I+1), LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Left', N-I, N, Q(I,I+1), LDQ, NU, - $ A(I+1,1), LDA, DWORK ) - ELSE - CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, - $ A(1,I+1), LDA, DWORK ) - END IF - IF ( LTRB ) THEN - CALL DLARF( 'Left', N-I, N-I+1, Q(I,I+1), LDQ, NU, - $ B(I+1,I), LDB, DWORK ) - ELSE - CALL DLARF( 'Right', N-I+1, N-I, Q(I,I+1), LDQ, NU, - $ B(I,I+1), LDB, DWORK ) - END IF - CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, - $ G(1,I+1), LDG, DWORK ) - Q(I,I+1) = NU - ELSE IF ( I.LT.N ) THEN - Q(I,I+1) = ZERO - END IF - IF ( I.LT.N ) THEN -C -C Generate symplectic Givens rotator GV(i) to annihilate -C Q(i,i+1). -C - IF ( LTRB ) THEN - TEMP = B(I+1,I) - CALL DLARTG( TEMP, ALPHA, C, S, B(I+1,I) ) - S = -S - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), LDB, C, S ) - ELSE - TEMP = B(I,I+1) - CALL DLARTG( TEMP, ALPHA, C, S, B(I,I+1) ) - S = -S - CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), 1, C, S ) - END IF - IF ( LTRA ) THEN - CALL DROT( N, A(I+1,1), LDA, G(1,I+1), 1, C, S ) - ELSE - CALL DROT( N, A(1,I+1), 1, G(1,I+1), 1, C, S ) - END IF - CSR(2*I-1) = C - CSR(2*I) = S - END IF - IF ( I.LT.N-1 ) THEN - IF ( LTRB ) THEN -C -C Generate elementary reflector FV(i) to annihilate -C B(i+2:n,i). -C - CALL DLARFG( N-I, B(I+1,I), B(I+2,I), 1, TAUR(I) ) -C -C Apply FV(i) from the right. -C - TEMP = B(I+1,I) - B(I+1,I) = ONE - CALL DLARF( 'Left', N-I, N-I, B(I+1,I), 1, TAUR(I), - $ B(I+1,I+1), LDB, DWORK ) - CALL DLARF( 'Right', N-I, N-I, B(I+1,I), 1, TAUR(I), - $ Q(I+1,I+1), LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Left', N-I, N, B(I+1,I), 1, - $ TAUR(I), A(I+1,1), LDA, DWORK ) - ELSE - CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, - $ TAUR(I), A(1,I+1), LDA, DWORK ) - END IF - CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, TAUR(I), - $ G(1,I+1), LDG, DWORK ) - B(I+1,I) = TEMP - ELSE -C -C Generate elementary reflector FV(i) to annihilate -C B(i,i+2:n). -C - CALL DLARFG( N-I, B(I,I+1), B(I,I+2), LDB, TAUR(I) ) -C -C Apply FV(i) from the right. -C - TEMP = B(I,I+1) - B(I,I+1) = ONE - CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), - $ B(I+1,I+1), LDB, DWORK ) - CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), - $ Q(I+1,I+1), LDQ, DWORK ) - IF ( LTRA ) THEN - CALL DLARF( 'Left', N-I, N, B(I,I+1), LDB, TAUR(I), - $ A(I+1,1), LDA, DWORK ) - ELSE - CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, - $ TAUR(I), A(1,I+1), LDA, DWORK ) - END IF - CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, TAUR(I), - $ G(1,I+1), LDG, DWORK ) - B(I,I+1) = TEMP - END IF - ELSE IF ( I.LT.N ) THEN - TAUR(I) = ZERO - END IF - 10 CONTINUE - DWORK(1) = DBLE( MAX( 1, N ) ) - RETURN -C *** Last line of MB04TS *** - END diff --git a/slycot/src/MB04TT.f b/slycot/src/MB04TT.f deleted file mode 100644 index 7d8e207f..00000000 --- a/slycot/src/MB04TT.f +++ /dev/null @@ -1,413 +0,0 @@ - SUBROUTINE MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANK, TOL, - $ IWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Let A and E be M-by-N matrices with E in column echelon form. -C Let AA and EE be the following submatrices of A and E: -C AA := A(IFIRA : M ; IFICA : N) -C EE := E(IFIRA : M ; IFICA : N). -C Let Aj and Ej be the following submatrices of AA and EE: -C Aj := A(IFIRA : M ; IFICA : IFICA + NCA - 1) and -C Ej := E(IFIRA : M ; IFICA + NCA : N). -C -C To transform (AA,EE) such that Aj is row compressed while keeping -C matrix Ej in column echelon form (which may be different from the -C form on entry). -C In fact the routine performs the j-th step of Algorithm 3.2.1 in -C [1]. Furthermore, it determines the rank RANK of the submatrix Ej, -C which is equal to the number of corner points in submatrix Ej. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C M is the number of rows of the matrices A, E and Q. -C M >= 0. -C -C N (input) INTEGER -C N is the number of columns of the matrices A, E and Z. -C N >= 0. -C -C IFIRA (input) INTEGER -C IFIRA is the first row index of the submatrices Aj and Ej -C in the matrices A and E, respectively. -C -C IFICA (input) INTEGER -C IFICA and IFICA + NCA are the first column indices of the -C submatrices Aj and Ej in the matrices A and E, -C respectively. -C -C NCA (input) INTEGER -C NCA is the number of columns of the submatrix Aj in A. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, A(IFIRA : M ; IFICA : IFICA + NCA - 1) contains -C the matrix Aj. -C On exit, it contains the matrix A with AA that has been -C row compressed while keeping EE in column echelon form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, E(IFIRA : M ; IFICA + NCA : N) contains the -C matrix Ej which is in column echelon form. -C On exit, it contains the transformed matrix EE which is -C kept in column echelon form. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C ISTAIR (input/output) INTEGER array, dimension (M) -C On entry, ISTAIR contains information on the column -C echelon form of the input matrix E as follows: -C ISTAIR(i) = +j: the boundary element E(i,j) is a corner -C point; -C -j: the boundary element E(i,j) is not a -C corner point (where i=1,...,M). -C On exit, ISTAIR contains the same information for the -C transformed matrix E. -C -C RANK (output) INTEGER -C Numerical rank of the submatrix Aj in A (based on TOL). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance used when considering matrix elements -C to be zero. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MB04FZ by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C June 13, 1997, V. Sima. -C November 24, 1997, A. Varga: array starting point A(KK,LL) -C correctly set when calling DLASET. -C -C KEYWORDS -C -C Echelon form, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER IFICA, IFIRA, LDA, LDE, LDQ, LDZ, M, N, NCA, - $ RANK - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER ISTAIR(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LZERO - INTEGER I, IFICA1, IFIRA1, II, IP, IST1, IST2, ISTPVT, - $ ITYPE, JC1, JC2, JPVT, K, KK, L, LL, LSAV, MJ, - $ MK1, MXRANK, NJ - DOUBLE PRECISION BMX, BMXNRM, EIJPVT, SC, SS -C .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -C .. External Subroutines .. - EXTERNAL DLAPMT, DLASET, DROT, DROTG, DSWAP -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN -C .. Executable Statements .. -C - RANK = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C Initialisation. -C -C NJ = number of columns in submatrix Aj, -C MJ = number of rows in submatrices Aj and Ej. -C - NJ = NCA - MJ = M + 1 - IFIRA - IFIRA1 = IFIRA - 1 - IFICA1 = IFICA - 1 -C - DO 20 I = 1, NJ - IWORK(I) = I - 20 CONTINUE -C - K = 1 - LZERO = .FALSE. - RANK = MIN( NJ, MJ ) - MXRANK = RANK -C -C WHILE ( K <= MXRANK ) and ( LZERO = FALSE ) DO - 40 IF ( ( K.LE.MXRANK ) .AND. ( .NOT.LZERO ) ) THEN -C -C Determine column in Aj with largest max-norm. -C - BMXNRM = ZERO - LSAV = K - KK = IFIRA1 + K -C - DO 60 L = K, NJ -C -C IDAMAX call gives the relative index in column L of Aj where -C max element is found. -C Note: the first element in column L is in row K of -C matrix Aj. -C - LL = IFICA1 + L - BMX = ABS( A(IDAMAX( MJ-K+1, A(KK,LL), 1 )+KK-1,LL) ) - IF ( BMX.GT.BMXNRM ) THEN - BMXNRM = BMX - LSAV = L - END IF - 60 CONTINUE -C - LL = IFICA1 + K - IF ( BMXNRM.LT.TOL ) THEN -C -C Set submatrix of Aj to zero. -C - CALL DLASET( 'Full', MJ-K+1, NJ-K+1, ZERO, ZERO, A(KK,LL), - $ LDA ) - LZERO = .TRUE. - RANK = K - 1 - ELSE -C -C Check whether columns have to be interchanged. -C - IF ( LSAV.NE.K ) THEN -C -C Interchange the columns in A which correspond to the -C columns lsav and k in Aj. Store the permutation in IWORK. -C - CALL DSWAP( M, A(1,LL), 1, A(1,IFICA1+LSAV), 1 ) - IP = IWORK(LSAV) - IWORK(LSAV) = IWORK(K) - IWORK(K) = IP - END IF -C - K = K + 1 - MK1 = N - LL + 1 -C - DO 80 I = MJ, K, -1 -C -C II = absolute row number in A corresponding to row i in -C Aj. -C - II = IFIRA1 + I -C -C Construct Givens transformation to annihilate Aj(i,k). -C Apply the row transformation to whole matrix A -C (NOT only to Aj). -C Update row transformation matrix Q, if needed. -C - CALL DROTG( A(II-1,LL), A(II,LL), SC, SS ) - CALL DROT( MK1-1, A(II-1,LL+1), LDA, A(II,LL+1), LDA, SC, - $ SS ) - A(II,LL) = ZERO - IF ( UPDATQ ) - $ CALL DROT( M, Q(1,II-1), 1, Q(1,II), 1, SC, SS ) -C -C Determine boundary type of matrix E at rows II-1 and II. -C - IST1 = ISTAIR(II-1) - IST2 = ISTAIR(II) - IF ( ( IST1*IST2 ).GT.0 ) THEN - IF ( IST1.GT.0 ) THEN -C -C boundary form = (* x) -C (0 *) -C - ITYPE = 1 - ELSE -C -C boundary form = (x x) -C (x x) -C - ITYPE = 3 - END IF - ELSE - IF ( IST1.LT.0 ) THEN -C -C boundary form = (x x) -C (* x) -C - ITYPE = 2 - ELSE -C -C boundary form = (* x) -C (0 x) -C - ITYPE = 4 - END IF - END IF -C -C Apply row transformation also to matrix E. -C -C JC1 = absolute number of the column in E in which stair -C element of row i-1 of Ej is present. -C JC2 = absolute number of the column in E in which stair -C element of row i of Ej is present. -C -C Note: JC1 < JC2 if ITYPE = 1. -C JC1 = JC2 if ITYPE = 2, 3 or 4. -C - JC1 = ABS( IST1 ) - JC2 = ABS( IST2 ) - JPVT = MIN( JC1, JC2 ) -C - CALL DROT( N-JPVT+1, E(II-1,JPVT), LDE, E(II,JPVT), LDE, - $ SC, SS ) - EIJPVT = E(II,JPVT) -C - IF ( ITYPE.EQ.1 ) THEN -C -C Construct column Givens transformation to annihilate -C E(ii,jpvt). -C Apply column Givens transformation to matrix E -C (NOT only to Ej). -C - CALL DROTG( E(II,JPVT+1), E(II,JPVT), SC, SS ) - CALL DROT( II-1, E(1,JPVT+1), 1, E(1,JPVT), 1, SC, - $ SS ) - E(II,JPVT) = ZERO -C -C Apply this transformation also to matrix A -C (NOT only to Aj). -C Update column transformation matrix Z, if needed. -C - CALL DROT( M, A(1,JPVT+1), 1, A(1,JPVT), 1, SC, SS ) - IF ( UPDATZ ) CALL DROT( N, Z(1,JPVT+1), 1, Z(1,JPVT), - $ 1, SC, SS ) -C - ELSE IF ( ITYPE.EQ.2 ) THEN - IF ( ABS( EIJPVT ).LT.TOL ) THEN -C -C (x x) (* x) -C Boundary form has been changed from (* x) to (0 x). -C - ISTPVT = ISTAIR(II) - ISTAIR(II-1) = ISTPVT - ISTAIR(II) = -(ISTPVT+1 ) - E(II,JPVT) = ZERO - END IF -C - ELSE IF ( ITYPE.EQ.4 ) THEN - IF ( ABS( EIJPVT ).GE.TOL ) THEN -C -C (* x) (x x) -C Boundary form has been changed from (0 x) to (* x). -C - ISTPVT = ISTAIR(II-1) - ISTAIR(II-1) = -ISTPVT - ISTAIR(II) = ISTPVT - END IF - END IF - 80 CONTINUE -C - END IF - GO TO 40 - END IF -C END WHILE 40 -C -C Permute columns of Aj to original order. -C - CALL DLAPMT( .FALSE., IFIRA1+RANK, NJ, A(1,IFICA), LDA, IWORK ) -C - RETURN -C *** Last line of MB04TT *** - END diff --git a/slycot/src/MB04TU.f b/slycot/src/MB04TU.f deleted file mode 100644 index 74e81bfe..00000000 --- a/slycot/src/MB04TU.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the Givens transformation, defined by C (cos) and S -C (sin), and interchange the vectors involved, i.e. -C -C |X(i)| | 0 1 | | C S | |X(i)| -C | | := | | x | | x | |, i = 1,...N. -C |Y(i)| | 1 0 | |-S C | |Y(i)| -C -C REMARK. This routine is a modification of DROT from BLAS. -C This routine is called only by the SLICOT routines MB04TX -C and MB04VX. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FU by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C January 26, 1998. -C -C KEYWORDS -C -C Othogonal transformation. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INCX, INCY, N - DOUBLE PRECISION C, S -C .. Array Arguments .. - DOUBLE PRECISION X(*), Y(*) -C .. Local Scalars .. - DOUBLE PRECISION DTEMP - INTEGER I, IX, IY -C .. Executable Statements .. -C - IF ( N.LE.0 ) RETURN - IF ( ( INCX.NE.1 ) .OR. ( INCY.NE.1 ) ) THEN -C -C Code for unequal increments or equal increments not equal to 1. -C - IX = 1 - IY = 1 - IF ( INCX.LT.0 ) IX = (-N+1)*INCX + 1 - IF ( INCY.LT.0 ) IY = (-N+1)*INCY + 1 -C - DO 20 I = 1, N - DTEMP = C*Y(IY) - S*X(IX) - Y(IY) = C*X(IX) + S*Y(IY) - X(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - 20 CONTINUE -C - ELSE -C -C Code for both increments equal to 1. -C - DO 40 I = 1, N - DTEMP = C*Y(I) - S*X(I) - Y(I) = C*X(I) + S*Y(I) - X(I) = DTEMP - 40 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB04TU *** - END diff --git a/slycot/src/MB04TV.f b/slycot/src/MB04TV.f deleted file mode 100644 index c3fa37f2..00000000 --- a/slycot/src/MB04TV.f +++ /dev/null @@ -1,171 +0,0 @@ - SUBROUTINE MB04TV( UPDATZ, N, NRA, NCA, IFIRA, IFICA, A, LDA, E, - $ LDE, Z, LDZ ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a submatrix A(k) of A to upper triangular form by column -C Givens rotations only. -C Here A(k) = A(IFIRA:ma,IFICA:na) where ma = IFIRA - 1 + NRA, -C na = IFICA - 1 + NCA. -C Matrix A(k) is assumed to have full row rank on entry. Hence, no -C pivoting is done during the reduction process. See Algorithm 2.3.1 -C and Remark 2.3.4 in [1]. -C The constructed column transformations are also applied to matrix -C E(k) = E(1:IFIRA-1,IFICA:na). -C Note that in E columns are transformed with the same column -C indices as in A, but with row indices different from those in A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NRA (input) INTEGER -C Number of rows in A to be transformed. 0 <= NRA <= LDA. -C -C NCA (input) INTEGER -C Number of columns in A to be transformed. 0 <= NCA <= N. -C -C IFIRA (input) INTEGER -C Index of the first row in A to be transformed. -C -C IFICA (input) INTEGER -C Index of the first column in A to be transformed. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the elements of A(IFIRA:ma,IFICA:na) must -C contain the submatrix A(k) of full row rank to be reduced -C to upper triangular form. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NRA). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the elements of E(1:IFIRA-1,IFICA:na) must -C contain the submatrix E(k). -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,IFIRA-1). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FV by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATZ - INTEGER IFICA, IFIRA, LDA, LDE, LDZ, N, NCA, NRA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I, IFIRA1, J, JPVT - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROT, DROTG -C .. Executable Statements .. -C - IF ( N.LE.0 .OR. NRA.LE.0 .OR. NCA.LE.0 ) - $ RETURN - IFIRA1 = IFIRA - 1 - JPVT = IFICA + NCA -C - DO 40 I = IFIRA1 + NRA, IFIRA, -1 - JPVT = JPVT - 1 -C - DO 20 J = JPVT - 1, IFICA, -1 -C -C Determine the Givens transformation on columns j and jpvt -C to annihilate A(i,j). Apply the transformation to these -C columns from rows 1 up to i. -C Apply the transformation also to the E-matrix (from rows 1 -C up to ifira1). -C Update column transformation matrix Z, if needed. -C - CALL DROTG( A(I,JPVT), A(I,J), SC, SS ) - CALL DROT( I-1, A(1,JPVT), 1, A(1,J), 1, SC, SS ) - A(I,J) = ZERO - CALL DROT( IFIRA1, E(1,JPVT), 1, E(1,J), 1, SC, SS ) - IF( UPDATZ ) CALL DROT( N, Z(1,JPVT), 1, Z(1,J), 1, SC, SS ) - 20 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of MB04TV *** - END diff --git a/slycot/src/MB04TW.f b/slycot/src/MB04TW.f deleted file mode 100644 index 81854d9f..00000000 --- a/slycot/src/MB04TW.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE MB04TW( UPDATQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA, A, - $ LDA, E, LDE, Q, LDQ ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a submatrix E(k) of E to upper triangular form by row -C Givens rotations only. -C Here E(k) = E(IFIRE:me,IFICE:ne), where me = IFIRE - 1 + NRE, -C ne = IFICE - 1 + NCE. -C Matrix E(k) is assumed to have full column rank on entry. Hence, -C no pivoting is done during the reduction process. See Algorithm -C 2.3.1 and Remark 2.3.4 in [1]. -C The constructed row transformations are also applied to matrix -C A(k) = A(IFIRE:me,IFICA:N). -C Note that in A(k) rows are transformed with the same row indices -C as in E but with column indices different from those in E. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows of A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NRE (input) INTEGER -C Number of rows in E to be transformed. 0 <= NRE <= M. -C -C NCE (input) INTEGER -C Number of columns in E to be transformed. 0 <= NCE <= N. -C -C IFIRE (input) INTEGER -C Index of first row in E to be transformed. -C -C IFICE (input) INTEGER -C Index of first column in E to be transformed. -C -C IFICA (input) INTEGER -C Index of first column in A to be transformed. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the submatrix A(k). -C On exit, it contains the transformed matrix A(k). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the submatrix E(k) of full -C column rank to be reduced to upper triangular form. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FW by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C June 13, 1997. V. Sima. -C December 30, 1997. A. Varga: Corrected column range to apply -C transformations on the matrix E. -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ - INTEGER IFICA, IFICE, IFIRE, LDA, LDE, LDQ, M, N, NCE, - $ NRE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*) -C .. Local Scalars .. - INTEGER I, IPVT, J - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROT, DROTG -C .. Executable Statements .. -C - IF ( M.LE.0 .OR. N.LE.0 .OR. NRE.LE.0 .OR. NCE.LE.0 ) - $ RETURN -C - IPVT = IFIRE - 1 -C - DO 40 J = IFICE, IFICE + NCE - 1 - IPVT = IPVT + 1 -C - DO 20 I = IPVT + 1, IFIRE + NRE - 1 -C -C Determine the Givens transformation on rows i and ipvt -C to annihilate E(i,j). -C Apply the transformation to these rows (in whole E-matrix) -C from columns j up to n . -C Apply the transformations also to the A-matrix -C (from columns ifica up to n). -C Update the row transformation matrix Q, if needed. -C - CALL DROTG( E(IPVT,J), E(I,J), SC, SS ) - CALL DROT( N-J, E(IPVT,J+1), LDE, E(I,J+1), LDE, SC, SS ) - E(I,J) = ZERO - CALL DROT( N-IFICA+1, A(IPVT,IFICA), LDA, A(I,IFICA), LDA, - $ SC, SS ) - IF( UPDATQ ) - $ CALL DROT( M, Q(1,IPVT), 1, Q(1,I), 1, SC, SS ) - 20 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of MB04TW *** - END diff --git a/slycot/src/MB04TX.f b/slycot/src/MB04TX.f deleted file mode 100644 index ff4c3712..00000000 --- a/slycot/src/MB04TX.f +++ /dev/null @@ -1,394 +0,0 @@ - SUBROUTINE MB04TX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in -C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. -C -C On entry, it is assumed that the M-by-N matrices A and E have -C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to -C the pencil s*E - A as described in [1], i.e. -C -C | s*E(eps,inf)-A(eps,inf) | X | -C Q'(s*E - A)Z = |-------------------------|-------------| -C | 0 | s*E(r)-A(r) | -C -C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. -C This pencil contains all Kronecker column indices and infinite -C elementary divisors of the pencil s*E - A. -C The pencil s*E(r)-A(r) contains all Kronecker row indices and -C finite elementary divisors of s*E - A. -C Furthermore, the submatrices having full row and column rank in -C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be -C triangularized. -C -C On exit, the result then is -C -C Q'(s*E - A)Z = -C -C | s*E(eps)-A(eps) | X | X | -C |-----------------|-----------------|-------------| -C | 0 | s*E(inf)-A(inf) | X | -C |===================================|=============| -C | | | -C | 0 | s*E(r)-A(r) | -C -C Note that the pencil s*E(r)-A(r) is not reduced further. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows of A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NBLCKS (input/output) INTEGER -C On entry, the number of submatrices having full row rank -C (possibly zero) in A(eps,inf). -C On exit, the input value has been reduced by one, if the -C last submatrix is a 0-by-0 (empty) matrix. -C -C INUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps)-A(eps). -C -C IMUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps)-A(eps). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the matrix A to be reduced. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the matrix E to be reduced. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C MNEI (output) INTEGER array, dimension (4) -C MNEI(1) = MEPS = row dimension of s*E(eps)-A(eps), -C MNEI(2) = NEPS = column dimension of s*E(eps)-A(eps), -C MNEI(3) = MINF = row dimension of s*E(inf)-A(inf), -C MNEI(4) = NINF = column dimension of s*E(inf)-A(inf). -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FX by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C June 13, 1997, V. Sima. -C November 24, 1997, A. Varga: initialization of MNEI to 0, instead -C of ZERO. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, orthogonal -C transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*), MNEI(4) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER CA, CE, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, - $ MINF, MUK, MUKP1, MUP, MUP1, NEPS, NINF, NUK, - $ NUP, RA, RJE, SK1P1, TK1P1, TP1 - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROTG, MB04TU -C .. Executable Statements .. -C - MNEI(1) = 0 - MNEI(2) = 0 - MNEI(3) = 0 - MNEI(4) = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C Initialisation. -C - ISMUK = 0 - ISNUK = 0 -C - DO 20 K = 1, NBLCKS - ISMUK = ISMUK + IMUK(K) - ISNUK = ISNUK + INUK(K) - 20 CONTINUE -C -C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). -C MEPS = Sum(k=1,...,nblcks) NU(k), -C NEPS = Sum(k=1,...,nblcks) MU(k). -C MINF, NINF are the dimensions of the pencil s*E(inf)-A(inf). -C - MEPS = ISNUK - NEPS = ISMUK - MINF = 0 - NINF = 0 -C -C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. -C - MUKP1 = 0 -C - DO 120 K = NBLCKS, 1, -1 - NUK = INUK(K) - MUK = IMUK(K) -C -C Reduce submatrix E(k,k+1) to square matrix. -C NOTE that always NU(k) >= MU(k+1) >= 0. -C -C WHILE ( NU(k) > MU(k+1) ) DO - 40 IF ( NUK.GT.MUKP1 ) THEN -C -C sk1p1 = sum(i=k+1,...,p-1) NU(i) -C tk1p1 = sum(i=k+1,...,p-1) MU(i) -C ismuk = sum(i=1,...,k) MU(i) -C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. -C - SK1P1 = 0 - TK1P1 = 0 -C - DO 100 IP = K + 1, NBLCKS -C -C Annihilate the elements originally present in the last -C row of E(k,p+1) and A(k,p). -C Start annihilating the first MU(p) - MU(p+1) elements by -C applying column Givens rotations plus interchanging -C elements. -C Use original bottom diagonal element of A(k,k) as pivot. -C Start position of pivot in A = (ra,ca). -C - TP1 = ISMUK + TK1P1 - RA = ISNUK + SK1P1 - CA = TP1 -C - MUP = IMUK(IP) - NUP = INUK(IP) - MUP1 = NUP -C - DO 60 CJA = CA, CA + MUP - NUP - 1 -C -C CJA = current column index of pivot in A. -C - CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) -C -C Apply transformations to A- and E-matrix. -C Interchange columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RA,CJA+1) = A(RA,CJA) - A(RA,CJA) = ZERO - CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 60 CONTINUE -C -C Annihilate the remaining elements originally present in -C the last row of E(k,p+1) and A(k,p) by alternatingly -C applying row and column rotations plus interchanging -C elements. -C Use diagonal elements of E(p,p+1) and original bottom -C diagonal element of A(k,k) as pivots, respectively. -C (re,ce) and (ra,ca) are the starting positions of the -C pivots in E and A. -C - CE = TP1 + MUP - CA = CE - MUP1 - 1 -C - DO 80 RJE = RA + 1, RA + MUP1 -C -C (RJE,CJE) = current position pivot in E. -C - CJE = CE + 1 - CJA = CA + 1 -C -C Determine the row transformations. -C Apply these transformations to E- and A-matrix. -C Interchange the rows simultaneously. -C Update row transformation matrix Q, if needed. -C - CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) - CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), - $ LDE, SC, SS ) - E(RJE-1,CJE) = E(RJE,CJE) - E(RJE,CJE) = ZERO - CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), - $ LDA, SC, SS ) - IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, - $ Q(1,RJE-1), 1, SC, SS ) -C -C Determine the column transformations. -C Apply these transformations to A- and E-matrix. -C Interchange the columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) - CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RJE,CJA+1) = A(RJE,CJA) - A(RJE,CJA) = ZERO - CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 80 CONTINUE -C - SK1P1 = SK1P1 + NUP - TK1P1 = TK1P1 + MUP -C - 100 CONTINUE -C -C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last -C row and right most column. The row and column ignored -C belong to the pencil s*E(inf)-A(inf). -C Redefine blocks in new A and E. -C - MUK = MUK - 1 - NUK = NUK - 1 - ISMUK = ISMUK - 1 - ISNUK = ISNUK - 1 - MEPS = MEPS - 1 - NEPS = NEPS - 1 - MINF = MINF + 1 - NINF = NINF + 1 -C - GO TO 40 - END IF -C END WHILE 40 -C - IMUK(K) = MUK - INUK(K) = NUK -C -C Now submatrix E(k,k+1) is square. -C -C Consider next submatrix (k:=k-1). -C - ISNUK = ISNUK - NUK - ISMUK = ISMUK - MUK - MUKP1 = MUK - 120 CONTINUE -C -C If mu(NBLCKS) = 0, then the last submatrix counted in NBLCKS is -C a 0-by-0 (empty) matrix. This "matrix" must be removed. -C - IF ( IMUK(NBLCKS).EQ.0 ) NBLCKS = NBLCKS - 1 -C -C Store dimensions of the pencils s*E(eps)-A(eps) and -C s*E(inf)-A(inf) in array MNEI. -C - MNEI(1) = MEPS - MNEI(2) = NEPS - MNEI(3) = MINF - MNEI(4) = NINF -C - RETURN -C *** Last line of MB04TX *** - END diff --git a/slycot/src/MB04TY.f b/slycot/src/MB04TY.f deleted file mode 100644 index 1a146092..00000000 --- a/slycot/src/MB04TY.f +++ /dev/null @@ -1,241 +0,0 @@ - SUBROUTINE MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the triangularization of the submatrices having full -C row and column rank in the pencil s*E(eps,inf)-A(eps,inf) below -C -C | s*E(eps,inf)-A(eps,inf) | X | -C s*E - A = |-------------------------|-------------| , -C | 0 | s*E(r)-A(r) | -C -C using Algorithm 3.3.1 in [1]. -C On entry, it is assumed that the M-by-N matrices A and E have -C been transformed to generalized Schur form by unitary -C transformations (see Algorithm 3.2.1 in [1]), and that the pencil -C s*E(eps,inf)-A(eps,inf) is in staircase form. -C This pencil contains all Kronecker column indices and infinite -C elementary divisors of the pencil s*E - A. -C The pencil s*E(r)-A(r) contains all Kronecker row indices and -C finite elementary divisors of s*E - A. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows in A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns in A and E. N >= 0. -C -C NBLCKS (input) INTEGER -C Number of submatrices having full row rank (possibly zero) -C in A(eps,inf). -C -C INUK (input) INTEGER array, dimension (NBLCKS) -C The row dimensions nu(k) (k=1, 2, ..., NBLCKS) of the -C submatrices having full row rank in the pencil -C s*E(eps,inf)-A(eps,inf). -C -C IMUK (input) INTEGER array, dimension (NBLCKS) -C The column dimensions mu(k) (k=1, 2, ..., NBLCKS) of the -C submatrices having full column rank in the pencil. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the matrix A to be reduced. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the matrix E to be reduced. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if incorrect dimensions of a full column rank -C submatrix; -C = 2: if incorrect dimensions of a full row rank -C submatrix. -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB04FY by Th.G.J. Beelen, -C Philips Glass Eindhoven, Holland. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKS -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER IFICA, IFICE, IFIRE, ISMUK, ISNUK1, K, MUK, - $ MUKP1, NUK -C .. External Subroutines .. - EXTERNAL MB04TV, MB04TW -C .. Executable Statements .. -C - INFO = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C ISMUK = sum(i=1,...,k) MU(i), -C ISNUK1 = sum(i=1,...,k-1) NU(i). -C - ISMUK = 0 - ISNUK1 = 0 -C - DO 20 K = 1, NBLCKS - ISMUK = ISMUK + IMUK(K) - ISNUK1 = ISNUK1 + INUK(K) - 20 CONTINUE -C -C Note: ISNUK1 has not yet the correct value. -C - MUKP1 = 0 -C - DO 40 K = NBLCKS, 1, -1 - MUK = IMUK(K) - NUK = INUK(K) - ISNUK1 = ISNUK1 - NUK -C -C Determine left upper absolute co-ordinates of E(k) in E-matrix -C and of A(k) in A-matrix. -C - IFIRE = 1 + ISNUK1 - IFICE = 1 + ISMUK - IFICA = IFICE - MUK -C -C Reduce E(k) to upper triangular form using Givens -C transformations on rows only. Apply the same transformations -C to the rows of A(k). -C - IF ( MUKP1.GT.NUK ) THEN - INFO = 1 - RETURN - END IF -C - CALL MB04TW( UPDATQ, M, N, NUK, MUKP1, IFIRE, IFICE, IFICA, A, - $ LDA, E, LDE, Q, LDQ ) -C -C Reduce A(k) to upper triangular form using Givens -C transformations on columns only. Apply the same transformations -C to the columns in the E-matrix. -C - IF ( NUK.GT.MUK ) THEN - INFO = 2 - RETURN - END IF -C - CALL MB04TV( UPDATZ, N, NUK, MUK, IFIRE, IFICA, A, LDA, E, LDE, - $ Z, LDZ ) -C - ISMUK = ISMUK - MUK - MUKP1 = MUK - 40 CONTINUE -C - RETURN -C *** Last line of MB04TY *** - END diff --git a/slycot/src/MB04UD.f b/slycot/src/MB04UD.f deleted file mode 100644 index a5e2ba34..00000000 --- a/slycot/src/MB04UD.f +++ /dev/null @@ -1,375 +0,0 @@ - SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, - $ Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformations Q and Z such that the -C transformed pencil Q'(sE-A)Z has the E matrix in column echelon -C form, where E and A are M-by-N matrices. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBQ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Q the unitary row permutations, as follows: -C = 'N': Do not form Q; -C = 'I': Q is initialized to the unit matrix and the -C unitary row permutation matrix Q is returned; -C = 'U': The given matrix Q is updated by the unitary -C row permutations used in the reduction. -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the unitary column transformations, as follows: -C = 'N': Do not form Z; -C = 'I': Z is initialized to the unit matrix and the -C unitary transformation matrix Z is returned; -C = 'U': The given matrix Z is updated by the unitary -C transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the matrices A, E and the order of -C the matrix Q. M >= 0. -C -C N (input) INTEGER -C The number of columns in the matrices A, E and the order -C of the matrix Z. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the A matrix of the pencil sE-A. -C On exit, the leading M-by-N part of this array contains -C the unitary transformed matrix Q' * A * Z. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading M-by-N part of this array must -C contain the E matrix of the pencil sE-A, to be reduced to -C column echelon form. -C On exit, the leading M-by-N part of this array contains -C the unitary transformed matrix Q' * E * Z, which is in -C column echelon form. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if JOBQ = 'U', then the leading M-by-M part of -C this array must contain a given matrix Q (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading M-by-M part of this array contains the product of -C the input matrix Q and the row permutation matrix used to -C transform the rows of matrix E. -C On exit, if JOBQ = 'I', then the leading M-by-M part of -C this array contains the matrix of accumulated unitary -C row transformations performed. -C If JOBQ = 'N', the array Q is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDQ = 1 and -C declare this array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. If JOBQ = 'U' or -C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if JOBZ = 'U', then the leading N-by-N part of -C this array must contain a given matrix Z (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix Z and the column transformation matrix -C used to transform the columns of matrix E. -C On exit, if JOBZ = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated unitary -C column transformations performed. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'U' or -C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C RANKE (output) INTEGER -C The computed rank of the unitary transformed matrix E. -C -C ISTAIR (output) INTEGER array, dimension (M) -C This array contains information on the column echelon form -C of the unitary transformed matrix E. Specifically, -C ISTAIR(i) = +j if the first non-zero element E(i,j) -C is a corner point and -j otherwise, for i = 1,2,...,M. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance below which matrix elements are considered -C to be zero. If the user sets TOL to be less than (or -C equal to) zero then the tolerance is taken as -C EPS * MAX(ABS(E(I,J))), where EPS is the machine -C precision (see LAPACK Library routine DLAMCH), -C I = 1,2,...,M and J = 1,2,...,N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension MAX(M,N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an M-by-N matrix pencil sE-A with E not necessarily regular, -C the routine computes a unitary transformed pencil Q'(sE-A)Z such -C that the matrix Q' * E * Z is in column echelon form (trapezoidal -C form). Further details can be found in [1]. -C -C [An M-by-N matrix E with rank(E) = r is said to be in column -C echelon form if the following conditions are satisfied: -C (a) the first (N - r) columns contain only zero elements; and -C (b) if E(i(k),k) is the last nonzero element in column k for -C k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for -C j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.] -C -C REFERENCES -C -C [1] Beelen, Th. and Van Dooren, P. -C An improved algorithm for the computation of Kronecker's -C canonical form of a singular pencil. -C Linear Algebra and Applications, 105, pp. 9-65, 1988. -C -C NUMERICAL ASPECTS -C -C It is shown in [1] that the algorithm is numerically backward -C stable. The operations count is proportional to (MAX(M,N))**3. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Based on Release 3.0 routine MB04SD modified by A. Varga, -C German Aerospace Research Establishment, Oberpfaffenhofen, -C Germany, Dec. 1997, to transform also the matrix A. -C -C REVISIONS -C -C A. Varga, DLR Oberpfaffenhofen, June 2005. -C -C KEYWORDS -C -C Echelon form, orthogonal transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBQ, JOBZ - INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, RANKE - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER ISTAIR(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LJOBQI, LJOBZI, LZERO, UPDATQ, UPDATZ - INTEGER I, K, KM1, L, LK, MNK, NR1 - DOUBLE PRECISION EMX, EMXNRM, TAU, TOLER -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DLARF, DLARFG, DLASET, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LJOBQI = LSAME( JOBQ, 'I' ) - UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) - LJOBZI = LSAME( JOBZ, 'I' ) - UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDE.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. - $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. - $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04UD', -INFO ) - RETURN - END IF -C -C Initialize Q and Z to the identity matrices, if needed. -C - IF ( LJOBQI ) - $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) - IF ( LJOBZI ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - RANKE = MIN( M, N ) -C - IF ( RANKE.EQ.0 ) - $ RETURN -C - TOLER = TOL - IF ( TOLER.LE.ZERO ) - $ TOLER = DLAMCH( 'Epsilon' )*DLANGE( 'M', M, N, E, LDE, DWORK ) -C - K = N - LZERO = .FALSE. -C -C WHILE ( ( K > 0 ) AND ( NOT a zero submatrix encountered ) ) DO - 20 IF ( ( K.GT.0 ) .AND. ( .NOT. LZERO ) ) THEN -C -C Intermediate form of E -C -C <--k--><--n-k-> -C l=1 |x....x| | -C | | | -C | Ek | X | -C | | | -C l=m-n+k |x....x| | -C ---------------- -C | |x ... x| } -C | O | x x x| } -C | | x x| } n-k -C | | x| } -C -C where submatrix Ek = E[1:m-n+k;1:k]. -C -C Determine row LK in submatrix Ek with largest max-norm -C (starting with row m-n+k). -C - MNK = M - N + K - EMXNRM = ZERO - LK = MNK -C - DO 40 L = MNK, 1, -1 - EMX = ABS( E(L,IDAMAX( K, E(L,1), LDE )) ) - IF ( EMX.GT.EMXNRM ) THEN - EMXNRM = EMX - LK = L - END IF - 40 CONTINUE -C - IF ( EMXNRM.LE.TOLER ) THEN -C -C Set submatrix Ek to zero. -C - CALL DLASET( 'Full', MNK, K, ZERO, ZERO, E, LDE ) - LZERO = .TRUE. - RANKE = N - K - ELSE -C -C Submatrix Ek is not considered to be identically zero. -C Check whether rows have to be interchanged. -C - IF ( LK.NE.MNK ) THEN -C -C Interchange rows lk and m-n+k in whole A- and E-matrix -C and update the row transformation matrix Q, if needed. -C (For Q, the number of elements involved is m.) -C - CALL DSWAP( N, E(LK,1), LDE, E(MNK,1), LDE ) - CALL DSWAP( N, A(LK,1), LDA, A(MNK,1), LDA ) - IF( UPDATQ ) CALL DSWAP( M, Q(1,LK), 1, Q(1,MNK), 1 ) - END IF -C - KM1 = K - 1 -C -C Determine a Householder transformation to annihilate -C E(m-n+k,1:k-1) using E(m-n+k,k) as pivot. -C Apply the transformation to the columns of A and Ek -C (number of elements involved is m for A and m-n+k for Ek). -C Update the column transformation matrix Z, if needed -C (number of elements involved is n). -C - CALL DLARFG( K, E(MNK,K), E(MNK,1), LDE, TAU ) - EMX = E(MNK,K) - E(MNK,K) = ONE - CALL DLARF( 'Right', MNK-1, K, E(MNK,1), LDE, TAU, E, LDE, - $ DWORK ) - CALL DLARF( 'Right', M, K, E(MNK,1), LDE, TAU, A, LDA, - $ DWORK ) - IF( UPDATZ ) CALL DLARF( 'Right', N, K, E(MNK,1), LDE, TAU, - $ Z, LDZ, DWORK ) - E(MNK,K) = EMX - CALL DLASET( 'Full', 1, KM1, ZERO, ZERO, E(MNK,1), LDE ) -C - K = KM1 - END IF - GO TO 20 - END IF -C END WHILE 20 -C -C Initialise administration staircase form, i.e. -C ISTAIR(i) = j if E(i,j) is a nonzero corner point -C = -j if E(i,j) is on the boundary but is no corner -C point. -C Thus, -C ISTAIR(m-k) = n-k for k=0,...,rank(E)-1 -C = -(n-rank(E)+1) for k=rank(E),...,m-1. -C - DO 60 I = 0, RANKE - 1 - ISTAIR(M-I) = N - I - 60 CONTINUE -C - NR1 = -(N - RANKE + 1) -C - DO 80 I = 1, M - RANKE - ISTAIR(I) = NR1 - 80 CONTINUE -C - RETURN -C *** Last line of MB04UD *** - END diff --git a/slycot/src/MB04VD.f b/slycot/src/MB04VD.f deleted file mode 100644 index e83817aa..00000000 --- a/slycot/src/MB04VD.f +++ /dev/null @@ -1,540 +0,0 @@ - SUBROUTINE MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE, - $ Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK, - $ INUK, IMUK0, MNEI, TOL, IWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformations Q and Z such that the -C transformed pencil Q'(sE-A)Z is in upper block triangular form, -C where E is an M-by-N matrix in column echelon form (see SLICOT -C Library routine MB04UD) and A is an M-by-N matrix. -C -C If MODE = 'B', then the matrices A and E are transformed into the -C following generalized Schur form by unitary transformations Q1 -C and Z1 : -C -C | sE(eps,inf)-A(eps,inf) | X | -C Q1'(sE-A)Z1 = |------------------------|------------|. (1) -C | O | sE(r)-A(r) | -C -C The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it -C contains all Kronecker column indices and infinite elementary -C divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all -C Kronecker row indices and elementary divisors of sE-A. -C Note: X is a pencil. -C -C If MODE = 'T', then the submatrices having full row and column -C rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are -C triangularized by applying unitary transformations Q2 and Z2 to -C Q1'*(sE-A)*Z1. -C -C If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is -C separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying -C unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2. -C -C This gives -C -C | sE(eps)-A(eps) | X | X | -C |----------------|----------------|------------| -C | O | sE(inf)-A(inf) | X | -C Q'(sE-A)Z =|=================================|============| (2) -C | | | -C | O | sE(r)-A(r) | -C -C where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3. -C Note: the pencil sE(r)-A(r) is not reduced further. -C -C ARGUMENTS -C -C Mode Parameters -C -C MODE CHARACTER*1 -C Specifies the desired structure of the transformed -C pencil Q'(sE-A)Z to be computed as follows: -C = 'B': Basic reduction given by (1); -C = 'T': Further reduction of (1) to triangular form; -C = 'S': Further separation of sE(eps,inf)-A(eps,inf) -C in (1) into the two pencils in (2). -C -C JOBQ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = 'N': Do not form Q; -C = 'I': Q is initialized to the unit matrix and the -C orthogonal transformation matrix Q is returned; -C = 'U': The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = 'N': Do not form Z; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned; -C = 'U': The given matrix Z is updated by the orthogonal -C transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in the matrices A, E and the order of -C the matrix Q. M >= 0. -C -C N (input) INTEGER -C The number of columns in the matrices A, E and the order -C of the matrix Z. N >= 0. -C -C RANKE (input) INTEGER -C The rank of the matrix E in column echelon form. -C RANKE >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix to be row compressed. -C On exit, the leading M-by-N part of this array contains -C the matrix that has been row compressed while keeping -C matrix E in column echelon form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading M-by-N part of this array must -C contain the matrix in column echelon form to be -C transformed equivalent to matrix A. -C On exit, the leading M-by-N part of this array contains -C the matrix that has been transformed equivalent to matrix -C A. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if JOBQ = 'U', then the leading M-by-M part of -C this array must contain a given matrix Q (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading M-by-M part of this array contains the product of -C the input matrix Q and the row transformation matrix used -C to transform the rows of matrices A and E. -C On exit, if JOBQ = 'I', then the leading M-by-M part of -C this array contains the matrix of accumulated orthogonal -C row transformations performed. -C If JOBQ = 'N', the array Q is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDQ = 1 and -C declare this array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. If JOBQ = 'U' or -C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if JOBZ = 'U', then the leading N-by-N part of -C this array must contain a given matrix Z (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix Z and the column transformation matrix -C used to transform the columns of matrices A and E. -C On exit, if JOBZ = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated orthogonal -C column transformations performed. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'U' or -C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C ISTAIR (input/output) INTEGER array, dimension (M) -C On entry, this array must contain information on the -C column echelon form of the unitary transformed matrix E. -C Specifically, ISTAIR(i) must be set to +j if the first -C non-zero element E(i,j) is a corner point and -j -C otherwise, for i = 1,2,...,M. -C On exit, this array contains no useful information. -C -C NBLCKS (output) INTEGER -C The number of submatrices having full row rank greater -C than or equal to 0 detected in matrix A in the pencil -C sE(x)-A(x), -C where x = eps,inf if MODE = 'B' or 'T', -C or x = eps if MODE = 'S'. -C -C NBLCKI (output) INTEGER -C If MODE = 'S', the number of diagonal submatrices in the -C pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then -C NBLCKI = 0. -C -C IMUK (output) INTEGER array, dimension (MAX(N,M+1)) -C The leading NBLCKS elements of this array contain the -C column dimensions mu(1),...,mu(NBLCKS) of the submatrices -C having full column rank in the pencil sE(x)-A(x), -C where x = eps,inf if MODE = 'B' or 'T', -C or x = eps if MODE = 'S'. -C -C INUK (output) INTEGER array, dimension (MAX(N,M+1)) -C The leading NBLCKS elements of this array contain the -C row dimensions nu(1),...,nu(NBLCKS) of the submatrices -C having full row rank in the pencil sE(x)-A(x), -C where x = eps,inf if MODE = 'B' or 'T', -C or x = eps if MODE = 'S'. -C -C IMUK0 (output) INTEGER array, dimension (limuk0), -C where limuk0 = N if MODE = 'S' and 1, otherwise. -C If MODE = 'S', then the leading NBLCKI elements of this -C array contain the dimensions mu0(1),...,mu0(NBLCKI) -C of the square diagonal submatrices in the pencil -C sE(inf)-A(inf). -C Otherwise, IMUK0 is not referenced and can be supplied -C as a dummy array. -C -C MNEI (output) INTEGER array, dimension (3) -C If MODE = 'B' or 'T' then -C MNEI(1) contains the row dimension of -C sE(eps,inf)-A(eps,inf); -C MNEI(2) contains the column dimension of -C sE(eps,inf)-A(eps,inf); -C MNEI(3) = 0. -C If MODE = 'S', then -C MNEI(1) contains the row dimension of sE(eps)-A(eps); -C MNEI(2) contains the column dimension of sE(eps)-A(eps); -C MNEI(3) contains the order of the regular pencil -C sE(inf)-A(inf). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance below which matrix elements are considered -C to be zero. If the user sets TOL to be less than (or -C equal to) zero then the tolerance is taken as -C EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the -C machine precision (see LAPACK Library routine DLAMCH), -C I = 1,2,...,M and J = 1,2,...,N. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C > 0: if incorrect rank decisions were revealed during the -C triangularization phase. This failure is not likely -C to occur. The possible values are: -C = 1: if incorrect dimensions of a full column rank -C submatrix; -C = 2: if incorrect dimensions of a full row rank -C submatrix. -C -C METHOD -C -C Let sE - A be an arbitrary pencil. Prior to calling the routine, -C this pencil must be transformed into a pencil with E in column -C echelon form. This may be accomplished by calling the SLICOT -C Library routine MB04UD. Depending on the value of MODE, -C submatrices of A and E are then reduced to one of the forms -C described above. Further details can be found in [1]. -C -C REFERENCES -C -C [1] Beelen, Th. and Van Dooren, P. -C An improved algorithm for the computation of Kronecker's -C canonical form of a singular pencil. -C Linear Algebra and Applications, 105, pp. 9-65, 1988. -C -C NUMERICAL ASPECTS -C -C It is shown in [1] that the algorithm is numerically backward -C stable. The operations count is proportional to (MAX(M,N))**3. -C -C FURTHER COMMENTS -C -C The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number -C of elementary Kronecker blocks of size k x (k+1). -C -C If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1), -C for k = 1,2,...,NBLCKS, is the number of infinite elementary -C divisors of degree k (with mu(NBLCKS+1) = 0). -C -C If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1), -C for k = 1,2,...,NBLCKI, is the number of infinite elementary -C divisors of degree k (with mu0(NBLCKI+1) = 0). -C In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and -C sE(eta)-A(eta) can be separated by pertransposing the pencil -C sE(r)-A(r) and calling the routine with MODE set to 'B'. The -C result has got to be pertransposed again. (For more details see -C [1]). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Based on Release 3.0 routine MB04TD modified by A. Varga, -C German Aerospace Research Establishment, Oberpfaffenhofen, -C Germany, Nov. 1997, as follows: -C 1) NBLCKI is added; -C 2) the significance of IMUK0 and MNEI is changed; -C 3) INUK0 is removed. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, -C staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBQ, JOBZ, MODE - INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKI, NBLCKS, - $ RANKE - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IMUK(*), IMUK0(*), INUK(*), ISTAIR(*), IWORK(*), - $ MNEI(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL FIRST, FIRSTI, LJOBQI, LJOBZI, LMODEB, LMODES, - $ LMODET, UPDATQ, UPDATZ - INTEGER I, IFICA, IFIRA, ISMUK, ISNUK, JK, K, NCA, NRA, - $ RANKA - DOUBLE PRECISION TOLER -C .. Local Arrays .. - DOUBLE PRECISION DWORK(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DLASET, MB04TT, MB04TY, MB04VX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. Executable Statements .. -C - INFO = 0 - LMODEB = LSAME( MODE, 'B' ) - LMODET = LSAME( MODE, 'T' ) - LMODES = LSAME( MODE, 'S' ) - LJOBQI = LSAME( JOBQ, 'I' ) - UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) - LJOBZI = LSAME( JOBZ, 'I' ) - UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LMODEB .AND. .NOT.LMODET .AND. .NOT.LMODES ) THEN - INFO = -1 - ELSE IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN - INFO = -2 - ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( RANKE.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. - $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN - INFO = -12 - ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. - $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04VD', -INFO ) - RETURN - END IF -C -C Initialize Q and Z to the identity matrices, if needed. -C - IF ( LJOBQI ) - $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) - IF ( LJOBZI ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - NBLCKS = 0 - NBLCKI = 0 -C - IF ( N.EQ.0 ) THEN - MNEI(1) = 0 - MNEI(2) = 0 - MNEI(3) = 0 - RETURN - END IF -C - IF ( M.EQ.0 ) THEN - NBLCKS = N - DO 10 I = 1, N - IMUK(I) = 1 - INUK(I) = 0 - 10 CONTINUE - MNEI(1) = 0 - MNEI(2) = N - MNEI(3) = 0 - RETURN - END IF -C - TOLER = TOL - IF ( TOLER.LE.ZERO ) - $ TOLER = DLAMCH( 'Epsilon' )* - $ MAX( DLANGE( 'M', M, N, A, LDA, DWORK ), - $ DLANGE( 'M', M, N, E, LDE, DWORK ) ) -C -C A(k) is the submatrix in A that will be row compressed. -C -C ISMUK = sum(i=1,..,k) MU(i), ISNUK = sum(i=1,...,k) NU(i), -C IFIRA, IFICA: first row and first column index of A(k) in A. -C NRA, NCA: number of rows and columns in A(k). -C - IFIRA = 1 - IFICA = 1 - NRA = M - NCA = N - RANKE - ISNUK = 0 - ISMUK = 0 - K = 0 -C -C Initialization of the arrays INUK and IMUK. -C - DO 20 I = 1, M + 1 - INUK(I) = -1 - 20 CONTINUE -C -C Note: it is necessary that array INUK has DIMENSION M+1 since it -C is possible that M = 1 and NBLCKS = 2. -C Example sE-A = (0 0 s -1). -C - DO 40 I = 1, N - IMUK(I) = -1 - 40 CONTINUE -C -C Compress the rows of A while keeping E in column echelon form. -C -C REPEAT -C - 60 K = K + 1 - CALL MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, LDA, - $ E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANKA, TOLER, - $ IWORK ) - IMUK(K) = NCA - ISMUK = ISMUK + NCA -C - INUK(K) = RANKA - ISNUK = ISNUK + RANKA - NBLCKS = NBLCKS + 1 -C -C If the rank of A(k) is nra then A has full row rank; -C JK = the first column index (in A) after the right most column -C of matrix A(k+1). (In case A(k+1) is empty, then JK = N+1.) -C - IFIRA = 1 + ISNUK - IFICA = 1 + ISMUK - IF ( IFIRA.GT.M ) THEN - JK = N + 1 - ELSE - JK = ABS( ISTAIR(IFIRA) ) - END IF - NRA = M - ISNUK - NCA = JK - 1 - ISMUK -C -C If NCA > 0 then there can be done some more row compression -C of matrix A while keeping matrix E in column echelon form. -C - IF ( NCA.GT.0 ) GO TO 60 -C UNTIL NCA <= 0 -C -C Matrix E(k+1) has full column rank since NCA = 0. -C Reduce A and E by ignoring all rows and columns corresponding -C to E(k+1). Ignoring these columns in E changes the ranks of the -C submatrices E(i), (i=1,...,k-1). -C - MNEI(1) = ISNUK - MNEI(2) = ISMUK - MNEI(3) = 0 -C - IF ( LMODEB ) - $ RETURN -C -C Triangularization of the submatrices in A and E. -C - CALL MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, - $ LDE, Q, LDQ, Z, LDZ, INFO ) -C - IF ( INFO.GT.0 .OR. LMODET ) - $ RETURN -C -C Save the row dimensions of the diagonal submatrices in pencil -C sE(eps,inf)-A(eps,inf). -C - DO 80 I = 1, NBLCKS - IMUK0(I) = INUK(I) - 80 CONTINUE -C -C Reduction to square submatrices E(k)'s in E. -C - CALL MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, - $ LDE, Q, LDQ, Z, LDZ, MNEI ) -C -C Determine the dimensions of the inf diagonal submatrices and -C update block numbers if necessary. -C - FIRST = .TRUE. - FIRSTI = .TRUE. - NBLCKI = NBLCKS - K = NBLCKS -C - DO 100 I = K, 1, -1 - IMUK0(I) = IMUK0(I) - INUK(I) - IF ( FIRSTI .AND. IMUK0(I).EQ.0 ) THEN - NBLCKI = NBLCKI - 1 - ELSE - FIRSTI = .FALSE. - END IF - IF ( FIRST .AND. IMUK(I).EQ.0 ) THEN - NBLCKS = NBLCKS - 1 - ELSE - FIRST = .FALSE. - END IF - 100 CONTINUE -C - RETURN -C *** Last line of MB04VD *** - END diff --git a/slycot/src/MB04VX.f b/slycot/src/MB04VX.f deleted file mode 100644 index 92cfab1c..00000000 --- a/slycot/src/MB04VX.f +++ /dev/null @@ -1,384 +0,0 @@ - SUBROUTINE MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, - $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in -C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. -C -C On entry, it is assumed that the M-by-N matrices A and E have -C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to -C the pencil s*E - A as described in [1], i.e. -C -C | s*E(eps,inf)-A(eps,inf) | X | -C Q'(s*E - A)Z = |-------------------------|-------------| -C | 0 | s*E(r)-A(r) | -C -C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. -C This pencil contains all Kronecker column indices and infinite -C elementary divisors of the pencil s*E - A. -C The pencil s*E(r)-A(r) contains all Kronecker row indices and -C finite elementary divisors of s*E - A. -C Furthermore, the submatrices having full row and column rank in -C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be -C triangularized. -C -C On exit, the result then is -C -C Q'(s*E - A)Z = -C -C | s*E(eps)-A(eps) | X | X | -C |-----------------|-----------------|-------------| -C | 0 | s*E(inf)-A(inf) | X | -C |===================================|=============| -C | | | -C | 0 | s*E(r)-A(r) | -C -C Note that the pencil s*E(r)-A(r) is not reduced further. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPDATQ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Q the orthogonal row transformations, as follows: -C = .FALSE.: Do not form Q; -C = .TRUE.: The given matrix Q is updated by the orthogonal -C row transformations used in the reduction. -C -C UPDATZ LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal column transformations, as -C follows: -C = .FALSE.: Do not form Z; -C = .TRUE.: The given matrix Z is updated by the orthogonal -C column transformations used in the reduction. -C -C Input/Output Parameters -C -C M (input) INTEGER -C Number of rows of A and E. M >= 0. -C -C N (input) INTEGER -C Number of columns of A and E. N >= 0. -C -C NBLCKS (input) INTEGER -C The number of submatrices having full row rank (possibly -C zero) in A(eps,inf). -C -C INUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the row dimensions nu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full row -C rank in the pencil s*E(eps)-A(eps). -C -C IMUK (input/output) INTEGER array, dimension (NBLCKS) -C On entry, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps,inf)-A(eps,inf). -C On exit, this array contains the column dimensions mu(k), -C (k=1, 2, ..., NBLCKS) of the submatrices having full -C column rank in the pencil s*E(eps)-A(eps). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, this array contains the matrix A to be reduced. -C On exit, it contains the transformed matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, this array contains the matrix E to be reduced. -C On exit, it contains the transformed matrix E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,M). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) -C On entry, if UPDATQ = .TRUE., then the leading M-by-M -C part of this array must contain a given matrix Q (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading M-by-M part of this array contains the -C product of the input matrix Q and the row transformation -C matrix that has transformed the rows of the matrices A -C and E. -C If UPDATQ = .FALSE., the array Q is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDQ = 1 and declare this array to be Q(1,1) in the calling -C program). -C -C LDQ INTEGER -C The leading dimension of array Q. If UPDATQ = .TRUE., -C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) -C On entry, if UPDATZ = .TRUE., then the leading N-by-N -C part of this array must contain a given matrix Z (e.g. -C from a previous call to another SLICOT routine), and on -C exit, the leading N-by-N part of this array contains the -C product of the input matrix Z and the column -C transformation matrix that has transformed the columns of -C the matrices A and E. -C If UPDATZ = .FALSE., the array Z is not referenced and -C can be supplied as a dummy array (i.e. set parameter -C LDZ = 1 and declare this array to be Z(1,1) in the calling -C program). -C -C LDZ INTEGER -C The leading dimension of array Z. If UPDATZ = .TRUE., -C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. -C -C MNEI (output) INTEGER array, dimension (3) -C MNEI(1) = MEPS = row dimension of sE(eps)-A(eps); -C MNEI(2) = NEPS = column dimension of sE(eps)-A(eps); -C MNEI(3) = MINF = order of the regular pencil -C sE(inf)-A(inf). -C -C REFERENCES -C -C [1] Beelen, Th. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, -C The Netherlands, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Based on Release 3.0 routine MB04TX modified by A. Varga, -C German Aerospace Research Establishment, Oberpfaffenhofen, -C Germany, Nov. 1997, as follows: -C 1) NBLCKS is only an input variable; -C 2) the significance of MNEI is changed. -C -C REVISIONS -C -C A. Varga, DLR Oberpfaffenhofen, March 2002. -C -C KEYWORDS -C -C Generalized eigenvalue problem, Kronecker indices, orthogonal -C transformation, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL UPDATQ, UPDATZ - INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*), MNEI(3) - DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER CA, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, MINF, - $ MUK, MUKP1, MUP, MUP1, NEPS, NUK, NUP, RA, RJE, - $ SK1P1, TK1P1, TP1 - DOUBLE PRECISION SC, SS -C .. External Subroutines .. - EXTERNAL DROTG, MB04TU -C .. Executable Statements .. -C - MNEI(1) = 0 - MNEI(2) = 0 - MNEI(3) = 0 - IF ( M.LE.0 .OR. N.LE.0 ) - $ RETURN -C -C Initialisation. -C - ISMUK = 0 - ISNUK = 0 -C - DO 20 K = 1, NBLCKS - ISMUK = ISMUK + IMUK(K) - ISNUK = ISNUK + INUK(K) - 20 CONTINUE -C -C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). -C MEPS = Sum(k=1,...,nblcks) NU(k), -C NEPS = Sum(k=1,...,nblcks) MU(k). -C MINF is the order of the regular pencil s*E(inf)-A(inf). -C - MEPS = ISNUK - NEPS = ISMUK - MINF = 0 -C -C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. -C - MUKP1 = 0 -C - DO 120 K = NBLCKS, 1, -1 - NUK = INUK(K) - MUK = IMUK(K) -C -C Reduce submatrix E(k,k+1) to square matrix. -C NOTE that always NU(k) >= MU(k+1) >= 0. -C -C WHILE ( NU(k) > MU(k+1) ) DO - 40 IF ( NUK.GT.MUKP1 ) THEN -C -C sk1p1 = sum(i=k+1,...,p-1) NU(i) -C tk1p1 = sum(i=k+1,...,p-1) MU(i) -C ismuk = sum(i=1,...,k) MU(i) -C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. -C - SK1P1 = 0 - TK1P1 = 0 -C - DO 100 IP = K + 1, NBLCKS -C -C Annihilate the elements originally present in the last -C row of E(k,p+1) and A(k,p). -C Start annihilating the first MU(p) - MU(p+1) elements by -C applying column Givens rotations plus interchanging -C elements. -C Use original bottom diagonal element of A(k,k) as pivot. -C Start position of pivot in A = (ra,ca). -C - TP1 = ISMUK + TK1P1 - RA = ISNUK + SK1P1 - CA = TP1 -C - MUP = IMUK(IP) - NUP = INUK(IP) - MUP1 = NUP -C - DO 60 CJA = CA, CA + MUP - NUP - 1 -C -C CJA = current column index of pivot in A. -C - CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) -C -C Apply transformations to A- and E-matrix. -C Interchange columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RA,CJA+1) = A(RA,CJA) - A(RA,CJA) = ZERO - CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 60 CONTINUE -C -C Annihilate the remaining elements originally present in -C the last row of E(k,p+1) and A(k,p) by alternatingly -C applying row and column rotations plus interchanging -C elements. -C Use diagonal elements of E(p,p+1) and original bottom -C diagonal element of A(k,k) as pivots, respectively. -C (re,ce) and (ra,ca) are the starting positions of the -C pivots in E and A. -C - CJE = TP1 + MUP - CJA = CJE - MUP1 - 1 -C - DO 80 RJE = RA + 1, RA + MUP1 -C -C (RJE,CJE) = current position pivot in E. -C - CJE = CJE + 1 - CJA = CJA + 1 -C -C Determine the row transformations. -C Apply these transformations to E- and A-matrix. -C Interchange the rows simultaneously. -C Update row transformation matrix Q, if needed. -C - CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) - CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), - $ LDE, SC, SS ) - E(RJE-1,CJE) = E(RJE,CJE) - E(RJE,CJE) = ZERO - CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), - $ LDA, SC, SS ) - IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, - $ Q(1,RJE-1), 1, SC, SS ) -C -C Determine the column transformations. -C Apply these transformations to A- and E-matrix. -C Interchange the columns simultaneously. -C Update column transformation matrix Z, if needed. -C - CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) - CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, - $ SS ) - A(RJE,CJA+1) = A(RJE,CJA) - A(RJE,CJA) = ZERO - CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) - IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), - $ 1, SC, SS ) - 80 CONTINUE -C - SK1P1 = SK1P1 + NUP - TK1P1 = TK1P1 + MUP -C - 100 CONTINUE -C -C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last -C row and right most column. The row and column ignored -C belong to the pencil s*E(inf)-A(inf). -C Redefine blocks in new A and E. -C - MUK = MUK - 1 - NUK = NUK - 1 - ISMUK = ISMUK - 1 - ISNUK = ISNUK - 1 - MEPS = MEPS - 1 - NEPS = NEPS - 1 - MINF = MINF + 1 -C - GO TO 40 - END IF -C END WHILE 40 -C - IMUK(K) = MUK - INUK(K) = NUK -C -C Now submatrix E(k,k+1) is square. -C -C Consider next submatrix (k:=k-1). -C - ISNUK = ISNUK - NUK - ISMUK = ISMUK - MUK - MUKP1 = MUK - 120 CONTINUE -C -C Store dimensions of the pencils s*E(eps)-A(eps) and -C s*E(inf)-A(inf) in array MNEI. -C - MNEI(1) = MEPS - MNEI(2) = NEPS - MNEI(3) = MINF -C - RETURN -C *** Last line of MB04VX *** - END diff --git a/slycot/src/MB04WD.f b/slycot/src/MB04WD.f deleted file mode 100644 index 9edbbf8c..00000000 --- a/slycot/src/MB04WD.f +++ /dev/null @@ -1,411 +0,0 @@ - SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, - $ CS, TAU, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate a matrix Q with orthogonal columns (spanning an -C isotropic subspace), which is defined as the first n columns -C of a product of symplectic reflectors and Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C The matrix Q is returned in terms of its first 2*M rows -C -C [ op( Q1 ) op( Q2 ) ] -C Q = [ ]. -C [ -op( Q2 ) op( Q1 ) ] -C -C Blocked version of the SLICOT Library routine MB04WU. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANQ1 CHARACTER*1 -C Specifies the form of op( Q1 ) as follows: -C = 'N': op( Q1 ) = Q1; -C = 'T': op( Q1 ) = Q1'; -C = 'C': op( Q1 ) = Q1'. -C -C TRANQ2 CHARACTER*1 -C Specifies the form of op( Q2 ) as follows: -C = 'N': op( Q2 ) = Q2; -C = 'T': op( Q2 ) = Q2'; -C = 'C': op( Q2 ) = Q2'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices Q1 and Q2. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices Q1 and Q2. -C M >= N >= 0. -C -C K (input) INTEGER -C The number of symplectic Givens rotators whose product -C partly defines the matrix Q. N >= K >= 0. -C -C Q1 (input/output) DOUBLE PRECISION array, dimension -C (LDQ1,N) if TRANQ1 = 'N', -C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' -C On entry with TRANQ1 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector F(i). -C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C K-by-M part of this array must contain in its i-th row -C the vector which defines the elementary reflector F(i). -C On exit with TRANQ1 = 'N', the leading M-by-N part of this -C array contains the matrix Q1. -C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C N-by-M part of this array contains the matrix Q1'. -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. -C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; -C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. -C -C Q2 (input/output) DOUBLE PRECISION array, dimension -C (LDQ2,N) if TRANQ2 = 'N', -C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' -C On entry with TRANQ2 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector H(i) and, on the -C diagonal, the scalar factor of H(i). -C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C K-by-M part of this array must contain in its i-th row the -C vector which defines the elementary reflector H(i) and, on -C the diagonal, the scalar factor of H(i). -C On exit with TRANQ2 = 'N', the leading M-by-N part of this -C array contains the matrix Q2. -C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C N-by-M part of this array contains the matrix Q2'. -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. -C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; -C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is -C the optimal block size determined by the function UE01MD. -C On exit, if INFO = -13, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,M+N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSB). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANQ1, TRANQ2 - INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) -C .. Local Scalars .. - LOGICAL LTRQ1, LTRQ2 - INTEGER I, IB, IERR, KI, KK, NB, NBMIN, NX, PDRS, PDT, - $ PDW, WRKOPT -C .. External Functions .. - LOGICAL LSAME - INTEGER UE01MD - EXTERNAL LSAME, UE01MD -C .. External Subroutines .. - EXTERNAL MB04QC, MB04QF, MB04WU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRQ1 = LSAME( TRANQ1, 'T' ) .OR. LSAME( TRANQ1,'C' ) - LTRQ2 = LSAME( TRANQ2, 'T' ) .OR. LSAME( TRANQ2,'C' ) - NB = UE01MD( 1, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( M.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN - INFO = -4 - ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN - INFO = -5 - ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN - INFO = -9 - ELSE IF ( LDWORK.LT.MAX( 1, M + N ) ) THEN - DWORK(1) = DBLE( MAX( 1, M + N ) ) - INFO = -13 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - NBMIN = 2 - NX = 0 - WRKOPT = M + N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -C -C Determine when to cross over from blocked to unblocked code. -C - NX = MAX( 0, UE01MD( 3, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) ) - IF ( NX.LT.K ) THEN -C -C Determine if workspace is large enough for blocked code. -C - WRKOPT = MAX( WRKOPT, 8*N*NB + 15*NB*NB ) - IF( LDWORK.LT.WRKOPT ) THEN -C -C Not enough workspace to use optimal NB: reduce NB and -C determine the minimum value of NB. -C - NB = INT( ( SQRT( DBLE( 16*N*N + 15*LDWORK ) ) - $ - DBLE( 4*N ) ) / 15.0D0 ) - NBMIN = MAX( 2, UE01MD( 2, 'MB04WD', TRANQ1 // TRANQ2, M, - $ N, K ) ) - END IF - END IF - END IF -C - IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -C -C Use blocked code after the last block. -C The first kk columns are handled by the block method. -C - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) - ELSE - KK = 0 - END IF -C -C Use unblocked code for the last or only block. -C - IF ( KK.LT.N ) - $ CALL MB04WU( TRANQ1, TRANQ2, M-KK, N-KK, K-KK, Q1(KK+1,KK+1), - $ LDQ1, Q2(KK+1,KK+1), LDQ2, CS(2*KK+1), TAU(KK+1), - $ DWORK, LDWORK, IERR ) -C -C Blocked code. -C - IF ( KK.GT.0 ) THEN - PDRS = 1 - PDT = PDRS + 6*NB*NB - PDW = PDT + 9*NB*NB - IF ( LTRQ1.AND.LTRQ2 ) THEN - DO 10 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Rowwise', 'Rowwise', M-I+1, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i+ib:n,i:m) and Q2(i+ib:n,i:m) from -C the right. -C - CALL MB04QC( 'Zero Structure', 'Transpose', - $ 'Transpose', 'No Transpose', 'Forward', - $ 'Rowwise', 'Rowwise', M-I+1, N-I-IB+1, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ Q2(I+IB,I), LDQ2, Q1(I+IB,I), LDQ1, - $ DWORK(PDW) ) - END IF -C -C Apply SH to columns i:m of the current block. -C - CALL MB04WU( 'Transpose', 'Transpose', M-I+1, IB, IB, - $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 10 CONTINUE -C - ELSE IF ( LTRQ1 ) THEN - DO 20 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Rowwise', 'Columnwise', - $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i+ib:n,i:m) from the right and to -C Q2(i:m,i+ib:n) from the left. -C - CALL MB04QC( 'Zero Structure', 'No Transpose', - $ 'Transpose', 'No Transpose', - $ 'Forward', 'Rowwise', 'Columnwise', - $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, - $ Q2(I,I), LDQ2, DWORK(PDRS), NB, - $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, - $ Q1(I+IB,I), LDQ1, DWORK(PDW) ) - END IF -C -C Apply SH to columns/rows i:m of the current block. -C - CALL MB04WU( 'Transpose', 'No Transpose', M-I+1, IB, IB, - $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 20 CONTINUE -C - ELSE IF ( LTRQ2 ) THEN - DO 30 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Columnwise', 'Rowwise', - $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i:m,i+ib:n) from the left and to -C Q2(i+ib:n,i:m) from the right. -C - CALL MB04QC( 'Zero Structure', 'Transpose', - $ 'No Transpose', 'No Transpose', 'Forward', - $ 'Columnwise', 'Rowwise', M-I+1, N-I-IB+1, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ DWORK(PDRS), NB, DWORK(PDT), NB, - $ Q2(I+IB,I), LDQ2, Q1(I,I+IB), LDQ1, - $ DWORK(PDW) ) - END IF -C -C Apply SH to columns/rows i:m of the current block. -C - CALL MB04WU( 'No Transpose', 'Transpose', M-I+1, IB, IB, - $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 30 CONTINUE -C - ELSE - DO 40 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF ( I+IB.LE.N ) THEN -C -C Form the triangular factors of the symplectic block -C reflector SH. -C - CALL MB04QF( 'Forward', 'Columnwise', 'Columnwise', - $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, - $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, - $ DWORK(PDT), NB, DWORK(PDW) ) -C -C Apply SH to Q1(i:m,i+ib:n) and Q2(i:m,i+ib:n) from -C the left. -C - CALL MB04QC( 'Zero Structure', 'No Transpose', - $ 'No Transpose', 'No Transpose', - $ 'Forward', 'Columnwise', 'Columnwise', - $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, - $ Q2(I,I), LDQ2, DWORK(PDRS), NB, - $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, - $ Q1(I,I+IB), LDQ1, DWORK(PDW) ) - END IF -C -C Apply SH to rows i:m of the current block. -C - CALL MB04WU( 'No Transpose', 'No Transpose', M-I+1, IB, - $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ TAU(I), DWORK, LDWORK, IERR ) - 40 CONTINUE - END IF - END IF -C - DWORK(1) = DBLE( WRKOPT ) -C - RETURN -C *** Last line of MB04WD *** - END diff --git a/slycot/src/MB04WP.f b/slycot/src/MB04WP.f deleted file mode 100644 index 2af3306c..00000000 --- a/slycot/src/MB04WP.f +++ /dev/null @@ -1,211 +0,0 @@ - SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate an orthogonal symplectic matrix U, which is defined as -C a product of symplectic reflectors and Givens rotators -C -C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). -C -C as returned by MB04PU. The matrix U is returned in terms of its -C first N rows -C -C [ U1 U2 ] -C U = [ ]. -C [ -U2 U1 ] -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices U1 and U2. N >= 0. -C -C ILO (input) INTEGER -C ILO must have the same value as in the previous call of -C MB04PU. U is equal to the unit matrix except in the -C submatrix -C U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]). -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) -C On entry, the leading N-by-N part of this array must -C contain in its i-th column the vector which defines the -C elementary reflector F(i). -C On exit, the leading N-by-N part of this array contains -C the matrix U1. -C -C LDU1 INTEGER -C The leading dimension of the array U1. LDU1 >= MAX(1,N). -C -C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) -C On entry, the leading N-by-N part of this array must -C contain in its i-th column the vector which defines the -C elementary reflector H(i) and, on the subdiagonal, the -C scalar factor of H(i). -C On exit, the leading N-by-N part of this array contains -C the matrix U2. -C -C LDU2 INTEGER -C The leading dimension of the array U2. LDU2 >= MAX(1,N). -C -C CS (input) DOUBLE PRECISION array, dimension (2N-2) -C On entry, the first 2N-2 elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (N-1) -C On entry, the first N-1 elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -10, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)). -C For optimum performance LDWORK should be larger. (See -C SLICOT Library routine MB04WD). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O(N**3) floating point operations and is -C strongly backward stable. -C -C REFERENCES -C -C [1] C. F. VAN LOAN: -C A symplectic method for approximating all the eigenvalues of -C a Hamiltonian matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] D. KRESSNER: -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner (Technical Univ. Berlin, Germany) and -C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. -C -C REVISIONS -C -C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DOSGPV). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - INTEGER ILO, INFO, LDU1, LDU2, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*) -C .. Local Scalars .. - INTEGER I, IERR, J, NH -C .. External Subroutines .. - EXTERNAL DLASET, MB04WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - 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 ( LDU1.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDWORK.LT.MAX( 1, 2*( N - ILO ) ) ) THEN - DWORK(1) = DBLE( MAX( 1, 2*( N - ILO ) ) ) - INFO = -10 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WP', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Shift the vectors which define the elementary reflectors one -C column to the right, and set the first ilo rows and columns to -C those of the unit matrix. -C - DO 30 J = N, ILO + 1, -1 - DO 10 I = 1, J-1 - U1(I,J) = ZERO - 10 CONTINUE - DO 20 I = J+1, N - U1(I,J) = U1(I,J-1) - 20 CONTINUE - 30 CONTINUE - CALL DLASET( 'All', N, ILO, ZERO, ONE, U1, LDU1 ) - DO 60 J = N, ILO + 1, -1 - DO 40 I = 1, J-1 - U2(I,J) = ZERO - 40 CONTINUE - DO 50 I = J, N - U2(I,J) = U2(I,J-1) - 50 CONTINUE - 60 CONTINUE - CALL DLASET( 'All', N, ILO, ZERO, ZERO, U2, LDU2 ) - NH = N - ILO - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, - $ U1(ILO+1,ILO+1), LDU1, U2(ILO+1,ILO+1), LDU2, - $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) - END IF - RETURN -C *** Last line of MB04WP *** - END diff --git a/slycot/src/MB04WR.f b/slycot/src/MB04WR.f deleted file mode 100644 index 42c1f461..00000000 --- a/slycot/src/MB04WR.f +++ /dev/null @@ -1,340 +0,0 @@ - SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS, - $ TAU, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate orthogonal symplectic matrices U or V, defined as -C products of symplectic reflectors and Givens rotators -C -C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) -C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) -C .... -C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), -C -C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) -C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) -C .... -C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ), -C -C as returned by the SLICOT Library routines MB04TS or MB04TB. The -C matrices U and V are returned in terms of their first N/2 rows: -C -C [ U1 U2 ] [ V1 V2 ] -C U = [ ], V = [ ]. -C [ -U2 U1 ] [ -V2 V1 ] -C -C ARGUMENTS -C -C Input/Output Parameters -C -C JOB CHARACTER*1 -C Specifies whether the matrix U or the matrix V is -C required: -C = 'U': generate U; -C = 'V': generate V. -C -C TRANS CHARACTER*1 -C If JOB = 'U' then TRANS must have the same value as -C the argument TRANA in the previous call of MB04TS or -C MB04TB. -C If JOB = 'V' then TRANS must have the same value as -C the argument TRANB in the previous call of MB04TS or -C MB04TB. -C -C N (input) INTEGER -C The order of the matrices Q1 and Q2. N >= 0. -C -C ILO (input) INTEGER -C ILO must have the same value as in the previous call of -C MB04TS or MB04TB. U and V are equal to the unit matrix -C except in the submatrices -C U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and -C V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]), -C respectively. -C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. -C -C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1,N) -C On entry, if JOB = 'U' and TRANS = 'N' then the -C leading N-by-N part of this array must contain in its i-th -C column the vector which defines the elementary reflector -C FU(i). -C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array must contain in its i-th -C row the vector which defines the elementary reflector -C FU(i). -C If JOB = 'V' and TRANS = 'N' then the leading N-by-N -C part of this array must contain in its i-th row the vector -C which defines the elementary reflector FV(i). -C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array must contain in its i-th -C column the vector which defines the elementary reflector -C FV(i). -C On exit, if JOB = 'U' and TRANS = 'N' then the leading -C N-by-N part of this array contains the matrix U1. -C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array contains the matrix -C U1**T. -C If JOB = 'V' and TRANS = 'N' then the leading N-by-N -C part of this array contains the matrix V1**T. -C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the -C leading N-by-N part of this array contains the matrix V1. -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). -C -C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2,N) -C On entry, if JOB = 'U' then the leading N-by-N part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector HU(i). -C If JOB = 'V' then the leading N-by-N part of this array -C must contain in its i-th row the vector which defines the -C elementary reflector HV(i). -C On exit, if JOB = 'U' then the leading N-by-N part of -C this array contains the matrix U2. -C If JOB = 'V' then the leading N-by-N part of this array -C contains the matrix V2**T. -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). -C -C CS (input) DOUBLE PRECISION array, dimension (2N) -C On entry, if JOB = 'U' then the first 2N elements of -C this array must contain the cosines and sines of the -C symplectic Givens rotators GU(i). -C If JOB = 'V' then the first 2N-2 elements of this array -C must contain the cosines and sines of the symplectic -C Givens rotators GV(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (N) -C On entry, if JOB = 'U' then the first N elements of -C this array must contain the scalar factors of the -C elementary reflectors FU(i). -C If JOB = 'V' then the first N-1 elements of this array -C must contain the scalar factors of the elementary -C reflectors FV(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -12, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,2*(N-ILO+1)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Benner, P., Mehrmann, V., and Xu, H. -C A numerically stable, structure preserving method for -C computing the eigenvalues of real Hamiltonian or symplectic -C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. -C -C [2] Kressner, D. -C Block algorithms for orthogonal symplectic factorizations. -C BIT, 43 (4), pp. 775-790, 2003. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU). -C -C KEYWORDS -C -C Elementary matrix operations, Hamiltonian matrix, orthogonal -C symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER JOB, TRANS - INTEGER ILO, INFO, LDQ1, LDQ2, LDWORK, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) -C .. Local Scalars .. - LOGICAL COMPU, LTRAN - INTEGER I, IERR, J, NH -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLASET, MB04WD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) - COMPU = LSAME( JOB, 'U' ) - IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN - INFO = -1 - ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) 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 ( LDQ1.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF ( LDWORK.LT.MAX( 1, 2*( N-ILO+1 ) ) ) THEN - DWORK(1) = DBLE( MAX( 1, 2*( N-ILO+1 ) ) ) - INFO = -12 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WR', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - IF ( COMPU ) THEN - CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 ) - CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO), - $ LDQ1 ) - CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 ) - CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO), - $ LDQ2 ) - NH = N - ILO + 1 - END IF - IF ( COMPU .AND. .NOT.LTRAN ) THEN -C -C Generate U1 and U2. -C - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, - $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), - $ TAU(ILO), DWORK, LDWORK, IERR ) - END IF - ELSE IF ( COMPU.AND.LTRAN ) THEN -C -C Generate U1**T and U2. -C - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH, - $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), - $ TAU(ILO), DWORK, LDWORK, IERR ) - END IF - ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN -C -C Generate V1**T and V2**T. -C -C Shift the vectors which define the elementary reflectors one -C column to the bottom, and set the first ilo rows and -C columns to those of the unit matrix. -C - DO 40 I = 1, N - DO 10 J = N, MAX( I, ILO )+1, -1 - Q1(J,I) = ZERO - 10 CONTINUE - DO 20 J = MAX( I, ILO ), ILO+1, -1 - Q1(J,I) = Q1(J-1,I) - 20 CONTINUE - DO 30 J = ILO, 1, -1 - Q1(J,I) = ZERO - 30 CONTINUE - IF ( I.LE.ILO ) Q1(I,I) = ONE - 40 CONTINUE - DO 80 I = 1, N - DO 50 J = N, MAX( I, ILO )+1, -1 - Q2(J,I) = ZERO - 50 CONTINUE - DO 60 J = MAX( I, ILO ), ILO+1, -1 - Q2(J,I) = Q2(J-1,I) - 60 CONTINUE - DO 70 J = ILO, 1, -1 - Q2(J,I) = ZERO - 70 CONTINUE - 80 CONTINUE -C - NH = N - ILO - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH, - $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, - $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) - END IF - ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN -C -C Generate V1 and V2**T. -C -C Shift the vectors which define the elementary reflectors one -C column to the right/bottom, and set the first ilo rows and -C columns to those of the unit matrix. -C - DO 110 J = N, ILO + 1, -1 - DO 90 I = 1, J-1 - Q1(I,J) = ZERO - 90 CONTINUE - DO 100 I = J+1, N - Q1(I,J) = Q1(I,J-1) - 100 CONTINUE - 110 CONTINUE - CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 ) - DO 150 I = 1, N - DO 120 J = N, MAX( I, ILO )+1, -1 - Q2(J,I) = ZERO - 120 CONTINUE - DO 130 J = MAX( I, ILO ), ILO+1, -1 - Q2(J,I) = Q2(J-1,I) - 130 CONTINUE - DO 140 J = ILO, 1, -1 - Q2(J,I) = ZERO - 140 CONTINUE - 150 CONTINUE - NH = N - ILO -C - IF ( NH.GT.0 ) THEN - CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH, - $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, - $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) - END IF - END IF - RETURN -C *** Last line of MB04WR *** - END diff --git a/slycot/src/MB04WU.f b/slycot/src/MB04WU.f deleted file mode 100644 index 1e177810..00000000 --- a/slycot/src/MB04WU.f +++ /dev/null @@ -1,402 +0,0 @@ - SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, - $ CS, TAU, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To generate a matrix Q with orthogonal columns (spanning an -C isotropic subspace), which is defined as the first n columns -C of a product of symplectic reflectors and Givens rotators, -C -C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) -C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) -C .... -C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). -C -C The matrix Q is returned in terms of its first 2*M rows -C -C [ op( Q1 ) op( Q2 ) ] -C Q = [ ]. -C [ -op( Q2 ) op( Q1 ) ] -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANQ1 CHARACTER*1 -C Specifies the form of op( Q1 ) as follows: -C = 'N': op( Q1 ) = Q1; -C = 'T': op( Q1 ) = Q1'; -C = 'C': op( Q1 ) = Q1'. -C -C TRANQ2 CHARACTER*1 -C Specifies the form of op( Q2 ) as follows: -C = 'N': op( Q2 ) = Q2; -C = 'T': op( Q2 ) = Q2'; -C = 'C': op( Q2 ) = Q2'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices Q1 and Q2. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices Q1 and Q2. -C M >= N >= 0. -C -C K (input) INTEGER -C The number of symplectic Givens rotators whose product -C partly defines the matrix Q. N >= K >= 0. -C -C Q1 (input/output) DOUBLE PRECISION array, dimension -C (LDQ1,N) if TRANQ1 = 'N', -C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' -C On entry with TRANQ1 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector F(i). -C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C K-by-M part of this array must contain in its i-th row -C the vector which defines the elementary reflector F(i). -C On exit with TRANQ1 = 'N', the leading M-by-N part of this -C array contains the matrix Q1. -C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading -C N-by-M part of this array contains the matrix Q1'. -C -C LDQ1 INTEGER -C The leading dimension of the array Q1. -C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; -C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. -C -C Q2 (input/output) DOUBLE PRECISION array, dimension -C (LDQ2,N) if TRANQ2 = 'N', -C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' -C On entry with TRANQ2 = 'N', the leading M-by-K part of -C this array must contain in its i-th column the vector -C which defines the elementary reflector H(i) and, on the -C diagonal, the scalar factor of H(i). -C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C K-by-M part of this array must contain in its i-th row the -C vector which defines the elementary reflector H(i) and, on -C the diagonal, the scalar factor of H(i). -C On exit with TRANQ2 = 'N', the leading M-by-N part of this -C array contains the matrix Q2. -C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading -C N-by-M part of this array contains the matrix Q2'. -C -C LDQ2 INTEGER -C The leading dimension of the array Q2. -C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; -C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. -C -C CS (input) DOUBLE PRECISION array, dimension (2*K) -C On entry, the first 2*K elements of this array must -C contain the cosines and sines of the symplectic Givens -C rotators G(i). -C -C TAU (input) DOUBLE PRECISION array, dimension (K) -C On entry, the first K elements of this array must -C contain the scalar factors of the elementary reflectors -C F(i). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C On exit, if INFO = -13, DWORK(1) returns the minimum -C value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,M+N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C REFERENCES -C -C [1] Bunse-Gerstner, A. -C Matrix factorizations for symplectic QR-like methods. -C Linear Algebra Appl., 83, pp. 49-77, 1986. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSQ). -C -C KEYWORDS -C -C Elementary matrix operations, orthogonal symplectic matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANQ1, TRANQ2 - INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) -C .. Local Scalars .. - LOGICAL LTRQ1, LTRQ2 - INTEGER I, J - DOUBLE PRECISION NU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INFO = 0 - LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' ) - LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN - INFO = -1 - ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN - INFO = -2 - ELSE IF ( M.LT.0 ) THEN - INFO = -3 - ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN - INFO = -4 - ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN - INFO = -5 - ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN - INFO = -9 - ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN - DWORK(1) = DBLE( MAX( 1,M + N ) ) - INFO = -13 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04WU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Initialize columns K+1:N to columns of the unit matrix. -C - DO 20 J = K + 1, N - DO 10 I = 1, M - Q1(I,J) = ZERO - 10 CONTINUE - Q1(J,J) = ONE - 20 CONTINUE - CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 ) -C - IF ( LTRQ1.AND.LTRQ2 ) THEN - DO 50 I = K, 1, -1 -C -C Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the -C right. -C - CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), - $ Q1(I+1,I), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), - $ Q2(I+1,I), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(I,1:I-1) and Q2(I,1:M) to zero. -C - DO 30 J = 1, I - 1 - Q1(I,J) = ZERO - 30 CONTINUE - DO 40 J = 1, M - Q2(I,J) = ZERO - 40 CONTINUE -C -C Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right. -C - CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 50 CONTINUE - ELSE IF ( LTRQ1 ) THEN - DO 80 I = K, 1, -1 -C -C Apply F(I) to Q1(I+1:N,I:M) from the right and to -C Q2(I:M,I+1:N) from the left. -C - CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), - $ Q1(I+1,I), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I), - $ Q2(I,I+1), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(I,1:I-1) and Q2(1:M,I) to zero. -C - DO 60 J = 1, I - 1 - Q1(I,J) = ZERO - 60 CONTINUE - DO 70 J = 1, M - Q2(J,I) = ZERO - 70 CONTINUE -C -C Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N) -C from the left. -C - CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N) -C from the left. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 80 CONTINUE - ELSE IF ( LTRQ2 ) THEN - DO 110 I = K, 1, -1 -C -C Apply F(I) to Q1(I:M,I+1:N) from the left and to -C Q2(I+1:N,I:M) from the right. -C - CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), - $ Q1(I,I+1), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I), - $ Q2(I+1,I), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(1:I-1,I) and Q2(I,1:M) to zero. -C - DO 90 J = 1, I - 1 - Q1(J,I) = ZERO - 90 CONTINUE - DO 100 J = 1, M - Q2(I,J) = ZERO - 100 CONTINUE -C -C Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I) -C from the right. -C - CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M) -C from the left. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 110 CONTINUE - ELSE - DO 140 I = K, 1, -1 -C -C Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left. -C - CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) - IF ( I.LT.N ) THEN - Q1(I,I) = ONE - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), - $ Q1(I,I+1), LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), - $ Q2(I,I+1), LDQ2, DWORK(M+1) ) - END IF - IF ( I.LT.M ) - $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) - Q1(I,I) = ONE - TAU(I) -C -C Set Q1(1:I-1,I) and Q2(1:M,I) to zero. -C - DO 120 J = 1, I - 1 - Q1(J,I) = ZERO - 120 CONTINUE - DO 130 J = 1, M - Q2(J,I) = ZERO - 130 CONTINUE -C -C Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left. -C - CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), - $ CS(2*I) ) -C -C Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left. -C - NU = DWORK(1) - DWORK(1) = ONE - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), - $ LDQ1, DWORK(M+1) ) - CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), - $ LDQ2, DWORK(M+1) ) - 140 CONTINUE - END IF - DWORK(1) = DBLE( MAX( 1, M+N ) ) -C *** Last line of MB04WU *** - END diff --git a/slycot/src/MB04XD.f b/slycot/src/MB04XD.f deleted file mode 100644 index 6d417486..00000000 --- a/slycot/src/MB04XD.f +++ /dev/null @@ -1,652 +0,0 @@ - SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, - $ V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a basis for the left and/or right singular subspace of -C an M-by-N matrix A corresponding to its smallest singular values. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Specifies whether to compute the left singular subspace -C as follows: -C = 'N': Do not compute the left singular subspace; -C = 'A': Return the (M - RANK) base vectors of the desired -C left singular subspace in U; -C = 'S': Return the first (min(M,N) - RANK) base vectors -C of the desired left singular subspace in U. -C -C JOBV CHARACTER*1 -C Specifies whether to compute the right singular subspace -C as follows: -C = 'N': Do not compute the right singular subspace; -C = 'A': Return the (N - RANK) base vectors of the desired -C right singular subspace in V; -C = 'S': Return the first (min(M,N) - RANK) base vectors -C of the desired right singular subspace in V. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns in matrix A. N >= 0. -C -C RANK (input/output) INTEGER -C On entry, if RANK < 0, then the rank of matrix A is -C computed by the routine as the number of singular values -C greater than THETA. -C Otherwise, RANK must specify the rank of matrix A. -C RANK <= min(M,N). -C On exit, if RANK < 0 on entry, then RANK contains the -C computed rank of matrix A. That is, the number of singular -C values of A greater than THETA. -C Otherwise, the user-supplied value of RANK may be changed -C by the routine on exit if the RANK-th and the (RANK+1)-th -C singular values of A are considered to be equal. -C See also the description of parameter TOL below. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, if RANK < 0, then THETA must specify an upper -C bound on the smallest singular values of A corresponding -C to the singular subspace to be computed. THETA >= 0.0. -C Otherwise, THETA must specify an initial estimate (t say) -C for computing an upper bound on the (min(M,N) - RANK) -C smallest singular values of A. If THETA < 0.0, then t is -C computed by the routine. -C On exit, if RANK >= 0 on entry, then THETA contains the -C computed upper bound such that precisely RANK singular -C values of A are greater than THETA + TOL. -C Otherwise, THETA is unchanged. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A from which the basis of a desired singular -C subspace is to be computed. -C NOTE that this array is destroyed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,M). -C -C U (output) DOUBLE PRECISION array, dimension (LDU,*) -C If JOBU = 'A', then the leading M-by-M part of this array -C contains the (M - RANK) M-dimensional base vectors of the -C desired left singular subspace of A corresponding to its -C singular values less than or equal to THETA. These vectors -C are stored in the i-th column(s) of U for which -C INUL(i) = .TRUE., where i = 1,2,...,M. -C -C If JOBU = 'S', then the leading M-by-min(M,N) part of this -C array contains the first (min(M,N) - RANK) M-dimensional -C base vectors of the desired left singular subspace of A -C corresponding to its singular values less than or equal to -C THETA. These vectors are stored in the i-th column(s) of U -C for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N). -C -C Otherwise, U is not referenced (since JOBU = 'N') and can -C be supplied as a dummy array (i.e. set parameter LDU = 1 -C and declare this array to be U(1,1) in the calling -C program). -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S', -C LDU >= 1 if JOBU = 'N'. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,*) -C If JOBV = 'A', then the leading N-by-N part of this array -C contains the (N - RANK) N-dimensional base vectors of the -C desired right singular subspace of A corresponding to its -C singular values less than or equal to THETA. These vectors -C are stored in the i-th column(s) of V for which -C INUL(i) = .TRUE., where i = 1,2,...,N. -C -C If JOBV = 'S', then the leading N-by-min(M,N) part of this -C array contains the first (min(M,N) - RANK) N-dimensional -C base vectors of the desired right singular subspace of A -C corresponding to its singular values less than or equal to -C THETA. These vectors are stored in the i-th column(s) of V -C for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N). -C -C Otherwise, V is not referenced (since JOBV = 'N') and can -C be supplied as a dummy array (i.e. set parameter LDV = 1 -C and declare this array to be V(1,1) in the calling -C program). -C -C LDV INTEGER -C The leading dimension of array V. -C LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S', -C LDV >= 1 if JOBV = 'N'. -C -C Q (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1) -C This array contains the partially diagonalized bidiagonal -C matrix J computed from A, at the moment that the desired -C singular subspace has been found. Specifically, the -C leading p = min(M,N) entries of Q contain the diagonal -C elements q(1),q(2),...,q(p) and the entries Q(p+1), -C Q(p+2),...,Q(2*p-1) contain the superdiagonal elements -C e(1),e(2),...,e(p-1) of J. -C -C INUL (output) LOGICAL array, dimension (max(M,N)) -C If JOBU <> 'N' or JOBV <> 'N', then the indices of the -C elements of this array with value .TRUE. indicate the -C columns in U and/or V containing the base vectors of the -C desired left and/or right singular subspace of A. They -C also equal the indices of the diagonal elements of the -C bidiagonal submatrices in the array Q, which correspond -C to the computed singular subspaces. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL is also taken -C as an absolute tolerance for negligible elements in the -C QR/QL iterations. If the user sets TOL to be less than or -C equal to 0, then the tolerance is taken as specified in -C SLICOT Library routine MB04YD document. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. If the user sets RELTOL to be less than -C BASE * EPS, where BASE is machine radix and EPS is machine -C precision (see LAPACK Library routine DLAMCH), then the -C tolerance is taken as BASE * EPS. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where -C P = min(M,N); -C LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large -C enough than N; -C LDW = 0, otherwise; -C LDY = 8*P - 5, if JOBU <> 'N' or JOBV <> 'N'; -C LDY = 6*P - 3, if JOBU = 'N' and JOBV = 'N'. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: if the rank of matrix A (as specified by the user) -C has been lowered because a singular value of -C multiplicity greater than 1 was found. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the maximum number of QR/QL iteration steps -C (30*MIN(M,N)) has been exceeded. -C -C METHOD -C -C The method used is the Partial Singular Value Decomposition (PSVD) -C approach proposed by Van Huffel, Vandewalle and Haegemans, which -C is an efficient technique (see [1]) for computing the singular -C subspace of a matrix corresponding to its smallest singular -C values. It differs from the classical SVD algorithm [3] at three -C points, which results in high efficiency. Firstly, the Householder -C transformations of the bidiagonalization need only to be applied -C on the base vectors of the desired singular subspaces; secondly, -C the bidiagonal matrix need only be partially diagonalized; and -C thirdly, the convergence rate of the iterative diagonalization can -C be improved by an appropriate choice between QL and QR iterations. -C (Note, however, that LAPACK Library routine DGESVD, for computing -C SVD, also uses either QL and QR iterations.) Depending on the gap, -C the desired numerical accuracy and the dimension of the desired -C singular subspace, the PSVD can be up to three times faster than -C the classical SVD algorithm. -C -C The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as -C follows: -C -C Step 1: Bidiagonalization phase -C ----------------------- -C (a) If M is large enough than N, transform A into upper -C triangular form R. -C -C (b) Transform A (or R) into bidiagonal form: -C -C |q(1) e(1) 0 ... 0 | -C (0) | 0 q(2) e(2) . | -C J = | . . | -C | . e(N-1)| -C | 0 ... q(N) | -C -C if M >= N, or -C -C |q(1) 0 0 ... 0 0 | -C (0) |e(1) q(2) 0 . . | -C J = | . . . | -C | . q(M-1) . | -C | 0 ... e(M-1) q(M)| -C -C if M < N, using Householder transformations. -C In the second case, transform the matrix to the upper bidiagonal -C form by applying Givens rotations. -C -C (c) If U is requested, initialize U with the identity matrix. -C If V is requested, initialize V with the identity matrix. -C -C Step 2: Partial diagonalization phase -C ----------------------------- -C If the upper bound THETA is not given, then compute THETA such -C that precisely (min(M,N) - RANK) singular values of the bidiagonal -C matrix are less than or equal to THETA, using a bisection method -C [4]. Diagonalize the given bidiagonal matrix J partially, using -C either QR iterations (if the upper left diagonal element of the -C considered bidiagonal submatrix is larger than the lower right -C diagonal element) or QL iterations, such that J is split into -C unreduced bidiagonal submatrices whose singular values are either -C all larger than THETA or all less than or equal to THETA. -C Accumulate the Givens rotations in U and/or V (if desired). -C -C Step 3: Back transformation phase -C ------------------------- -C (a) Apply the Householder transformations of Step 1(b) onto the -C columns of U and/or V associated with the bidiagonal -C submatrices with all singular values less than or equal to -C THETA (if U and/or V is desired). -C -C (b) If M is large enough than N, and U is desired, then apply the -C Householder transformations of Step 1(a) onto each computed -C column of U in Step 3(a). -C -C REFERENCES -C -C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. -C An efficient and reliable algorithm for computing the singular -C subspace of a matrix associated with its smallest singular -C values. -C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. -C -C [2] Van Huffel, S. -C Analysis of the total least squares problem and its use in -C parameter estimation. -C Doctoral dissertation, Dept. of Electr. Eng., Katholieke -C Universiteit Leuven, Belgium, June 1987. -C -C [3] Chan, T.F. -C An improved algorithm for computing the singular value -C decomposition. -C ACM TOMS, 8, pp. 72-83, 1982. -C -C [4] Van Huffel, S. and Vandewalle, J. -C The partial total least squares algorithm. -C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. -C -C NUMERICAL ASPECTS -C -C Using the PSVD a large reduction in computation time can be -C gained in total least squares applications (cf [2 - 4]), in the -C computation of the null space of a matrix and in solving -C (non)homogeneous linear equations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04PD by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C July 10, 1997. -C -C KEYWORDS -C -C Bidiagonalization, singular subspace, singular value -C decomposition, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV - INTEGER INFO, IWARN, LDA, LDU, LDV, LDWORK, M, N, RANK - DOUBLE PRECISION RELTOL, THETA, TOL -C .. Array Arguments .. - LOGICAL INUL(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), Q(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - CHARACTER*1 JOBUY, JOBVY - LOGICAL ALL, LJOBUA, LJOBUS, LJOBVA, LJOBVS, QR, WANTU, - $ WANTV - INTEGER I, IHOUSH, IJ, ITAU, ITAUP, ITAUQ, J, JU, JV, - $ JWORK, K, LDW, LDY, MA, P, PP1, WRKOPT - DOUBLE PRECISION CS, SN, TEMP -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEBRD, DGEQRF, DLARTG, DLASET, DLASR, - $ MB04XY, MB04YD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - P = MIN( M, N ) - K = MAX( M, N ) -C -C Determine whether U and/or V are/is to be computed. -C - LJOBUA = LSAME( JOBU, 'A' ) - LJOBUS = LSAME( JOBU, 'S' ) - LJOBVA = LSAME( JOBV, 'A' ) - LJOBVS = LSAME( JOBV, 'S' ) - WANTU = LJOBUA.OR.LJOBUS - WANTV = LJOBVA.OR.LJOBVS - ALL = ( LJOBUA .AND. M.GT.N ) .OR. ( LJOBVA .AND. M.LT.N ) - QR = M.GE.ILAENV( 6, 'DGESVD', 'N' // 'N', M, N, 0, 0 ) - IF ( QR.AND.WANTU ) THEN - LDW = MAX( 2*N, N*( N + 1 )/2 ) - ELSE - LDW = 0 - END IF - IF ( WANTU.OR.WANTV ) THEN - LDY = 8*P - 5 - ELSE - LDY = 6*P - 3 - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( RANK.GT.P ) THEN - INFO = -5 - ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( ( .NOT.WANTU .AND. LDU.LT.1 ) .OR. - $ ( WANTU .AND. LDU.LT.MAX( 1, M ) ) ) THEN - INFO = -10 - ELSE IF( ( .NOT.WANTV .AND. LDV.LT.1 ) .OR. - $ ( WANTV .AND. LDV.LT.MAX( 1, N ) ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, LDW + MAX( 2*P + K, LDY ) ) ) THEN - INFO = -18 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04XD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( P.EQ.0 ) THEN - IF ( RANK.GE.0 ) - $ THETA = ZERO - RANK = 0 - RETURN - END IF -C -C Initializations. -C - PP1 = P + 1 -C - IF ( ALL .AND. ( .NOT.QR ) ) THEN -C - DO 20 I = 1, P - INUL(I) = .FALSE. - 20 CONTINUE -C - DO 40 I = PP1, K - INUL(I) = .TRUE. - 40 CONTINUE -C - ELSE -C - DO 60 I = 1, K - INUL(I) = .FALSE. - 60 CONTINUE -C - END IF -C -C Step 1: Bidiagonalization phase -C ----------------------- -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( QR ) THEN -C -C 1.a.: M is large enough than N; transform A into upper -C triangular form R by Householder transformations. -C -C Workspace: need 2*N; prefer N + N*NB. -C - ITAU = 1 - JWORK = ITAU + N - CALL DGEQRF( M, N, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = INT( DWORK(JWORK) )+JWORK-1 -C -C If (WANTU), store information on the Householder -C transformations performed on the columns of A in N*(N+1)/2 -C extra storage locations DWORK(K), for K = 1,2,...,N*(N+1)/2. -C (The first N locations store the scalar factors of Householder -C transformations.) -C -C Workspace: LDW = max(2*N, N*(N+1)/2). -C - IF ( WANTU ) THEN - IHOUSH = JWORK - K = IHOUSH - I = N - ELSE - K = 1 - END IF -C - DO 100 J = 1, N - 1 - IF ( WANTU ) THEN - I = I - 1 - CALL DCOPY( I, A(J+1,J), 1, DWORK(K), 1 ) - K = K + I - END IF -C - DO 80 IJ = J + 1, N - A(IJ,J) = ZERO - 80 CONTINUE -C - 100 CONTINUE -C - MA = N - WRKOPT = MAX( WRKOPT, K ) - ELSE -C -C Workspace: LDW = 0. -C - K = 1 - MA = M - WRKOPT = 1 - END IF -C -C 1.b.: Transform A (or R) into bidiagonal form Q using Householder -C transformations. -C -C Workspace: need LDW + 2*min(M,N) + max(M,N); -C prefer LDW + 2*min(M,N) + (M+N)*NB. -C - ITAUQ = K - ITAUP = ITAUQ + P - JWORK = ITAUP + P - CALL DGEBRD( MA, N, A, LDA, Q, Q(PP1), DWORK(ITAUQ), - $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C 1.c.: Initialize U (if WANTU) and V (if WANTV) with the identity -C matrix. -C - IF ( WANTU ) THEN - IF ( ALL ) THEN - JU = M - ELSE - JU = P - END IF - CALL DLASET( 'Full', M, JU, ZERO, ONE, U, LDU ) - JOBUY = 'U' - ELSE - JOBUY = 'N' - END IF - IF ( WANTV ) THEN - IF ( ALL ) THEN - JV = N - ELSE - JV = P - END IF - CALL DLASET( 'Full', N, JV, ZERO, ONE, V, LDV ) - JOBVY = 'U' - ELSE - JOBVY = 'N' - END IF -C -C If the matrix is lower bidiagonal, rotate to be upper bidiagonal -C by applying Givens rotations on the left. -C - IF ( M.LT.N ) THEN -C - DO 120 I = 1, P - 1 - CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) - Q(I) = TEMP - Q(P+I) = SN*Q(I+1) - Q(I+1) = CS*Q(I+1) - IF ( WANTU ) THEN -C -C Workspace: LDW + 4*min(M,N) - 2. -C - DWORK(JWORK+I-1) = CS - DWORK(JWORK+P+I-2) = SN - END IF - 120 CONTINUE -C -C Update left singular vectors if desired. -C - IF( WANTU ) - $ CALL DLASR( 'Right', 'Variable pivot', 'Forward', M, JU, - $ DWORK(JWORK), DWORK(JWORK+P-1), U, LDU ) -C - END IF -C -C Step 2: Partial diagonalization phase. -C ----------------------------- -C Diagonalize the bidiagonal Q partially until convergence -C to the desired left and/or right singular subspace. -C -C Workspace: LDW + 8*min(M,N) - 5, if WANTU or WANTV; -C Workspace: LDW + 6*min(M,N) - 3, if JOBU = JOBV = 'N'. -C - CALL MB04YD( JOBUY, JOBVY, M, N, RANK, THETA, Q, Q(PP1), U, LDU, - $ V, LDV, INUL, TOL, RELTOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARN, INFO ) - IF ( WANTU.OR.WANTV ) THEN - WRKOPT = MAX( WRKOPT, JWORK - 6 + 8*P ) - ELSE - WRKOPT = MAX( WRKOPT, JWORK - 4 + 6*P ) - END IF - IF ( INFO.GT.0 ) - $ RETURN -C -C Step 3: Back transformation phase. -C ------------------------- -C 3.a.: Apply the Householder transformations of the bidiagonaliza- -C tion onto the base vectors associated with the desired -C bidiagonal submatrices. -C -C Workspace: LDW + 2*min(M,N). -C - CALL MB04XY( JOBU, JOBV, MA, N, A, LDA, DWORK(ITAUQ), - $ DWORK(ITAUP), U, LDU, V, LDV, INUL, INFO ) -C -C 3.b.: If A was reduced to upper triangular form R and JOBU = 'A' -C or JOBU = 'S' apply the Householder transformations of the -C triangularization of A onto the desired base vectors. -C - IF ( QR.AND.WANTU ) THEN - IF ( ALL ) THEN -C - DO 140 I = PP1, M - INUL(I) = .TRUE. - 140 CONTINUE -C - END IF - K = IHOUSH - I = N -C - DO 160 J = 1, N - 1 - I = I - 1 - CALL DCOPY( I, DWORK(K), 1, A(J+1,J), 1 ) - K = K + I - 160 CONTINUE -C -C Workspace: MIN(M,N) + 1. -C - JWORK = PP1 - CALL MB04XY( JOBU, 'No V', M, N, A, LDA, DWORK(ITAU), - $ DWORK(ITAU), U, LDU, DWORK(JWORK), 1, INUL, INFO ) - WRKOPT = MAX( WRKOPT, PP1 ) - END IF -C -C Set the optimal workspace. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of MB04XD *** - END diff --git a/slycot/src/MB04XY.f b/slycot/src/MB04XY.f deleted file mode 100644 index 02e8e7e2..00000000 --- a/slycot/src/MB04XY.f +++ /dev/null @@ -1,274 +0,0 @@ - SUBROUTINE MB04XY( JOBU, JOBV, M, N, X, LDX, TAUP, TAUQ, U, - $ LDU, V, LDV, INUL, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply the Householder transformations Pj stored in factored -C form into the columns of the array X, to the desired columns of -C the matrix U by premultiplication, and/or the Householder -C transformations Qj stored in factored form into the rows of the -C array X, to the desired columns of the matrix V by -C premultiplication. The Householder transformations Pj and Qj -C are stored as produced by LAPACK Library routine DGEBRD. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Specifies whether to transform the columns in U as -C follows: -C = 'N': Do not transform the columns in U; -C = 'A': Transform the columns in U (U has M columns); -C = 'S': Transform the columns in U (U has min(M,N) -C columns). -C -C JOBV CHARACTER*1 -C Specifies whether to transform the columns in V as -C follows: -C = 'N': Do not transform the columns in V; -C = 'A': Transform the columns in V (V has N columns); -C = 'S': Transform the columns in V (V has min(M,N) -C columns). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix X. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix X. N >= 0. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading M-by-N part contains in the columns of its -C lower triangle the Householder transformations Pj, and -C in the rows of its upper triangle the Householder -C transformations Qj in factored form. -C X is modified by the routine but restored on exit. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,M). -C -C TAUP (input) DOUBLE PRECISION array, dimension (MIN(M,N)) -C The scalar factors of the Householder transformations Pj. -C -C TAUQ (input) DOUBLE PRECISION array, dimension (MIN(M,N)) -C The scalar factors of the Householder transformations Qj. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, U contains the M-by-M (if JOBU = 'A') or -C M-by-min(M,N) (if JOBU = 'S') matrix U. -C On exit, the Householder transformations Pj have been -C applied to each column i of U corresponding to a parameter -C INUL(i) = .TRUE. -C NOTE that U is not referenced if JOBU = 'N'. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,M), if JOBU = 'A' or JOBU = 'S'; -C LDU >= 1, if JOBU = 'N'. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) -C On entry, V contains the N-by-N (if JOBV = 'A') or -C N-by-min(M,N) (if JOBV = 'S') matrix V. -C On exit, the Householder transformations Qj have been -C applied to each column i of V corresponding to a parameter -C INUL(i) = .TRUE. -C NOTE that V is not referenced if JOBV = 'N'. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= MAX(1,M), if JOBV = 'A' or JOBV = 'S'; -C LDV >= 1, if JOBV = 'N'. -C -C INUL (input) LOGICAL array, dimension (MAX(M,N)) -C INUL(i) = .TRUE. if the i-th column of U and/or V is to be -C transformed, and INUL(i) = .FALSE., otherwise. -C (1 <= i <= MAX(M,N)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder transformations Pj or Qj are applied to the -C columns of U or V indexed by I for which INUL(I) = .TRUE.. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04PZ by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bidiagonalization, orthogonal transformation, singular subspace, -C singular value decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV - INTEGER INFO, LDU, LDV, LDX, M, N -C .. Array Arguments .. - LOGICAL INUL(*) - DOUBLE PRECISION TAUP(*), TAUQ(*), U(LDU,*), V(LDV,*), - $ X(LDX,*) -C .. Local Scalars .. - LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV - INTEGER I, IM, IOFF, L, NCOL, P - DOUBLE PRECISION FIRST -C .. Local Arrays .. - DOUBLE PRECISION DWORK(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARF, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MIN, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBUA = LSAME( JOBU, 'A' ) - LJOBUS = LSAME( JOBU, 'S' ) - LJOBVA = LSAME( JOBV, 'A' ) - LJOBVS = LSAME( JOBV, 'S' ) - WANTU = LJOBUA.OR.LJOBUS - WANTV = LJOBVA.OR.LJOBVS -C -C Test the input scalar arguments. -C - IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDX.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( ( WANTU.AND.LDU.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.WANTU.AND.LDU.LT.1 ) ) THEN - INFO = -10 - ELSE IF( ( WANTV.AND.LDV.LT.MAX( 1, N ) ) .OR. - $ ( .NOT.WANTV.AND.LDV.LT.1 ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'MB04XY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - P = MIN( M, N ) - IF ( P.EQ.0 ) - $ RETURN -C - IF ( M.LT.N ) THEN - IOFF = 1 - ELSE - IOFF = 0 - END IF -C -C Apply the Householder transformations Pj onto the desired -C columns of U. -C - IM = MIN( M-1, N ) - IF ( WANTU .AND. ( IM.GT.0 ) ) THEN - IF ( LJOBUA ) THEN - NCOL = M - ELSE - NCOL = P - END IF -C - DO 40 I = 1, NCOL - IF ( INUL(I) ) THEN -C - DO 20 L = IM, 1, -1 - IF ( TAUP(L).NE.ZERO ) THEN - FIRST = X(L+IOFF,L) - X(L+IOFF,L) = ONE - CALL DLARF( 'Left', M-L+1-IOFF, 1, X(L+IOFF,L), 1, - $ TAUP(L), U(L+IOFF,I), LDU, DWORK ) - X(L+IOFF,L) = FIRST - END IF - 20 CONTINUE -C - END IF - 40 CONTINUE -C - END IF -C -C Apply the Householder transformations Qj onto the desired columns -C of V. -C - IM = MIN( N-1, M ) - IF ( WANTV .AND. ( IM.GT.0 ) ) THEN - IF ( LJOBVA ) THEN - NCOL = N - ELSE - NCOL = P - END IF -C - DO 80 I = 1, NCOL - IF ( INUL(I) ) THEN -C - DO 60 L = IM, 1, -1 - IF ( TAUQ(L).NE.ZERO ) THEN - FIRST = X(L,L+1-IOFF) - X(L,L+1-IOFF) = ONE - CALL DLARF( 'Left', N-L+IOFF, 1, X(L,L+1-IOFF), - $ LDX, TAUQ(L), V(L+1-IOFF,I), LDV, - $ DWORK ) - X(L,L+1-IOFF) = FIRST - END IF - 60 CONTINUE -C - END IF - 80 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB04XY *** - END diff --git a/slycot/src/MB04YD.f b/slycot/src/MB04YD.f deleted file mode 100644 index 90ef68b2..00000000 --- a/slycot/src/MB04YD.f +++ /dev/null @@ -1,623 +0,0 @@ - SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, - $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To partially diagonalize the bidiagonal matrix -C -C |q(1) e(1) 0 ... 0 | -C | 0 q(2) e(2) . | -C J = | . . | (1) -C | . e(MIN(M,N)-1)| -C | 0 ... ... q(MIN(M,N)) | -C -C using QR or QL iterations in such a way that J is split into -C unreduced bidiagonal submatrices whose singular values are either -C all larger than a given bound or are all smaller than (or equal -C to) this bound. The left- and right-hand Givens rotations -C performed on J (corresponding to each QR or QL iteration step) may -C be optionally accumulated in the arrays U and V. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the left-hand Givens rotations, as follows: -C = 'N': Do not form U; -C = 'I': U is initialized to the M-by-MIN(M,N) submatrix of -C the unit matrix and the left-hand Givens rotations -C are accumulated in U; -C = 'U': The given matrix U is updated by the left-hand -C Givens rotations used in the calculation. -C -C JOBV CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix V the right-hand Givens rotations, as follows: -C = 'N': Do not form V; -C = 'I': V is initialized to the N-by-MIN(M,N) submatrix of -C the unit matrix and the right-hand Givens -C rotations are accumulated in V; -C = 'U': The given matrix V is updated by the right-hand -C Givens rotations used in the calculation. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows in matrix U. M >= 0. -C -C N (input) INTEGER -C The number of rows in matrix V. N >= 0. -C -C RANK (input/output) INTEGER -C On entry, if RANK < 0, then the rank of matrix J is -C computed by the routine as the number of singular values -C larger than THETA. -C Otherwise, RANK must specify the rank of matrix J. -C RANK <= MIN(M,N). -C On exit, if RANK < 0 on entry, then RANK contains the -C computed rank of J. That is, the number of singular -C values of J larger than THETA. -C Otherwise, the user-supplied value of RANK may be -C changed by the routine on exit if the RANK-th and the -C (RANK+1)-th singular values of J are considered to be -C equal. See also the parameter TOL. -C -C THETA (input/output) DOUBLE PRECISION -C On entry, if RANK < 0, then THETA must specify an upper -C bound on the smallest singular values of J. THETA >= 0.0. -C Otherwise, THETA must specify an initial estimate (t say) -C for computing an upper bound such that precisely RANK -C singular values are greater than this bound. -C If THETA < 0.0, then t is computed by the routine. -C On exit, if RANK >= 0 on entry, then THETA contains the -C computed upper bound such that precisely RANK singular -C values of J are greater than THETA + TOL. -C Otherwise, THETA is unchanged. -C -C Q (input/output) DOUBLE PRECISION array, dimension -C (MIN(M,N)) -C On entry, this array must contain the diagonal elements -C q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That -C is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N). -C On exit, this array contains the leading diagonal of the -C transformed bidiagonal matrix J. -C -C E (input/output) DOUBLE PRECISION array, dimension -C (MIN(M,N)-1) -C On entry, this array must contain the superdiagonal -C elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal -C matrix J. That is, E(k) = J(k,k+1) for k = 1,2,..., -C MIN(M,N)-1. -C On exit, this array contains the superdiagonal of the -C transformed bidiagonal matrix J. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part -C of this array must contain a left transformation matrix -C applied to the original matrix of the problem, and -C on exit, the leading M-by-MIN(M,N) part of this array -C contains the product of the input matrix U and the -C left-hand Givens rotations. -C On exit, if JOBU = 'I', then the leading M-by-MIN(M,N) -C part of this array contains the matrix of accumulated -C left-hand Givens rotations used. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. If JOBU = 'U' or -C JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) -C On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part -C of this array must contain a right transformation matrix -C applied to the original matrix of the problem, and -C on exit, the leading N-by-MIN(M,N) part of this array -C contains the product of the input matrix V and the -C right-hand Givens rotations. -C On exit, if JOBV = 'I', then the leading N-by-MIN(M,N) -C part of this array contains the matrix of accumulated -C right-hand Givens rotations used. -C If JOBV = 'N', the array V is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDV = 1 and -C declare this array to be V(1,1) in the calling program). -C -C LDV INTEGER -C The leading dimension of array V. If JOBV = 'U' or -C JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1. -C -C INUL (input/output) LOGICAL array, dimension (MIN(M,N)) -C On entry, the leading MIN(M,N) elements of this array must -C be set to .FALSE. unless the i-th columns of U (if JOBU = -C 'U') and V (if JOBV = 'U') already contain a computed base -C vector of the desired singular subspace of the original -C matrix, in which case INUL(i) must be set to .TRUE. -C for 1 <= i <= MIN(M,N). -C On exit, the indices of the elements of this array with -C value .TRUE. indicate the indices of the diagonal entries -C of J which belong to those bidiagonal submatrices whose -C singular values are all less than or equal to THETA. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C This parameter defines the multiplicity of singular values -C by considering all singular values within an interval of -C length TOL as coinciding. TOL is used in checking how many -C singular values are less than or equal to THETA. Also in -C computing an appropriate upper bound THETA by a bisection -C method, TOL is used as a stopping criterion defining the -C minimum (absolute) subinterval width. TOL is also taken -C as an absolute tolerance for negligible elements in the -C QR/QL iterations. If the user sets TOL to be less than or -C equal to 0, then the tolerance is taken as -C EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the -C machine precision (see LAPACK Library routine DLAMCH), -C i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1. -C -C RELTOL DOUBLE PRECISION -C This parameter specifies the minimum relative width of an -C interval. When an interval is narrower than TOL, or than -C RELTOL times the larger (in magnitude) endpoint, then it -C is considered to be sufficiently small and bisection has -C converged. If the user sets RELTOL to be less than -C BASE * EPS, where BASE is machine radix and EPS is machine -C precision (see LAPACK Library routine DLAMCH), then the -C tolerance is taken as BASE * EPS. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or -C JOBV = 'I' or 'U'; -C LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and -C JOBV = 'N'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: if the rank of the bidiagonal matrix J (as specified -C by the user) has been lowered because a singular -C value of multiplicity larger than 1 was found. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; this includes values like RANK > MIN(M,N), or -C THETA < 0.0 and RANK < 0; -C = 1: if the maximum number of QR/QL iteration steps -C (30*MIN(M,N)) has been exceeded. -C -C METHOD -C -C If the upper bound THETA is not specified by the user, then it is -C computed by the routine (using a bisection method) such that -C precisely (MIN(M,N) - RANK) singular values of J are less than or -C equal to THETA + TOL. -C -C The method used by the routine (see [1]) then proceeds as follows. -C -C The unreduced bidiagonal submatrices of J(j), where J(j) is the -C transformed bidiagonal matrix after the j-th iteration step, are -C classified into the following three classes: -C -C - C1 contains the bidiagonal submatrices with all singular values -C > THETA, -C - C2 contains the bidiagonal submatrices with all singular values -C <= THETA and -C - C3 contains the bidiagonal submatrices with singular values -C > THETA and also singular values <= THETA. -C -C If C3 is empty, then the partial diagonalization is complete, and -C RANK is the sum of the dimensions of the bidiagonal submatrices of -C C1. -C Otherwise, QR or QL iterations are performed on each bidiagonal -C submatrix of C3, until this bidiagonal submatrix has been split -C into two bidiagonal submatrices. These two submatrices are then -C classified and the iterations are restarted. -C If the upper left diagonal element of the bidiagonal submatrix is -C larger than its lower right diagonal element, then QR iterations -C are performed, else QL iterations are used. The shift is taken as -C the smallest diagonal element of the bidiagonal submatrix (in -C magnitude) unless its value exceeds THETA, in which case it is -C taken as zero. -C -C REFERENCES -C -C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. -C An efficient and reliable algorithm for computing the -C singular subspace of a matrix associated with its smallest -C singular values. -C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C To avoid overflow, matrix J is scaled so that its largest element -C is no greater than overflow**(1/2) * underflow**(1/4) in absolute -C value (and not much smaller than that, for maximal accuracy). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routine MB04QD by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C July 10, 1997. V. Sima. -C November 25, 1997. V. Sima: Setting INUL(K) = .TRUE. when handling -C 2-by-2 submatrix. -C -C KEYWORDS -C -C Bidiagonal matrix, orthogonal transformation, singular values. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TEN, HNDRD - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, - $ HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 30 ) -C .. Scalar Arguments .. - CHARACTER JOBU, JOBV - INTEGER INFO, IWARN, LDU, LDV, LDWORK, M, N, RANK - DOUBLE PRECISION RELTOL, THETA, TOL -C .. Array Arguments .. - LOGICAL INUL(*) - DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - LOGICAL LJOBUA, LJOBUI, LJOBVA, LJOBVI, NOC12, QRIT - INTEGER I, I1, IASCL, INFO1, ITER, J, K, MAXIT, NUMEIG, - $ OLDI, OLDK, P, R - DOUBLE PRECISION COSL, COSR, EPS, PIVMIN, RMAX, RMIN, SAFEMN, - $ SHIFT, SIGMA, SIGMN, SIGMX, SINL, SINR, SMAX, - $ SMLNUM, THETAC, THRESH, TOLABS, TOLREL, X -C .. External Functions .. - LOGICAL LSAME - INTEGER MB03ND - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME, MB03ND -C .. External Subroutines .. - EXTERNAL DLASET, DLASV2, DROT, DSCAL, MB02NY, MB03MD, - $ MB04YW, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. Executable Statements .. -C - P = MIN( M, N ) - INFO = 0 - IWARN = 0 - LJOBUI = LSAME( JOBU, 'I' ) - LJOBVI = LSAME( JOBV, 'I' ) - LJOBUA = LJOBUI.OR.LSAME( JOBU, 'U' ) - LJOBVA = LJOBVI.OR.LSAME( JOBV, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBUA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBVA .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( RANK.GT.P ) THEN - INFO = -5 - ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( .NOT.LJOBUA .AND. LDU.LT.1 .OR. - $ LJOBUA .AND. LDU.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( .NOT.LJOBVA .AND. LDV.LT.1 .OR. - $ LJOBVA .AND. LDV.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( ( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 6*P-5 ) ) - $ .OR.(.NOT.( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 4*P-3 ) ) - $ ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB04YD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( P.EQ.0 ) THEN - IF ( RANK.GE.0 ) - $ THETA = ZERO - RANK = 0 - RETURN - END IF -C -C Set tolerances and machine parameters. -C - TOLABS = TOL - TOLREL = RELTOL - SMAX = ABS( Q(P) ) -C - DO 20 J = 1, P - 1 - SMAX = MAX( SMAX, ABS( Q(J) ), ABS( E(J) ) ) - 20 CONTINUE -C - SAFEMN = DLAMCH( 'Safe minimum' ) - EPS = DLAMCH( 'Epsilon' ) - IF ( TOLABS.LE.ZERO ) TOLABS = EPS*SMAX - X = DLAMCH( 'Base' )*EPS - IF ( TOLREL.LE.X ) TOLREL = X - THRESH = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS - SMLNUM = SAFEMN / EPS - RMIN = SQRT( SMLNUM ) - RMAX = MIN( ONE / RMIN, ONE / SQRT( SQRT( SAFEMN ) ) ) - THETAC = THETA -C -C Scale the matrix to allowable range, if necessary, and set PIVMIN, -C using the squares of Q and E (saved in DWORK). -C - IASCL = 0 - IF( SMAX.GT.ZERO .AND. SMAX.LT.RMIN ) THEN - IASCL = 1 - SIGMA = RMIN / SMAX - ELSE IF( SMAX.GT.RMAX ) THEN - IASCL = 1 - SIGMA = RMAX / SMAX - END IF - IF( IASCL.EQ.1 ) THEN - CALL DSCAL( P, SIGMA, Q, 1 ) - CALL DSCAL( P-1, SIGMA, E, 1 ) - THETAC = SIGMA*THETA - TOLABS = SIGMA*TOLABS - END IF -C - PIVMIN = Q(P)**2 - DWORK(P) = PIVMIN -C - DO 40 J = 1, P - 1 - DWORK(J) = Q(J)**2 - DWORK(P+J) = E(J)**2 - PIVMIN = MAX( PIVMIN, DWORK(J), DWORK(P+J) ) - 40 CONTINUE -C - PIVMIN = MAX( PIVMIN*SAFEMN, SAFEMN ) -C -C Initialize U and/or V to the identity matrix, if needed. -C - IF ( LJOBUI ) - $ CALL DLASET( 'Full', M, P, ZERO, ONE, U, LDU ) - IF ( LJOBVI ) - $ CALL DLASET( 'Full', N, P, ZERO, ONE, V, LDV ) -C -C Estimate THETA (if not fixed by the user), and set R. -C - IF ( RANK.GE.0 ) THEN - J = P - RANK - CALL MB03MD( P, J, THETAC, Q, E, DWORK(1), DWORK(P+1), PIVMIN, - $ TOLABS, TOLREL, IWARN, INFO1 ) - THETA = THETAC - IF ( IASCL.EQ.1 ) THETA = THETA / SIGMA - IF ( J.LE.0 ) - $ RETURN - R = P - J - ELSE - R = P - MB03ND( P, THETAC, DWORK, DWORK(P+1), PIVMIN, INFO1 ) - END IF -C - RANK = P -C - DO 60 I = 1, P - IF ( INUL(I) ) RANK = RANK - 1 - 60 CONTINUE -C -C From now on K is the smallest known index such that the elements -C of the bidiagonal matrix J with indices larger than K belong to C1 -C or C2. -C RANK = P - SUM(dimensions of known bidiagonal matrices of C2). -C - K = P - OLDI = -1 - OLDK = -1 - ITER = 0 - MAXIT = MAXITR*P -C WHILE ( C3 NOT EMPTY ) DO - 80 IF ( RANK.GT.R .AND. K.GT.0 ) THEN -C WHILE ( K.GT.0 .AND. INUL(K) ) DO -C -C Search for the rightmost index of a bidiagonal submatrix, -C not yet classified. -C - 100 IF ( K.GT.0 ) THEN - IF ( INUL(K) ) THEN - K = K - 1 - GO TO 100 - END IF - END IF -C END WHILE 100 -C - IF ( K.EQ.0 ) - $ RETURN -C - NOC12 = .TRUE. -C WHILE ((ITER < MAXIT).AND.(No bidiagonal matrix of C1 or -C C2 found)) DO - 120 IF ( ( ITER.LT.MAXIT ) .AND. NOC12 ) THEN -C -C Search for negligible Q(I) or E(I-1) (for I > 1) and find -C the shift. -C - I = K - X = ABS( Q(I) ) - SHIFT = X -C WHILE ABS( Q(I) ) > TOLABS .AND. ABS( E(I-1) ) > TOLABS ) DO - 140 IF ( I.GT.1 ) THEN - IF ( ( X.GT.TOLABS ).AND.( ABS( E(I-1) ).GT.TOLABS ) ) - $ THEN - I = I - 1 - X = ABS( Q(I) ) - IF ( X.LT.SHIFT ) SHIFT = X - GO TO 140 - END IF - END IF -C END WHILE 140 -C -C Classify the bidiagonal submatrix (of order J) found. -C - J = K - I + 1 - IF ( ( X.LE.TOLABS ) .OR. ( K.EQ.I ) ) THEN - NOC12 = .FALSE. - ELSE - NUMEIG = MB03ND( J, THETAC, DWORK(I), DWORK(P+I), PIVMIN, - $ INFO1 ) - IF ( NUMEIG.GE.J .OR. NUMEIG.LE.0 ) NOC12 = .FALSE. - END IF - IF ( NOC12 ) THEN - IF ( J.EQ.2 ) THEN -C -C Handle separately the 2-by-2 submatrix. -C - CALL DLASV2( Q(I), E(I), Q(K), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - Q(I) = SIGMX - Q(K) = SIGMN - E(I) = ZERO - RANK = RANK - 1 - INUL(K) = .TRUE. - NOC12 = .FALSE. -C -C Update U and/or V, if needed. -C - IF( LJOBUA ) - $ CALL DROT( M, U(1,I), 1, U(1,K), 1, COSL, SINL ) - IF( LJOBVA ) - $ CALL DROT( N, V(1,I), 1, V(1,K), 1, COSR, SINR ) - ELSE -C -C If working on new submatrix, choose QR or -C QL iteration. -C - IF ( I.NE.OLDI .OR. K.NE.OLDK ) - $ QRIT = ABS( Q(I) ).GE.ABS( Q(K) ) - OLDI = I - IF ( QRIT ) THEN - IF ( ABS( E(K-1) ).LE.THRESH*ABS( Q(K) ) ) - $ E(K-1) = ZERO - ELSE - IF ( ABS( E(I) ).LE.THRESH*ABS( Q(I) ) ) - $ E(I) = ZERO - END IF -C - CALL MB04YW( QRIT, LJOBUA, LJOBVA, M, N, I, K, SHIFT, - $ Q, E, U, LDU, V, LDV, DWORK(2*P) ) -C - IF ( QRIT ) THEN - IF ( ABS( E(K-1) ).LE.TOLABS ) E(K-1) = ZERO - ELSE - IF ( ABS( E(I) ).LE.TOLABS ) E(I) = ZERO - END IF - DWORK(K) = Q(K)**2 -C - DO 160 I1 = I, K - 1 - DWORK(I1) = Q(I1)**2 - DWORK(P+I1) = E(I1)**2 - 160 CONTINUE -C - ITER = ITER + 1 - END IF - END IF - GO TO 120 - END IF -C END WHILE 120 -C - IF ( ITER.GE.MAXIT ) THEN - INFO = 1 - GO TO 200 - END IF -C - IF ( X.LE.TOLABS ) THEN -C -C Split at negligible diagonal element ABS( Q(I) ) <= TOLABS. -C - CALL MB02NY( LJOBUA, LJOBVA, M, N, I, K, Q, E, U, LDU, V, - $ LDV, DWORK(2*P) ) - INUL(I) = .TRUE. - RANK = RANK - 1 - ELSE -C -C A negligible superdiagonal element ABS( E(I-1) ) <= TOL -C has been found, the corresponding bidiagonal submatrix -C belongs to C1 or C2. Treat this bidiagonal submatrix. -C - IF ( J.GE.2 ) THEN - IF ( NUMEIG.EQ.J ) THEN -C - DO 180 I1 = I, K - INUL(I1) = .TRUE. - 180 CONTINUE -C - RANK = RANK - J - K = K - J - ELSE - K = I - 1 - END IF - ELSE - IF ( X.LE.( THETAC + TOLABS ) ) THEN - INUL(I) = .TRUE. - RANK = RANK - 1 - END IF - K = K - 1 - END IF - OLDK = K - END IF - GO TO 80 - END IF -C END WHILE 80 -C -C If matrix was scaled, then rescale Q and E appropriately. -C - 200 CONTINUE - IF( IASCL.EQ.1 ) THEN - CALL DSCAL( P, ONE / SIGMA, Q, 1 ) - CALL DSCAL( P-1, ONE / SIGMA, E, 1 ) - END IF -C - RETURN -C *** Last line of MB04YD *** - END diff --git a/slycot/src/MB04YW.f b/slycot/src/MB04YW.f deleted file mode 100644 index 0090d511..00000000 --- a/slycot/src/MB04YW.f +++ /dev/null @@ -1,513 +0,0 @@ - SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E, - $ U, LDU, V, LDV, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform either one QR or QL iteration step onto the unreduced -C bidiagonal submatrix Jk: -C -C |D(l) E(l) 0 ... 0 | -C | 0 D(l+1) E(l+1) . | -C Jk = | . . | -C | . . | -C | . E(k-1)| -C | 0 ... ... D(k) | -C -C with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J: -C -C |D(1) E(1) 0 ... 0 | -C | 0 D(2) E(2) . | -C J = | . . |. -C | . . | -C | . E(p-1)| -C | 0 ... ... D(p) | -C -C Hereby, Jk is transformed to S' Jk T with S and T products of -C Givens rotations. These Givens rotations S (respectively, T) are -C postmultiplied into U (respectively, V), if UPDATU (respectively, -C UPDATV) is .TRUE.. -C -C ARGUMENTS -C -C Mode Parameters -C -C QRIT LOGICAL -C Indicates whether a QR or QL iteration step is to be -C taken (from larger end diagonal element towards smaller), -C as follows: -C = .TRUE. : QR iteration step (chase bulge from top to -C bottom); -C = .FALSE.: QL iteration step (chase bulge from bottom to -C top). -C -C UPDATU LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix U the left-hand Givens rotations S, as follows: -C = .FALSE.: Do not form U; -C = .TRUE. : The given matrix U is updated (postmultiplied) -C by the left-hand Givens rotations S. -C -C UPDATV LOGICAL -C Indicates whether the user wishes to accumulate in a -C matrix V the right-hand Givens rotations S, as follows: -C = .FALSE.: Do not form V; -C = .TRUE. : The given matrix V is updated (postmultiplied) -C by the right-hand Givens rotations T. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix U. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix V. N >= 0. -C -C L (input) INTEGER -C The index of the first diagonal entry of the considered -C unreduced bidiagonal submatrix Jk of J. -C -C K (input) INTEGER -C The index of the last diagonal entry of the considered -C unreduced bidiagonal submatrix Jk of J. -C -C SHIFT (input) DOUBLE PRECISION -C Value of the shift used in the QR or QL iteration step. -C -C D (input/output) DOUBLE PRECISION array, dimension (p) -C where p = MIN(M,N) -C On entry, D must contain the diagonal entries of the -C bidiagonal matrix J. -C On exit, D contains the diagonal entries of the -C transformed bidiagonal matrix S' J T. -C -C E (input/output) DOUBLE PRECISION array, dimension (p-1) -C On entry, E must contain the superdiagonal entries of J. -C On exit, E contains the superdiagonal entries of the -C transformed matrix S' J T. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) -C On entry, if UPDATU = .TRUE., U must contain the M-by-p -C left transformation matrix. -C On exit, if UPDATU = .TRUE., the Givens rotations S on the -C left have been postmultiplied into U, i.e., U * S is -C returned. -C U is not referenced if UPDATU = .FALSE.. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= max(1,M) if UPDATU = .TRUE.; -C LDU >= 1 if UPDATU = .FALSE.. -C -C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) -C On entry, if UPDATV = .TRUE., V must contain the N-by-p -C right transformation matrix. -C On exit, if UPDATV = .TRUE., the Givens rotations T on the -C right have been postmultiplied into V, i.e., V * T is -C returned. -C V is not referenced if UPDATV = .FALSE.. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= max(1,N) if UPDATV = .TRUE.; -C LDV >= 1 if UPDATV = .FALSE.. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) -C LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.; -C LDWORK >= 2*MIN(M,N)-2, if -C UPDATU = .TRUE. and UPDATV = .FALSE. or -C UPDATV = .TRUE. and UPDATU = .FALSE.; -C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. -C -C METHOD -C -C QR iterations diagonalize the bidiagonal matrix by zeroing the -C super-diagonal elements of Jk from bottom to top. -C QL iterations diagonalize the bidiagonal matrix by zeroing the -C super-diagonal elements of Jk from top to bottom. -C The routine overwrites Jk with the bidiagonal matrix S' Jk T, -C where S and T are products of Givens rotations. -C T is essentially the orthogonal matrix that would be obtained by -C applying one implicit symmetric shift QR (QL) step onto the matrix -C Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a -C product of an orthogonal matrix T and a upper (lower) triangular -C matrix. See [1,Sec.8.2-8.3] and [2] for more details. -C -C REFERENCES -C -C [1] Golub, G.H. and Van Loan, C.F. -C Matrix Computations. -C The Johns Hopkins University Press, Baltimore, Maryland, 1983. -C -C [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H. -C The QR and QL algorithms for symmetric matrices. -C Numer. Math., 11, pp. 293-306, 1968. -C -C [3] Demmel, J. and Kahan, W. -C Computing small singular values of bidiagonal matrices with -C guaranteed high relative accuracy. -C SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. -C Supersedes Release 2.0 routines MB04QY and MB04QZ by S. Van -C Huffel, Katholieke University Leuven, Belgium. -C This subroutine is based on the QR/QL step implemented in LAPACK -C routine DBDSQR. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Bidiagonal matrix, orthogonal transformation, singular values. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL QRIT, UPDATU, UPDATV - INTEGER K, L, LDU, LDV, M, N - DOUBLE PRECISION SHIFT -C .. -C .. Array Arguments .. - DOUBLE PRECISION D( * ), DWORK( * ), E( * ), U( LDU, * ), - $ V( LDV, * ) -C .. -C .. Local Scalars .. - INTEGER I, IROT, NCV, NM1, NM12, NM13 - DOUBLE PRECISION COSL, COSR, CS, F, G, H, OLDCS, OLDSN, R, SINL, - $ SINR, SN -C .. -C .. External Subroutines .. - EXTERNAL DLARTG, DLASR -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SIGN -C .. -C .. Executable Statements .. -C -C For speed, no tests of the input scalar arguments are done. -C -C Quick return if possible. -C - NCV = MIN( M, N ) - IF ( NCV.LE.1 .OR. L.EQ.K ) - $ RETURN -C - NM1 = NCV - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 - IF ( .NOT.UPDATV ) THEN - NM12 = 0 - NM13 = NM1 - END IF -C -C If SHIFT = 0, do simplified QR iteration. -C - IF( SHIFT.EQ.ZERO ) THEN - IF( QRIT ) THEN -C -C Chase bulge from top to bottom. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - CS = ONE - OLDCS = ONE - CALL DLARTG( D( L )*CS, E( L ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( L+1 )*SN, OLDCS, OLDSN, D( L ) ) - IF ( UPDATV ) THEN - DWORK( 1 ) = CS - DWORK( 1+NM1 ) = SN - END IF - IF ( UPDATU ) THEN - DWORK( 1+NM12 ) = OLDCS - DWORK( 1+NM13 ) = OLDSN - END IF - IROT = 1 -C - DO 110 I = L + 1, K - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT + 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = CS - DWORK( IROT+NM1 ) = SN - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = OLDCS - DWORK( IROT+NM13 ) = OLDSN - END IF - 110 CONTINUE -C - H = D( K )*CS - D( K ) = H*OLDCS - E( K-1 ) = H*OLDSN -C -C Update U and/or V. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) -C - ELSE -C -C Chase bulge from bottom to top. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - CS = ONE - OLDCS = ONE - CALL DLARTG( D( K )*CS, E( K-1 ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( K-1 )*SN, OLDCS, OLDSN, D( K ) ) - IF ( UPDATV ) THEN - DWORK( K-L ) = OLDCS - DWORK( K-L+NM1 ) = -OLDSN - END IF - IF ( UPDATU ) THEN - DWORK( K-L+NM12 ) = CS - DWORK( K-L+NM13 ) = -SN - END IF - IROT = K - L -C - DO 120 I = K - 1, L + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT - 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = OLDCS - DWORK( IROT+NM1 ) = -OLDSN - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = CS - DWORK( IROT+NM13 ) = -SN - END IF - 120 CONTINUE -C - H = D( L )*CS - D( L ) = H*OLDCS - E( L ) = H*OLDSN -C -C Update U and/or V. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) - END IF - ELSE -C -C Use nonzero shift. -C - IF( QRIT ) THEN -C -C Chase bulge from top to bottom. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - F = ( ABS( D( L ) ) - SHIFT )* - $ ( SIGN( ONE, D( L ) ) + SHIFT / D( L ) ) - G = E( L ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( L ) + SINR*E( L ) - E( L ) = COSR*E( L ) - SINR*D( L ) - G = SINR*D( L+1 ) - D( L+1 ) = COSR*D( L+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( L ) = R - F = COSL*E( L ) + SINL*D( L+1 ) - D( L+1 ) = COSL*D( L+1 ) - SINL*E( L ) - G = SINL*E( L+1 ) - E( L+1 ) = COSL*E( L+1 ) - IF ( UPDATV ) THEN - DWORK( 1 ) = COSR - DWORK( 1+NM1 ) = SINR - END IF - IF ( UPDATU ) THEN - DWORK( 1+NM12 ) = COSL - DWORK( 1+NM13 ) = SINL - END IF - IROT = 1 -C - DO 130 I = L + 1, K - 2 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - IROT = IROT + 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSR - DWORK( IROT+NM1 ) = SINR - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSL - DWORK( IROT+NM13 ) = SINL - END IF - 130 CONTINUE -C - IF ( L.LT.K-1 ) THEN - CALL DLARTG( F, G, COSR, SINR, R ) - E( K-2 ) = R - F = COSR*D( K-1 ) + SINR*E( K-1 ) - E( K-1 ) = COSR*E( K-1 ) - SINR*D( K-1 ) - G = SINR*D( K ) - D( K ) = COSR*D( K ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( K-1 ) = R - F = COSL*E( K-1 ) + SINL*D( K ) - D( K ) = COSL*D( K ) - SINL*E( K-1 ) - IROT = IROT + 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSR - DWORK( IROT+NM1 ) = SINR - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSL - DWORK( IROT+NM13 ) = SINL - END IF - END IF - E( K-1 ) = F -C -C Update U and/or V. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) -C - ELSE -C -C Chase bulge from bottom to top. -C Save cosines and sines for later U and/or V updates, -C if needed. -C - F = ( ABS( D( K ) ) - SHIFT )* - $ ( SIGN( ONE, D( K ) ) + SHIFT / D( K ) ) - G = E( K-1 ) - IF ( L.LT.K-1 ) THEN - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( K ) + SINR*E( K-1 ) - E( K-1 ) = COSR*E( K-1 ) - SINR*D( K ) - G = SINR*D( K-1 ) - D( K-1 ) = COSR*D( K-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( K ) = R - F = COSL*E( K-1 ) + SINL*D( K-1 ) - D( K-1 ) = COSL*D( K-1 ) - SINL*E( K-1 ) - G = SINL*E( K-2 ) - E( K-2 ) = COSL*E( K-2 ) - IF ( UPDATV ) THEN - DWORK( K-L ) = COSL - DWORK( K-L+NM1 ) = -SINL - END IF - IF ( UPDATU ) THEN - DWORK( K-L+NM12 ) = COSR - DWORK( K-L+NM13 ) = -SINR - END IF - IROT = K - L - ELSE - IROT = K - L + 1 - END IF -C - DO 140 I = K - 1, L + 2, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - IROT = IROT - 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSL - DWORK( IROT+NM1 ) = -SINL - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSR - DWORK( IROT+NM13 ) = -SINR - END IF - 140 CONTINUE -C - CALL DLARTG( F, G, COSR, SINR, R ) - E( L+1 ) = R - F = COSR*D( L+1 ) + SINR*E( L ) - E( L ) = COSR*E( L ) - SINR*D( L+1 ) - G = SINR*D( L ) - D( L ) = COSR*D( L ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( L+1 ) = R - F = COSL*E( L ) + SINL*D( L ) - D( L ) = COSL*D( L ) - SINL*E( L ) - IROT = IROT - 1 - IF ( UPDATV ) THEN - DWORK( IROT ) = COSL - DWORK( IROT+NM1 ) = -SINL - END IF - IF ( UPDATU ) THEN - DWORK( IROT+NM12 ) = COSR - DWORK( IROT+NM13 ) = -SINR - END IF - E( L ) = F -C -C Update U and/or V if desired. -C - IF( UPDATV ) - $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), - $ DWORK( NCV ), V( 1, L ), LDV ) - IF( UPDATU ) - $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), - $ DWORK( NM13+1 ), U( 1, L ), LDU ) - END IF - END IF -C - RETURN -C *** Last line of MB04YW *** - END diff --git a/slycot/src/MB04ZD.f b/slycot/src/MB04ZD.f deleted file mode 100644 index 63c77e6a..00000000 --- a/slycot/src/MB04ZD.f +++ /dev/null @@ -1,486 +0,0 @@ - SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO - $ ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To transform a Hamiltonian matrix -C -C ( A G ) -C H = ( T ) (1) -C ( Q -A ) -C -C into a square-reduced Hamiltonian matrix -C -C ( A' G' ) -C H' = ( T ) (2) -C ( Q' -A' ) -C T -C by an orthogonal symplectic similarity transformation H' = U H U, -C where -C ( U1 U2 ) -C U = ( ). (3) -C ( -U2 U1 ) -C T -C The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0, -C and -C -C 2 T 2 ( A'' G'' ) -C H' := (U H U) = ( T ). -C ( 0 A'' ) -C -C In addition, A'' is upper Hessenberg and G'' is skew symmetric. -C The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the -C eigenvalues of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPU CHARACTER*1 -C Indicates whether the orthogonal symplectic similarity -C transformation matrix U in (3) is returned or -C accumulated into an orthogonal symplectic matrix, or if -C the transformation matrix is not required, as follows: -C = 'N': U is not required; -C = 'I' or 'F': on entry, U need not be set; -C on exit, U contains the orthogonal -C symplectic matrix U from (3); -C = 'V' or 'A': the orthogonal symplectic similarity -C transformations are accumulated into U; -C on input, U must contain an orthogonal -C symplectic matrix S; -C on exit, U contains S*U with U from (3). -C See the description of U below for details. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On input, the leading N-by-N part of this array must -C contain the upper left block A of the Hamiltonian matrix H -C in (1). -C On output, the leading N-by-N part of this array contains -C the upper left block A' of the square-reduced Hamiltonian -C matrix H' in (2). -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C QG (input/output) DOUBLE PRECISION array, dimension -C (LDQG,N+1) -C On input, the leading N-by-N lower triangular part of this -C array must contain the lower triangle of the lower left -C symmetric block Q of the Hamiltonian matrix H in (1), and -C the N-by-N upper triangular part of the submatrix in the -C columns 2 to N+1 of this array must contain the upper -C triangle of the upper right symmetric block G of H in (1). -C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) -C and G(i,j) = G(j,i) is stored in QG(j,i+1). -C On output, the leading N-by-N lower triangular part of -C this array contains the lower triangle of the lower left -C symmetric block Q', and the N-by-N upper triangular part -C of the submatrix in the columns 2 to N+1 of this array -C contains the upper triangle of the upper right symmetric -C block G' of the square-reduced Hamiltonian matrix H' -C in (2). -C -C LDQG INTEGER -C The leading dimension of the array QG. LDQG >= MAX(1,N). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,2*N) -C If COMPU = 'N', then this array is not referenced. -C If COMPU = 'I' or 'F', then the input contents of this -C array are not specified. On output, the leading -C N-by-(2*N) part of this array contains the first N rows -C of the orthogonal symplectic matrix U in (3). -C If COMPU = 'V' or 'A', then, on input, the leading -C N-by-(2*N) part of this array must contain the first N -C rows of an orthogonal symplectic matrix S. On output, the -C leading N-by-(2*N) part of this array contains the first N -C rows of the product S*U where U is the orthogonal -C symplectic matrix from (3). -C The storage scheme implied by (3) is used for orthogonal -C symplectic matrices, i.e., only the first N rows are -C stored, as they contain all relevant information. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= MAX(1,N), if COMPU <> 'N'; -C LDU >= 1, if COMPU = 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, then the i-th argument had an illegal -C value. -C -C METHOD -C -C The Hamiltonian matrix H is transformed into a square-reduced -C Hamiltonian matrix H' using the implicit version of Van Loan's -C method as proposed in [1,2,3]. -C -C REFERENCES -C -C [1] Van Loan, C. F. -C A Symplectic Method for Approximating All the Eigenvalues of -C a Hamiltonian Matrix. -C Linear Algebra and its Applications, 61, pp. 233-251, 1984. -C -C [2] Byers, R. -C Hamiltonian and Symplectic Algorithms for the Algebraic -C Riccati Equation. -C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. -C -C [3] Benner, P., Byers, R., and Barth, E. -C Fortran 77 Subroutines for Computing the Eigenvalues of -C Hamiltonian Matrices. I: The Square-Reduced Method. -C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. -C -C NUMERICAL ASPECTS -C -C This algorithm requires approximately 20*N**3 flops for -C transforming H into square-reduced form. If the transformations -C are required, this adds another 8*N**3 flops. The method is -C strongly backward stable in the sense that if H' and U are the -C computed square-reduced Hamiltonian and computed orthogonal -C symplectic similarity transformation, then there is an orthogonal -C symplectic matrix T and a Hamiltonian matrix M such that -C -C H T = T M -C -C || T - U || <= c1 * eps -C -C || H' - M || <= c2 * eps * || H || -C -C where c1, c2 are modest constants depending on the dimension N and -C eps is the machine precision. -C -C Eigenvalues computed by explicitly forming the upper Hessenberg -C matrix A'' = A'A' + G'Q', with A', G', and Q' as in (2), and -C applying the Hessenberg QR iteration to A'' are exactly -C eigenvalues of a perturbed Hamiltonian matrix H + E, where -C -C || E || <= c3 * sqrt(eps) * || H ||, -C -C and c3 is a modest constant depending on the dimension N and eps -C is the machine precision. Moreover, if the norm of H and an -C eigenvalue lambda are of roughly the same magnitude, the computed -C eigenvalue is essentially as accurate as the computed eigenvalue -C from traditional methods. See [1] or [2]. -C -C CONTRIBUTOR -C -C P. Benner, Universitaet Bremen, Germany, -C R. Byers, University of Kansas, Lawrence, USA, and -C E. Barth, Kalamazoo College, Kalamazoo, USA, -C Aug. 1998, routine DHASRD. -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998, SLICOT Library version. -C -C REVISIONS -C -C May 2001, A. Varga, German Aeropsce Center, DLR Oberpfaffenhofen. -C May 2009, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Orthogonal transformation, (square-reduced) Hamiltonian matrix, -C symplectic similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. -C - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDQG, LDU, N - CHARACTER COMPU -C .. -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*) -C .. -C .. Local Scalars .. - DOUBLE PRECISION COSINE, SINE, TAU, TEMP, X, Y - INTEGER J - LOGICAL ACCUM, FORGET, FORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1), T(2,2) -C .. -C .. External Functions .. - DOUBLE PRECISION DDOT - LOGICAL LSAME - EXTERNAL DDOT, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DLARFX, DLARTG, - $ DROT, DSYMV, DSYR2, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - ACCUM = LSAME( COMPU, 'A' ) .OR. LSAME( COMPU, 'V' ) - FORM = LSAME( COMPU, 'F' ) .OR. LSAME( COMPU, 'I' ) - FORGET = LSAME( COMPU, 'N' ) -C - IF ( .NOT.ACCUM .AND. .NOT.FORM .AND. .NOT.FORGET ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( .NOT.FORGET .AND. LDU.LT.MAX( 1, N ) ) ) - $ THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'MB04ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Transform to square-reduced form. -C - DO 10 J = 1, N - 1 -C T -C DWORK <- (Q*A - A *Q)(J+1:N,J). -C - CALL DCOPY( J-1, QG(J,1), LDQG, DWORK(N+1), 1 ) - CALL DCOPY( N-J+1, QG(J,J), 1, DWORK(N+J), 1 ) - CALL DGEMV( 'Transpose', N, N-J, -ONE, A(1,J+1), LDA, - $ DWORK(N+1), 1, ZERO, DWORK(J+1), 1 ) - CALL DGEMV( 'NoTranspose', N-J, J, ONE, QG(J+1,1), LDQG, - $ A(1,J), 1, ONE, DWORK(J+1), 1 ) - CALL DSYMV( 'Lower', N-J, ONE, QG(J+1,J+1), LDQG, A(J+1,J), 1, - $ ONE, DWORK(J+1), 1 ) -C -C Symplectic reflection to zero (H*H)((N+J+2):2N,J). -C - CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) - Y = DWORK(J+1) - DWORK(J+1) = ONE -C - CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, - $ DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, - $ DWORK(N+1) ) -C - CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+1), LDQG ) -C - CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+2), LDQG ) -C - IF ( FORM ) THEN -C -C Save reflection. -C - CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,J), 1 ) - U(J+1,J) = TAU -C - ELSE IF ( ACCUM ) THEN -C -C Accumulate reflection. -C - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), - $ LDU, DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), - $ LDU, DWORK(N+1) ) - END IF -C -C (X,Y) := ((J+1,J),(N+J+1,J)) component of H*H. -C - X = DDOT( J, QG(1,J+2), 1, QG(J,1), LDQG ) + - $ DDOT( N-J, QG(J+1,J+2), LDQG, QG(J+1,J), 1 ) + - $ DDOT( N, A(J+1,1), LDA, A(1,J), 1 ) -C -C Symplectic rotation to zero (H*H)(N+J+1,J). -C - CALL DLARTG( X, Y, COSINE, SINE, TEMP ) -C - CALL DROT( J, A(J+1,1), LDA, QG(J+1,1), LDQG, COSINE, SINE ) - CALL DROT( J, A(1,J+1), 1, QG(1,J+2), 1, COSINE, SINE ) - IF( J.LT.N-1 ) THEN - CALL DROT( N-J-1, A(J+1,J+2), LDA, QG(J+2,J+1), 1, - $ COSINE, SINE ) - CALL DROT( N-J-1, A(J+2,J+1), 1, QG(J+1,J+3), LDQG, - $ COSINE, SINE ) - END IF -C - T(1,1) = A(J+1,J+1) - T(1,2) = QG(J+1,J+2) - T(2,1) = QG(J+1,J+1) - T(2,2) = -T(1,1) - CALL DROT( 2, T(1,1), 1, T(1,2), 1, COSINE, SINE ) - CALL DROT( 2, T(1,1), 2, T(2,1), 2, COSINE, SINE ) - A(J+1,J+1) = T(1,1) - QG(J+1,J+2) = T(1,2) - QG(J+1,J+1) = T(2,1) -C - IF ( FORM ) THEN -C -C Save rotation. -C - U(J,J) = COSINE - U(J,N+J) = SINE -C - ELSE IF ( ACCUM ) THEN -C -C Accumulate rotation. -C - CALL DROT( N, U(1,J+1), 1, U(1,N+J+1), 1, COSINE, SINE ) - END IF -C -C DWORK := (A*A + G*Q)(J+1:N,J). -C - CALL DGEMV( 'NoTranspose', N-J, N, ONE, A(J+1,1), LDA, A(1,J), - $ 1, ZERO, DWORK(J+1), 1 ) - CALL DGEMV( 'Transpose', J, N-J, ONE, QG(1,J+2), LDQG, QG(J,1), - $ LDQG, ONE, DWORK(J+1), 1 ) - CALL DSYMV( 'Upper', N-J, ONE, QG(J+1,J+2), LDQG, QG(J+1,J), 1, - $ ONE, DWORK(J+1), 1 ) -C -C Symplectic reflection to zero (H*H)(J+2:N,J). -C - CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) - DWORK(J+1) = ONE -C - CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, - $ DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, - $ DWORK(N+1) ) -C - CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+1), LDQG ) -C - CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, - $ DWORK(N+1) ) - CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), - $ 1, ZERO, DWORK(N+J+1), 1 ) - CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), - $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) - CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, - $ QG(J+1,J+2), LDQG ) -C - IF ( FORM ) THEN -C -C Save reflection. -C - CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,N+J), 1 ) - U(J+1,N+J) = TAU -C - ELSE IF ( ACCUM ) THEN -C -C Accumulate reflection. -C - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), - $ LDU, DWORK(N+1) ) - CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), - $ LDU, DWORK(N+1) ) - END IF -C - 10 CONTINUE -C - IF ( FORM ) THEN - DUMMY(1) = ZERO -C -C Form S by accumulating transformations. -C - DO 20 J = N - 1, 1, -1 -C -C Initialize (J+1)st column of S. -C - CALL DCOPY( N, DUMMY, 0, U(1,J+1), 1 ) - U(J+1,J+1) = ONE - CALL DCOPY( N, DUMMY, 0, U(1,N+J+1), 1 ) -C -C Second reflection. -C - TAU = U(J+1,N+J) - U(J+1,N+J) = ONE - CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, - $ U(J+1,J+1), LDU, DWORK(N+1) ) - CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, - $ U(J+1,N+J+1), LDU, DWORK(N+1) ) -C -C Rotation. -C - CALL DROT( N-J, U(J+1,J+1), LDU, U(J+1,N+J+1), LDU, - $ U(J,J), U(J,N+J) ) -C -C First reflection. -C - TAU = U(J+1,J) - U(J+1,J) = ONE - CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, U(J+1,J+1), - $ LDU, DWORK(N+1) ) - CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, - $ U(J+1,N+J+1), LDU, DWORK(N+1) ) - 20 CONTINUE -C -C The first column is the first column of identity. -C - CALL DCOPY( N, DUMMY, 0, U, 1 ) - U(1,1) = ONE - CALL DCOPY( N, DUMMY, 0, U(1,N+1), 1 ) - END IF -C - RETURN -C *** Last line of MB04ZD *** - END diff --git a/slycot/src/MB05MD.f b/slycot/src/MB05MD.f deleted file mode 100644 index 58da1152..00000000 --- a/slycot/src/MB05MD.f +++ /dev/null @@ -1,356 +0,0 @@ - SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, - $ VALI, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute exp(A*delta) where A is a real N-by-N non-defective -C matrix with real or complex eigenvalues and delta is a scalar -C value. The routine also returns the eigenvalues and eigenvectors -C of A as well as (if all eigenvalues are real) the matrix product -C exp(Lambda*delta) times the inverse of the eigenvector matrix -C of A, where Lambda is the diagonal matrix of eigenvalues. -C Optionally, the routine computes a balancing transformation to -C improve the conditioning of the eigenvalues and eigenvectors. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Indicates how the input matrix should be diagonally scaled -C to improve the conditioning of its eigenvalues as follows: -C = 'N': Do not diagonally scale; -C = 'S': Diagonally scale the matrix, i.e. replace A by -C D*A*D**(-1), where D is a diagonal matrix chosen -C to make the rows and columns of A more equal in -C norm. Do not permute. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C DELTA (input) DOUBLE PRECISION -C The scalar value delta of the problem. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A of the problem. -C On exit, the leading N-by-N part of this array contains -C the solution matrix exp(A*delta). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C V (output) DOUBLE PRECISION array, dimension (LDV,N) -C The leading N-by-N part of this array contains the -C eigenvector matrix for A. -C If the k-th eigenvalue is real the k-th column of the -C eigenvector matrix holds the eigenvector corresponding -C to the k-th eigenvalue. -C Otherwise, the k-th and (k+1)-th eigenvalues form a -C complex conjugate pair and the k-th and (k+1)-th columns -C of the eigenvector matrix hold the real and imaginary -C parts of the eigenvectors corresponding to these -C eigenvalues as follows. -C If p and q denote the k-th and (k+1)-th columns of the -C eigenvector matrix, respectively, then the eigenvector -C corresponding to the complex eigenvalue with positive -C (negative) imaginary value is given by -C 2 -C p + q*j (p - q*j), where j = -1. -C -C LDV INTEGER -C The leading dimension of array V. LDV >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains an -C intermediate result for computing the matrix exponential. -C Specifically, exp(A*delta) is obtained as the product V*Y, -C where V is the matrix stored in the leading N-by-N part of -C the array V. If all eigenvalues of A are real, then the -C leading N-by-N part of this array contains the matrix -C product exp(Lambda*delta) times the inverse of the (right) -C eigenvector matrix of A, where Lambda is the diagonal -C matrix of eigenvalues. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= max(1,N). -C -C VALR (output) DOUBLE PRECISION array, dimension (N) -C VALI (output) DOUBLE PRECISION array, dimension (N) -C These arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the matrix A. The -C eigenvalues are unordered except that complex conjugate -C pairs of values appear consecutively with the eigenvalue -C having positive imaginary part first. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and if N > 0, DWORK(2) returns the reciprocal -C condition number of the triangular matrix used to obtain -C the inverse of the eigenvector matrix. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= max(1,4*N). -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues; no eigenvectors have been computed; -C elements i+1:N of VALR and VALI contain eigenvalues -C which have converged; -C = N+1: if the inverse of the eigenvector matrix could not -C be formed due to an attempt to divide by zero, i.e., -C the eigenvector matrix is singular; -C = N+2: if the matrix A is defective, possibly due to -C rounding errors. -C -C METHOD -C -C This routine is an implementation of "Method 15" of the set of -C methods described in reference [1], which uses an eigenvalue/ -C eigenvector decomposition technique. A modification of LAPACK -C Library routine DGEEV is used for obtaining the right eigenvector -C matrix. A condition estimate is then employed to determine if the -C matrix A is near defective and hence the exponential solution is -C inaccurate. In this case the routine returns with the Error -C Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or -C MB05OD are the preferred alternative routines to be used. -C -C REFERENCES -C -C [1] Moler, C.B. and Van Loan, C.F. -C Nineteen dubious ways to compute the exponential of a matrix. -C SIAM Review, 20, pp. 801-836, 1978. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05AD by M.J. Denham, Kingston -C Polytechnic, March 1981. -C -C REVISIONS -C -C V. Sima, June 13, 1997, April 25, 2003, Feb. 15, 2004. -C -C KEYWORDS -C -C Eigenvalue, eigenvector decomposition, matrix exponential. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC - INTEGER INFO, LDA, LDV, LDWORK, LDY, N - DOUBLE PRECISION DELTA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), V(LDV,*), VALI(*), VALR(*), - $ Y(LDY,*) -C .. Local Scalars .. - LOGICAL SCALE - INTEGER I - DOUBLE PRECISION RCOND, TEMPI, TEMPR, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION TMP(2,2) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGEBAK, DGEMM, DLACPY, DSCAL, DSWAP, DTRCON, - $ DTRMM, DTRSM, MB05MY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC COS, EXP, MAX, SIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - SCALE = LSAME( BALANC, 'S' ) - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDV.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB05MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Compute the eigenvalues and right eigenvectors of the real -C nonsymmetric matrix A; optionally, compute a balancing -C transformation. -C Workspace: need: 4*N. -C - CALL MB05MY( BALANC, N, A, LDA, VALR, VALI, V, LDV, Y, LDY, - $ DWORK, LDWORK, INFO ) -C - IF ( INFO.GT.0 ) - $ RETURN - WRKOPT = DWORK(1) - IF ( SCALE ) THEN - DO 10 I = 1, N - DWORK(I) = DWORK(I+1) - 10 CONTINUE - END IF -C -C Exit with INFO = N + 1 if V is exactly singular. -C - DO 20 I = 1, N - IF ( V(I,I).EQ.ZERO ) THEN - INFO = N + 1 - RETURN - END IF - 20 CONTINUE -C -C Compute the reciprocal condition number of the triangular matrix. -C - CALL DTRCON( '1-norm', 'Upper', 'Non unit', N, V, LDV, RCOND, - $ DWORK(N+1), IWORK, INFO ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN - DWORK(2) = RCOND - INFO = N + 2 - RETURN - END IF -C -C Compute the right eigenvector matrix (temporarily) in A. -C - CALL DLACPY( 'Full', N, N, Y, LDY, A, LDA ) - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non unit', N, N, - $ ONE, V, LDV, A, LDA ) - IF ( SCALE ) - $ CALL DGEBAK( BALANC, 'Right', N, 1, N, DWORK, N, A, LDA, INFO ) -C -C Compute the inverse of the right eigenvector matrix, by solving -C a set of linear systems, V * X = Y' (if BALANC = 'N'). -C - DO 40 I = 2, N - CALL DSWAP( I-1, Y(I,1), LDY, Y(1,I), 1 ) - 40 CONTINUE -C - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non unit', N, N, - $ ONE, V, LDV, Y, LDY ) - IF( SCALE ) THEN -C - DO 60 I = 1, N - TEMPR = ONE / DWORK(I) - CALL DSCAL( N, TEMPR, Y(1,I), 1 ) - 60 CONTINUE -C - END IF -C -C Save the right eigenvector matrix in V. -C - CALL DLACPY( 'Full', N, N, A, LDA, V, LDV ) -C -C Premultiply the inverse eigenvector matrix by the exponential of -C quasi-diagonal matrix Lambda * DELTA, where Lambda is the matrix -C of eigenvalues. -C Note that only real arithmetic is used, taking the special storing -C of eigenvalues/eigenvectors into account. -C - I = 0 -C REPEAT - 80 CONTINUE - I = I + 1 - IF ( VALI(I).EQ.ZERO ) THEN - TEMPR = EXP( VALR(I)*DELTA ) - CALL DSCAL( N, TEMPR, Y(I,1), LDY ) - ELSE - TEMPR = VALR(I)*DELTA - TEMPI = VALI(I)*DELTA - TMP(1,1) = COS( TEMPI )*EXP( TEMPR ) - TMP(1,2) = SIN( TEMPI )*EXP( TEMPR ) - TMP(2,1) = -TMP(1,2) - TMP(2,2) = TMP(1,1) - CALL DLACPY( 'Full', 2, N, Y(I,1), LDY, DWORK, 2 ) - CALL DGEMM( 'No transpose', 'No transpose', 2, N, 2, ONE, - $ TMP, 2, DWORK, 2, ZERO, Y(I,1), LDY ) - I = I + 1 - END IF - IF ( I.LT.N ) GO TO 80 -C UNTIL I = N. -C -C Compute the matrix exponential as the product V * Y. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, V, LDV, - $ Y, LDY, ZERO, A, LDA ) -C -C Set optimal workspace dimension and reciprocal condition number. -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of MB05MD *** - END diff --git a/slycot/src/MB05MY.f b/slycot/src/MB05MY.f deleted file mode 100644 index 7d706349..00000000 --- a/slycot/src/MB05MY.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for an N-by-N real nonsymmetric matrix A, the -C orthogonal matrix Q reducing it to real Schur form T, the -C eigenvalues, and the right eigenvectors of T. -C -C The right eigenvector r(j) of T satisfies -C T * r(j) = lambda(j) * r(j) -C where lambda(j) is its eigenvalue. -C -C The matrix of right eigenvectors R is upper triangular, by -C construction. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Indicates how the input matrix should be diagonally scaled -C to improve the conditioning of its eigenvalues as follows: -C = 'N': Do not diagonally scale; -C = 'S': Diagonally scale the matrix, i.e. replace A by -C D*A*D**(-1), where D is a diagonal matrix chosen -C to make the rows and columns of A more equal in -C norm. Do not permute. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the given matrix A. -C On exit, the leading N-by-N upper quasi-triangular part of -C this array contains the real Schur canonical form of A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues. Complex -C conjugate pairs of eigenvalues appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the matrix of right eigenvectors R, in the same -C order as their eigenvalues. The real and imaginary parts -C of a complex eigenvector corresponding to an eigenvalue -C with positive imaginary part are stored in consecutive -C columns. (The corresponding conjugate eigenvector is not -C stored.) The eigenvectors are not backward transformed -C for balancing (when BALANC = 'S'). -C -C LDR INTEGER -C The leading dimension of array R. LDR >= max(1,N). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C The leading N-by-N part of this array contains the -C orthogonal matrix Q which has reduced A to real Schur -C form. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. -C If BALANC = 'S', DWORK(2),...,DWORK(N+1) return the -C scaling factors used for balancing. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= max(1,4*N). -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues, and no eigenvectors have been -C computed; elements i+1:N of WR and WI contain -C eigenvalues which have converged. -C -C METHOD -C -C This routine uses the QR algorithm to obtain the real Schur form -C T of matrix A. Then, the right eigenvectors of T are computed, -C but they are not backtransformed into the eigenvectors of A. -C MB05MY is a modification of the LAPACK driver routine DGEEV. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05AY. -C -C REVISIONS -C -C V. Sima, April 25, 2003, Feb. 15, 2004. -C -C KEYWORDS -C -C Eigenvalue, eigenvector decomposition, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC - INTEGER INFO, LDA, LDQ, LDR, LDWORK, N -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), DWORK( * ), Q( LDQ, * ), - $ R( LDR, * ), WI( * ), WR( * ) -C .. -C .. Local Scalars .. - LOGICAL SCALE, SCALEA - INTEGER HSDWOR, IBAL, IERR, IHI, ILO, ITAU, JWORK, K, - $ MAXB, MAXWRK, MINWRK, NOUT - DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM -C .. -C .. Local Arrays .. - LOGICAL SELECT( 1 ) - DOUBLE PRECISION DUM( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, DLASCL, - $ DORGHR, DTREVC, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - SCALE = LSAME( BALANC, 'S' ) - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV. -C HSDWOR refers to the workspace preferred by DHSEQR, as -C calculated below. HSDWOR is computed assuming ILO=1 and IHI=N, -C the worst case.) -C - MINWRK = 1 - IF( INFO.EQ.0 .AND. LDWORK.GE.1 ) THEN - MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) - MINWRK = MAX( 1, 4*N ) - MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* - $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) - MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) - K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, - $ N, -1 ) ) ) - HSDWOR = MAX( K*( K+2 ), 2*N ) - MAXWRK = MAX( MAXWRK, N+1, N+HSDWOR ) - MAXWRK = MAX( MAXWRK, 4*N ) - DWORK( 1 ) = MAXWRK - END IF - IF( LDWORK.LT.MINWRK ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB05MY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Get machine constants. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SQRT( SMLNUM ) / EPS - BIGNUM = ONE / SMLNUM -C -C Scale A if max element outside range [SMLNUM,BIGNUM]. -C - 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 ) -C -C Balance the matrix, if requested. (Permutation is not possible.) -C (Workspace: need N) -C - IBAL = 1 - CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, DWORK( IBAL ), IERR ) -C -C Reduce to upper Hessenberg form. -C (Workspace: need 3*N, prefer 2*N+N*NB) -C - ITAU = IBAL + N - JWORK = ITAU + N - CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK( ITAU ), DWORK( JWORK ), - $ LDWORK-JWORK+1, IERR ) -C -C Compute right eigenvectors of T. -C Copy Householder vectors to Q. -C - CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) -C -C Generate orthogonal matrix in Q. -C (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) -C - CALL DORGHR( N, ILO, IHI, Q, LDQ, DWORK( ITAU ), DWORK( JWORK ), - $ LDWORK-JWORK+1, IERR ) -C -C Perform QR iteration, accumulating Schur vectors in Q. -C (Workspace: need N+1, prefer N+HSDWOR (see comments) ) -C - JWORK = ITAU - CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, Q, LDQ, - $ DWORK( JWORK ), LDWORK-JWORK+1, INFO ) -C -C If INFO > 0 from DHSEQR, then quit. -C - IF( INFO.GT.0 ) - $ GO TO 10 -C -C Compute right eigenvectors of T in R. -C (Workspace: need 4*N) -C - CALL DTREVC( 'Right', 'All', SELECT, N, A, LDA, DUM, 1, R, LDR, N, - $ NOUT, DWORK( JWORK ), IERR ) -C -C Undo scaling if necessary. -C - 10 CONTINUE - IF( SCALEA ) THEN - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), - $ MAX( N-INFO, 1 ), IERR ) - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), - $ MAX( N-INFO, 1 ), IERR ) - IF( INFO.GT.0 ) THEN - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, - $ IERR ) - CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, - $ IERR ) - END IF - END IF -C - IF ( SCALE ) THEN - DO 20 K = N, 1, -1 - DWORK( K+1 ) = DWORK( K ) - 20 CONTINUE - END IF - DWORK( 1 ) = MAXWRK -C - RETURN -C *** Last line of MB05MY *** - END diff --git a/slycot/src/MB05ND.f b/slycot/src/MB05ND.f deleted file mode 100644 index 37bbe61a..00000000 --- a/slycot/src/MB05ND.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute -C -C (a) F(delta) = exp(A*delta) and -C -C (b) H(delta) = Int[F(s) ds] from s = 0 to s = delta, -C -C where A is a real N-by-N matrix and delta is a scalar value. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C DELTA (input) DOUBLE PRECISION -C The scalar value delta of the problem. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A of the problem. (Array A need not be set if -C DELTA = 0.) -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,N). -C -C EX (output) DOUBLE PRECISION array, dimension (LDEX,N) -C The leading N-by-N part of this array contains an -C approximation to F(delta). -C -C LDEX INTEGER -C The leading dimension of array EX. LDEX >= MAX(1,N). -C -C EXINT (output) DOUBLE PRECISION array, dimension (LDEXIN,N) -C The leading N-by-N part of this array contains an -C approximation to H(delta). -C -C LDEXIN INTEGER -C The leading dimension of array EXINT. LDEXIN >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the order of the -C Pade approximation to H(t), where t is a scale factor -C determined by the routine. A reasonable value for TOL may -C be SQRT(EPS), where EPS is the machine precision (see -C LAPACK Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N*(N+1)). -C For optimum performance LDWORK should be larger (2*N*N). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the (i,i) element of the denominator of -C the Pade approximation is zero, so the denominator -C is exactly singular; -C = N+1: if DELTA = (delta * frobenius norm of matrix A) is -C probably too large to permit meaningful computation. -C That is, DELTA > SQRT(BIG), where BIG is a -C representable number near the overflow threshold of -C the machine (see LAPACK Library Routine DLAMCH). -C -C METHOD -C -C This routine uses a Pade approximation to H(t) for some small -C value of t (where 0 < t <= delta) and then calculates F(t) from -C H(t). Finally, the results are re-scaled to give F(delta) and -C H(delta). For a detailed description of the implementation of this -C algorithm see [1]. -C -C REFERENCES -C -C [1] Benson, C.J. -C The numerical evaluation of the matrix exponential and its -C integral. -C Report 82/03, Control Systems Research Group, -C School of Electronic Engineering and Computer -C Science, Kingston Polytechnic, January 1982. -C -C [2] Ward, R.C. -C Numerical computation of the matrix exponential with accuracy -C estimate. -C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. -C -C [3] Moler, C.B. and Van Loan, C.F. -C Nineteen Dubious Ways to Compute the Exponential of a Matrix. -C SIAM Rev., 20, pp. 801-836, 1978. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine MB05BD by C.J. Benson, Kingston -C Polytechnic, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Continuous-time system, matrix algebra, matrix exponential, -C matrix operations, Pade approximation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, ONE64, THREE, FOUR8 - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ ONE64 = 1.64D0, THREE = 3.0D0, FOUR8 = 4.8D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDEX, LDEXIN, LDWORK, N - DOUBLE PRECISION DELTA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), EX(LDEX,*), EXINT(LDEXIN,*) -C .. Local Scalars .. - INTEGER I, I2IQ1, IJ, IQ, J, JSCAL, KK, L, NN - DOUBLE PRECISION COEFFD, COEFFN, DELSC, EPS, ERR, F2IQ1, - $ FNORM, FNORM2, QMAX, SMALL -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGESV, DLACPY, - $ DLASET, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, EXP, MAX, MOD, SQRT -C .. Executable Statements .. -C - INFO = 0 - NN = N*N -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDEX.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDEXIN.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDWORK.LT.MAX( 1, NN + N ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB05ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, EX, LDEX ) - CALL DLASET( 'Full', N, N, ZERO, ZERO, EXINT, LDEXIN ) -C - IF ( DELTA.EQ.ZERO ) THEN - CALL DLASET( 'Upper', N, N, ZERO, ONE, EX, LDEX ) - RETURN - END IF -C - IF ( N.EQ.1 ) THEN - EX(1,1) = EXP( DELTA*A(1,1) ) - IF ( A(1,1).EQ.ZERO ) THEN - EXINT(1,1) = DELTA - ELSE - EXINT(1,1) = ( ( ONE/A(1,1) )*EX(1,1) ) - ( ONE/A(1,1) ) - END IF - RETURN - END IF -C -C Set some machine parameters. -C - EPS = DLAMCH( 'Epsilon' ) - SMALL = DLAMCH( 'Safe minimum' )/EPS -C -C First calculate the Frobenius norm of A, and the scaling factor. -C - FNORM = DELTA*DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) -C - IF ( FNORM.GT.SQRT( ONE/SMALL ) ) THEN - INFO = N + 1 - RETURN - END IF -C - JSCAL = 0 - DELSC = DELTA -C WHILE ( FNORM >= HALF ) DO - 20 CONTINUE - IF ( FNORM.GE.HALF ) THEN - JSCAL = JSCAL + 1 - DELSC = DELSC*HALF - FNORM = FNORM*HALF - GO TO 20 - END IF -C END WHILE 20 -C -C Calculate the order of the Pade approximation needed to satisfy -C the requested relative error TOL. -C - FNORM2 = FNORM**2 - IQ = 1 - QMAX = FNORM/THREE - ERR = DELTA/DELSC*FNORM2**2/FOUR8 -C WHILE ( ERR > TOL*( 2*IQ + 3 - FNORM )/1.64 and QMAX >= EPS ) DO - 40 CONTINUE - IF ( ERR.GT.TOL*( DBLE( 2*IQ + 3 ) - FNORM )/ONE64 ) THEN - IQ = IQ + 1 - QMAX = QMAX*DBLE( IQ + 1 )*FNORM/DBLE( 2*IQ*( 2*IQ + 1 ) ) - IF ( QMAX.GE.EPS ) THEN - ERR = ERR*FNORM2*DBLE( 2*IQ + 5 )/DBLE( ( 2*IQ + 3 )**2 - $ *( 2*IQ + 4 ) ) - GO TO 40 - END IF - END IF -C END WHILE 40 -C -C Initialise DWORK (to contain succesive powers of A), -C EXINT (to contain the numerator) and -C EX (to contain the denominator). -C - I2IQ1 = 2*IQ + 1 - F2IQ1 = DBLE( I2IQ1 ) - COEFFD = -DBLE( IQ )/F2IQ1 - COEFFN = HALF/F2IQ1 - IJ = 1 -C - DO 80 J = 1, N -C - DO 60 I = 1, N - DWORK(IJ) = DELSC*A(I,J) - EXINT(I,J) = COEFFN*DWORK(IJ) - EX(I,J) = COEFFD*DWORK(IJ) - IJ = IJ + 1 - 60 CONTINUE -C - EXINT(J,J) = EXINT(J,J) + ONE - EX(J,J) = EX(J,J) + ONE - 80 CONTINUE -C - DO 140 KK = 2, IQ -C -C Calculate the next power of A*DELSC, and update the numerator -C and denominator. -C - COEFFD = -COEFFD*DBLE( IQ+1-KK )/DBLE( KK*( I2IQ1+1-KK ) ) - IF ( MOD( KK, 2 ).EQ.0 ) THEN - COEFFN = COEFFD/DBLE( KK + 1 ) - ELSE - COEFFN = -COEFFD/DBLE( I2IQ1 - KK ) - END IF - IJ = 1 -C - IF ( LDWORK.GE.2*NN ) THEN -C -C Enough space for a BLAS 3 calculation. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, DELSC, - $ A, LDA, DWORK, N, ZERO, DWORK(NN+1), N ) - CALL DCOPY( NN, DWORK(NN+1), 1, DWORK, 1 ) -C - DO 100 J = 1, N - CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) - CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) - IJ = IJ + N - 100 CONTINUE -C - ELSE -C -C Not enough space for a BLAS 3 calculation. Use BLAS 2. -C - DO 120 J = 1, N - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, DWORK(IJ), - $ 1, ZERO, DWORK(NN+1), 1 ) - CALL DCOPY( N, DWORK(NN+1), 1, DWORK(IJ), 1 ) - CALL DSCAL( N, DELSC, DWORK(IJ), 1 ) - CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) - CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) - IJ = IJ + N - 120 CONTINUE -C - END IF - 140 CONTINUE -C -C We now have numerator in EXINT, denominator in EX. -C -C Solve the set of N systems of linear equations for the columns of -C EXINT using the LU factorization of EX. -C - CALL DGESV( N, N, EX, LDEX, IWORK, EXINT, LDEXIN, INFO ) - IF ( INFO.NE.0 ) - $ RETURN -C -C Now we can form EX from EXINT using the formula: -C EX = EXINT * A + I -C - DO 160 J = 1, N - CALL DSCAL( N, DELSC, EXINT(1,J), 1 ) - 160 CONTINUE -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, EXINT, - $ LDEXIN, A, LDA, ZERO, EX, LDEX ) -C - DO 180 J = 1, N - EX(J,J) = EX(J,J) + ONE - 180 CONTINUE -C -C EX and EXINT have been evaluated at DELSC, so the results -C must be re-scaled to give the function values at DELTA. -C -C EXINT(2t) = EXINT(t) * ^ EX(t) + I [ -C EX(2t) = EX(t) * EX(t) -C -C DWORK is used to accumulate products. -C - DO 200 L = 1, JSCAL - CALL DLACPY( 'Full', N, N, EXINT, LDEXIN, DWORK, N ) - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ DWORK, N, EX, LDEX, ONE, EXINT, LDEXIN ) - CALL DLACPY( 'Full', N, N, EX, LDEX, DWORK, N ) - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ DWORK, N, DWORK, N, ZERO, EX, LDEX ) - 200 CONTINUE -C - DWORK(1) = 2*NN - RETURN -C *** Last line of MB05ND *** - END diff --git a/slycot/src/MB05OD.f b/slycot/src/MB05OD.f deleted file mode 100644 index ec87a2ee..00000000 --- a/slycot/src/MB05OD.f +++ /dev/null @@ -1,574 +0,0 @@ - SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute exp(A*delta) where A is a real N-by-N matrix and delta -C is a scalar value. The routine also returns the minimal number of -C accurate digits in the 1-norm of exp(A*delta) and the number of -C accurate digits in the 1-norm of exp(A*delta) at 95% confidence -C level. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALANC CHARACTER*1 -C Specifies whether or not a balancing transformation (done -C by SLICOT Library routine MB04MD) is required, as follows: -C = 'N', do not use balancing; -C = 'S', use balancing (scaling). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C NDIAG (input) INTEGER -C The specified order of the diagonal Pade approximant. -C In the absence of further information NDIAG should -C be set to 9. NDIAG should not exceed 15. NDIAG >= 1. -C -C DELTA (input) DOUBLE PRECISION -C The scalar value delta of the problem. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On input, the leading N-by-N part of this array must -C contain the matrix A of the problem. (This is not needed -C if DELTA = 0.) -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains the solution matrix exp(A*delta). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C MDIG (output) INTEGER -C The minimal number of accurate digits in the 1-norm of -C exp(A*delta). -C -C IDIG (output) INTEGER -C The number of accurate digits in the 1-norm of -C exp(A*delta) at 95% confidence level. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N > 1. -C LDWORK >= 1, if N <= 1. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: if MDIG = 0 and IDIG > 0, warning for possible -C inaccuracy (the exponential has been computed); -C = 2: if MDIG = 0 and IDIG = 0, warning for severe -C inaccuracy (the exponential has been computed); -C = 3: if balancing has been requested, but it failed to -C reduce the matrix norm and was not actually used. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the norm of matrix A*delta (after a possible -C balancing) is too large to obtain an accurate -C result; -C = 2: if the coefficient matrix (the denominator of the -C Pade approximant) is exactly singular; try a -C different value of NDIAG; -C = 3: if the solution exponential would overflow, possibly -C due to a too large value DELTA; the calculations -C stopped prematurely. This error is not likely to -C appear. -C -C METHOD -C -C The exponential of the matrix A is evaluated from a diagonal Pade -C approximant. This routine is a modification of the subroutine -C PADE, described in reference [1]. The routine implements an -C algorithm which exploits the identity -C -C (exp[(2**-m)*A]) ** (2**m) = exp(A), -C -C where m is an integer determined by the algorithm, to improve the -C accuracy for matrices with large norms. -C -C REFERENCES -C -C [1] Ward, R.C. -C Numerical computation of the matrix exponential with accuracy -C estimate. -C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05CD by T.W.C. Williams, Kingston -C Polytechnic, March 1982. -C -C REVISIONS -C -C June 14, 1997, April 25, 2003, December 12, 2004. -C -C KEYWORDS -C -C Continuous-time system, matrix algebra, matrix exponential, -C matrix operations, Pade approximation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, EIGHT, TEN, TWELVE, - $ NINTEN, TWO4, FOUR7, TWOHND - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, - $ TEN = 10.0D0, TWELVE = 12.0D0, - $ NINTEN = 19.0D0, TWO4 = 24.0D0, - $ FOUR7 = 47.0D0, TWOHND = 200.0D0 ) -C .. Scalar Arguments .. - CHARACTER BALANC - INTEGER IDIG, INFO, IWARN, LDA, LDWORK, MDIG, N, - $ NDIAG - DOUBLE PRECISION DELTA -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LBALS - CHARACTER ACTBAL - INTEGER BASE, I, IFAIL, IJ, IK, IM1, J, JWORA1, JWORA2, - $ JWORA3, JWORV1, JWORV2, K, M, MPOWER, NDAGM1, - $ NDAGM2, NDEC, NDECM1 - DOUBLE PRECISION ANORM, AVGEV, BD, BIG, EABS, EAVGEV, EMNORM, - $ EPS, FACTOR, FN, GN, MAXRED, OVRTH2, OVRTHR, P, - $ RERL, RERR, S, SD2, SIZE, SMALL, SS, SUM2D, - $ TEMP, TMP1, TR, U, UNDERF, VAR, VAREPS, XN -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2 - EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, - $ DLASCL, DLASET, DSCAL, MB04MD, MB05OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, EXP, INT, LOG, LOG10, MAX, MIN, MOD, SQRT -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - LBALS = LSAME( BALANC, 'S' ) -C -C Test the input scalar arguments. -C - IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LBALS ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NDIAG.LT.1 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDWORK.LT.1 .OR. - $ ( LDWORK.LT.N*( 2*N + NDIAG + 1 ) + NDIAG .AND. N.GT.1 ) - $ ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB05OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - EPS = DLAMCH( 'Epsilon' ) - NDEC = INT( LOG10( ONE/EPS ) + ONE ) -C - IF ( N.EQ.0 ) THEN - MDIG = NDEC - IDIG = NDEC - RETURN - END IF -C -C Set some machine parameters. -C - BASE = DLAMCH( 'Base' ) - NDECM1 = NDEC - 1 - UNDERF = DLAMCH( 'Underflow' ) - OVRTHR = DLAMCH( 'Overflow' ) - OVRTH2 = SQRT( OVRTHR ) -C - IF ( DELTA.EQ.ZERO ) THEN -C -C The DELTA = 0 case. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, A, LDA ) - MDIG = NDECM1 - IDIG = NDECM1 - RETURN - END IF -C - IF ( N.EQ.1 ) THEN -C -C The 1-by-1 case. -C - A(1,1) = EXP( A(1,1)*DELTA ) - MDIG = NDECM1 - IDIG = NDECM1 - RETURN - END IF -C -C Set pointers for the workspace. -C - JWORA1 = 1 - JWORA2 = JWORA1 + N*N - JWORA3 = JWORA2 + N*NDIAG - JWORV1 = JWORA3 + N*N - JWORV2 = JWORV1 + N -C -C Compute Pade coefficients in DWORK(JWORV2:JWORV2+NDIAG-1). -C - DWORK(JWORV2) = HALF -C - DO 20 I = 2, NDIAG - IM1 = I - 1 - DWORK(JWORV2+IM1) = DWORK(JWORV2+I-2)*DBLE( NDIAG - IM1 )/ - $ DBLE( I*( 2*NDIAG - IM1 ) ) - 20 CONTINUE -C - VAREPS = EPS**2*( ( DBLE( BASE )**2 - ONE )/ - $ ( TWO4*LOG( DBLE( BASE ) ) ) ) - XN = DBLE( N ) - TR = ZERO -C -C Apply a translation with the mean of the eigenvalues of A*DELTA. -C - DO 40 I = 1, N - CALL DSCAL( N, DELTA, A(1,I), 1 ) - TR = TR + A(I,I) - 40 CONTINUE -C - AVGEV = TR/XN - IF ( AVGEV.GT.LOG( OVRTHR ) .OR. AVGEV.LT.LOG( UNDERF ) ) - $ AVGEV = ZERO - IF ( AVGEV.NE.ZERO ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) -C - DO 60 I = 1, N - A(I,I) = A(I,I) - AVGEV - 60 CONTINUE -C - TEMP = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - IF ( TEMP.GT.HALF*ANORM ) THEN -C - DO 80 I = 1, N - A(I,I) = A(I,I) + AVGEV - 80 CONTINUE -C - AVGEV = ZERO - END IF - END IF - ACTBAL = BALANC - IF ( LBALS ) THEN -C -C Balancing (scaling) has been requested. First, save A. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(JWORA1), N ) - MAXRED = TWOHND - CALL MB04MD( N, MAXRED, A, LDA, DWORK(JWORV1), INFO ) - IF ( MAXRED.LT.ONE ) THEN -C -C Recover the matrix and reset DWORK(JWORV1,...,JWORV1+N-1) -C to 1, as no reduction of the norm occured (unlikely event). -C - CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) - ACTBAL = 'N' - DWORK(JWORV1) = ONE - CALL DCOPY( N-1, DWORK(JWORV1), 0, DWORK(JWORV1+1), 1 ) - IWARN = 3 - END IF - END IF -C -C Scale the matrix by 2**(-M), where M is the minimum integer -C so that the resulted matrix has the 1-norm less than 0.5. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - M = 0 - IF ( ANORM.GE.HALF ) THEN - MPOWER = INT( LOG( OVRTHR )/LOG( TWO ) ) - M = INT( LOG( ANORM )/LOG( TWO ) ) + 1 - IF ( M.GT.MPOWER ) THEN -C -C Error return: The norm of A*DELTA is too large. -C - INFO = 1 - RETURN - END IF - FACTOR = TWO**M - IF ( M+1.LT.MPOWER ) THEN - M = M + 1 - FACTOR = FACTOR*TWO - END IF -C - DO 120 I = 1, N - CALL DSCAL( N, ONE/FACTOR, A(1,I), 1 ) - 120 CONTINUE -C - END IF - NDAGM1 = NDIAG - 1 - NDAGM2 = NDAGM1 - 1 - IJ = 0 -C -C Compute the factors of the diagonal Pade approximant. -C The loop 200 takes the accuracy requirements into account: -C Pade coefficients decrease with K, so the calculations should -C be performed in backward order, one column at a time. -C (A BLAS 3 implementation in forward order, using DGEMM, could -C possibly be less accurate.) -C - DO 200 J = 1, N - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, A(1,J), 1, ZERO, - $ DWORK(JWORA2), 1 ) - IK = 0 -C - DO 140 K = 1, NDAGM2 - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK(JWORA2+IK), 1, ZERO, DWORK(JWORA2+IK+N), - $ 1 ) - IK = IK + N - 140 CONTINUE -C - DO 180 I = 1, N - S = ZERO - U = ZERO - IK = NDAGM2*N + I - 1 -C - DO 160 K = NDAGM1, 1, -1 - P = DWORK(JWORV2+K)*DWORK(JWORA2+IK) - IK = IK - N - S = S + P - IF ( MOD( K+1, 2 ).EQ.0 ) THEN - U = U + P - ELSE - U = U - P - END IF - 160 CONTINUE -C - P = DWORK(JWORV2)*A(I,J) - S = S + P - U = U - P - IF ( I.EQ.J ) THEN - S = S + ONE - U = U + ONE - END IF - DWORK(JWORA3+IJ) = S - DWORK(JWORA1+IJ) = U - IJ = IJ + 1 - 180 CONTINUE -C - 200 CONTINUE -C -C Compute the exponential of the scaled matrix, using diagonal Pade -C approximants. As, in theory [1], the denominator of the Pade -C approximant should be very well conditioned, no condition estimate -C is computed. -C - CALL DGETRF( N, N, DWORK(JWORA1), N, IWORK, IFAIL ) - IF ( IFAIL.GT.0 ) THEN -C -C Error return: The matrix is exactly singular. -C - INFO = 2 - RETURN - END IF -C - CALL DLACPY( 'Full', N, N, DWORK(JWORA3), N, A, LDA ) - CALL DGETRS( 'No transpose', N, N, DWORK(JWORA1), N, IWORK, A, - $ LDA, IFAIL ) -C -C Prepare for the calculation of the accuracy estimates. -C Note that ANORM here is in the range [1, e]. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - IF ( ANORM.GE.ONE ) THEN - EABS = ( NINTEN*XN + FOUR7 )*( EPS*ANORM ) - ELSE - EABS = ( ( NINTEN*XN + FOUR7 )*EPS )*ANORM - END IF - IF ( M.NE.0 ) THEN - VAR = XN*VAREPS - FN = ( FOUR*XN )/( ( XN + TWO )*( XN + ONE ) ) - GN = ( ( TWO*XN + TEN )*XN - FOUR )/( ( ( XN + TWO )**2 ) - $ *( ( XN + ONE )**2 ) ) -C -C Square-up the computed exponential matrix M times, with caution -C for avoiding overflows. -C - DO 220 K = 1, M - IF ( ANORM.GT.OVRTH2 ) THEN -C -C The solution could overflow. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, - $ ONE/ANORM, A, LDA, A, LDA, ZERO, - $ DWORK(JWORA1), N ) - S = DLANGE( '1-norm', N, N, DWORK(JWORA1), N, - $ DWORK(JWORA1) ) - IF ( ANORM.LE.OVRTHR/S ) THEN - CALL DLASCL( 'General', N, N, ONE, ANORM, N, N, - $ DWORK(JWORA1), N, INFO ) - TEMP = OVRTHR - ELSE -C -C Error return: The solution would overflow. -C This will not happen on most machines, due to the -C selection of M. -C - INFO = 3 - RETURN - END IF - ELSE - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ A, LDA, A, LDA, ZERO, DWORK(JWORA1), N ) - TEMP = ANORM**2 - END IF - IF ( EABS.LT.ONE ) THEN - EABS = ( TWO*ANORM + EABS )*EABS + XN*( EPS*TEMP ) - ELSE IF ( EABS.LT.SQRT( ONE - XN*EPS + OVRTHR/TEMP )*ANORM - - $ ANORM ) THEN - EABS = XN*( EPS*TEMP ) + TWO*( ANORM*EABS ) + EABS**2 - ELSE - EABS = OVRTHR - END IF -C - TMP1 = FN*VAR + GN*( TEMP*VAREPS ) - IF ( TMP1.GT.OVRTHR/TEMP ) THEN - VAR = OVRTHR - ELSE - VAR = TMP1*TEMP - END IF -C - CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) - 220 CONTINUE -C - ELSE - VAR = ( TWELVE*XN )*VAREPS - END IF -C -C Apply back transformations, if balancing was effectively used. -C - CALL MB05OY( ACTBAL, N, 1, N, A, LDA, DWORK(JWORV1), INFO ) - EAVGEV = EXP( AVGEV ) - EMNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) -C -C Compute auxiliary quantities needed for the accuracy estimates. -C - BIG = ONE - SMALL = ONE - IF ( LBALS ) THEN -C -C Compute norms of the diagonal scaling matrix and its inverse. -C - DO 240 I = 1, N - U = DWORK(JWORV1+I-1) - IF ( BIG.LT.U ) BIG = U - IF ( SMALL.GT.U ) SMALL = U - 240 CONTINUE -C - SUM2D = DNRM2( N, DWORK(JWORV1), 1 ) - ELSE - SUM2D = SQRT( XN ) - END IF -C -C Update the exponential for the initial translation, and update the -C auxiliary quantities needed for the accuracy estimates. -C - SD2 = SQRT( EIGHT*XN*VAREPS )*ANORM - BD = SQRT( VAR ) - SS = MAX( BD, SD2 ) - BD = MIN( BD, SD2 ) - SD2 = SS*SQRT( ONE + ( BD/SS )**2 ) - IF ( SD2.LE.ONE ) THEN - SD2 = ( TWO/XN )*SUM2D*SD2 - ELSE IF ( SUM2D/XN.LT.OVRTHR/TWO/SD2 ) THEN - SD2 = ( TWO/XN )*SUM2D*SD2 - ELSE - SD2 = OVRTHR - END IF - IF ( LBALS ) THEN - SIZE = ZERO - ELSE - IF ( SD2.LT.OVRTHR - EMNORM ) THEN - SIZE = EMNORM + SD2 - ELSE - SIZE = OVRTHR - END IF - END IF -C - DO 260 J = 1, N - SS = DASUM( N, A(1,J), 1 ) - CALL DSCAL( N, EAVGEV, A(1,J), 1 ) - IF ( LBALS ) THEN - BD = DWORK(JWORV1+J-1) - SIZE = MAX( SIZE, SS + SD2/BD ) - END IF - 260 CONTINUE -C -C Set the accuracy estimates and warning errors, if any. -C - RERR = LOG10( BIG ) + LOG10( EABS ) - LOG10( SMALL ) - - $ LOG10( EMNORM ) - LOG10( EPS ) - IF ( SIZE.GT.EMNORM ) THEN - RERL = LOG10( ( SIZE/EMNORM - ONE )/EPS ) - ELSE - RERL = ZERO - END IF - MDIG = MIN( NDEC - INT( RERR + HALF ), NDECM1 ) - IDIG = MIN( NDEC - INT( RERL + HALF ), NDECM1 ) -C - IF ( MDIG.LE.0 ) THEN - MDIG = 0 - IWARN = 1 - END IF - IF ( IDIG.LE.0 ) THEN - IDIG = 0 - IWARN = 2 - END IF -C - RETURN -C *** Last line of MB05OD *** - END diff --git a/slycot/src/MB05OY.f b/slycot/src/MB05OY.f deleted file mode 100644 index a73de703..00000000 --- a/slycot/src/MB05OY.f +++ /dev/null @@ -1,179 +0,0 @@ - SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To restore a matrix after it has been transformed by applying -C balancing transformations (permutations and scalings), as -C determined by LAPACK Library routine DGEBAL. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the type of backward transformation required, -C as follows: -C = 'N', do nothing, return immediately; -C = 'P', do backward transformation for permutation only; -C = 'S', do backward transformation for scaling only; -C = 'B', do backward transformations for both permutation -C and scaling. -C JOB must be the same as the argument JOB supplied -C to DGEBAL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C LOW (input) INTEGER -C IGH (input) INTEGER -C The integers LOW and IGH determined by DGEBAL. -C 1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if N=0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix to be back-transformed. -C On exit, the leading N-by-N part of this array contains -C the transformed matrix. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C SCALE (input) DOUBLE PRECISION array, dimension (N) -C Details of the permutation and scaling factors, as -C returned by DGEBAL. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Let P be a permutation matrix, and D a diagonal matrix of scaling -C factors, both of order N. The routine computes -C -1 -C A <-- P D A D P'. -C -C where the permutation and scaling factors are encoded in the -C array SCALE. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires O(N ) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. -C Supersedes Release 2.0 routine MB05CY. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER IGH, INFO, LDA, LOW, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), SCALE(*) -C .. Local Scalars .. - INTEGER I, II, J, K -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DSCAL, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - 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( LOW.LT.1 .OR. LOW.GT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( IGH.LT.MIN( LOW, N ) .OR. IGH.GT.N ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB05OY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. LSAME( JOB, 'N' ) ) - $ RETURN -C - IF ( .NOT.LSAME( JOB, 'P' ) .AND. IGH.NE.LOW ) THEN -C - DO 20 I = LOW, IGH - CALL DSCAL( N, SCALE(I), A(I,1), LDA ) - 20 CONTINUE -C - DO 40 J = LOW, IGH - CALL DSCAL( N, ONE/SCALE(J), A(1,J), 1 ) - 40 CONTINUE -C - END IF -C - IF( .NOT.LSAME( JOB, 'S' ) ) THEN -C - DO 60 II = 1, N - I = II - IF ( I.LT.LOW .OR. I.GT.IGH ) THEN - IF ( I.LT.LOW ) I = LOW - II - K = SCALE(I) - IF ( K.NE.I ) THEN - CALL DSWAP( N, A(I,1), LDA, A(K,1), LDA ) - CALL DSWAP( N, A(1,I), 1, A(1,K), 1 ) - END IF - END IF - 60 CONTINUE -C - END IF -C - RETURN -C *** Last line of MB05OY *** - END diff --git a/slycot/src/MB3OYZ.f b/slycot/src/MB3OYZ.f deleted file mode 100644 index 054e570a..00000000 --- a/slycot/src/MB3OYZ.f +++ /dev/null @@ -1,395 +0,0 @@ - SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing QR factorization of a complex general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated QR factorization with column pivoting -C [ R11 R12 ] -C A * P = Q * R, where R = [ ], -C [ 0 R22 ] -C with R11 defined as the largest leading upper triangular submatrix -C whose estimated condition number is less than 1/RCOND. The order -C of R11, RANK, is the effective rank of A. Condition estimation is -C performed during the QR factorization process. Matrix R22 is full -C (but of small norm), or empty. -C -C MB3OYZ does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the leading RANK-by-RANK upper triangular part -C of A contains the triangular factor R11, and the elements -C below the diagonal in the first RANK columns, with the -C array TAU, represent the unitary matrix Q as a product -C of RANK elementary reflectors. -C The remaining N-RANK columns contain the result of the -C QR factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest leading triangular -C submatrix R11 in the QR factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R11. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of R(1:RANK,1:RANK); -C SVAL(2): smallest singular value of R(1:RANK,1:RANK); -C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), -C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), -C otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the leading columns were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(1:RANK,1:RANK). -C -C JPVT (output) INTEGER array, dimension ( N ) -C If JPVT(i) = k, then the i-th column of A*P was the k-th -C column of A. -C -C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) -C The leading RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 2*N ) -C -C ZWORK COMPLEX*16 array, dimension ( 3*N-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of A, A * P = Q * R, with R defined above, and, -C during this process, finds the largest leading submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using the LAPACK incremental condition estimation scheme and a -C slightly modified rank decision test. The factorization process -C stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a complex scalar, and v is a complex vector with -C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in -C A(i+1:m,i), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth column of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, unitary transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) - COMPLEX*16 CZERO, CONE - PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), - $ CONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) - DOUBLE PRECISION DWORK( * ), SVAL( 3 ) -C .. -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT - COMPLEX*16 AII, C1, C2, S1, S2 - DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DZNRM2 - EXTERNAL DZNRM2, IDAMAX -C .. External Subroutines .. - EXTERNAL XERBLA, ZLAIC1, ZLARF, ZLARFG, ZSCAL, ZSWAP -C .. Intrinsic Functions .. - INTRINSIC ABS, DCONJG, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - 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( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB3OYZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - MN = MIN( M, N ) - IF( MN.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = 1 - ISMAX = ISMIN + N -C -C Initialize partial column norms and pivoting vector. The first n -C elements of DWORK store the exact column norms. -C - DO 10 I = 1, N - DWORK( I ) = DZNRM2( M, A( 1, I ), 1 ) - DWORK( N+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.MN ) THEN - I = RANK + 1 -C -C Determine ith pivot column and swap if necessary. -C - PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) -C - 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 - DWORK( PVT ) = DWORK( I ) - DWORK( N+PVT ) = DWORK( N+I ) - END IF -C -C Save A(I,I) and generate elementary reflector H(i) -C such that H(i)'*[A(i,i);*] = [*;0]. -C - IF( I.LT.M ) THEN - AII = A( I, I ) - CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) - ELSE - TAU( M ) = CZERO - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( 1, 1 ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = CONE - C2 = CONE - ELSE -C -C One step of incremental condition estimation. -C - CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, A( 1, I ), - $ A( I, I ), SMINPR, S1, C1 ) - CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, A( 1, I ), - $ A( I, I ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Continue factorization, as rank is at least RANK. -C - IF( I.LT.N ) THEN -C -C Apply H(i)' to A(i:m,i+1:n) from the left. -C - AII = A( I, I ) - A( I, I ) = CONE - CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, - $ ZWORK( 2*N+1 ) ) - A( I, I ) = AII - END IF -C -C Update partial column norms. -C - DO 30 J = I + 1, N - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( N+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - IF( M-I.GT.0 ) THEN - DWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) - DWORK( N+J ) = DWORK( J ) - ELSE - DWORK( J ) = ZERO - DWORK( N+J ) = ZERO - END IF - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - DO 40 I = 1, RANK - ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) - ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) - 40 CONTINUE -C - ZWORK( ISMIN+RANK ) = C1 - ZWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (RANK+1)-th column and set SVAL. -C - IF ( RANK.LT.N ) THEN - IF ( I.LT.M ) THEN - CALL ZSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = AII - END IF - END IF - IF ( RANK.EQ.0 ) THEN - SMIN = ZERO - SMINPR = ZERO - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB3OYZ *** - END diff --git a/slycot/src/MB3PYZ.f b/slycot/src/MB3PYZ.f deleted file mode 100644 index 119bca08..00000000 --- a/slycot/src/MB3PYZ.f +++ /dev/null @@ -1,398 +0,0 @@ - SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, - $ TAU, DWORK, ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a rank-revealing RQ factorization of a complex general -C M-by-N matrix A, which may be rank-deficient, and estimate its -C effective rank using incremental condition estimation. -C -C The routine uses a truncated RQ factorization with row pivoting: -C [ R11 R12 ] -C P * A = R * Q, where R = [ ], -C [ 0 R22 ] -C with R22 defined as the largest trailing upper triangular -C submatrix whose estimated condition number is less than 1/RCOND. -C The order of R22, RANK, is the effective rank of A. Condition -C estimation is performed during the RQ factorization process. -C Matrix R11 is full (but of small norm), or empty. -C -C MB3PYZ does not perform any scaling of the matrix A. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) -C On entry, the leading M-by-N part of this array must -C contain the given matrix A. -C On exit, the upper triangle of the subarray -C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper -C triangular matrix R22; the remaining elements in the last -C RANK rows, with the array TAU, represent the unitary -C matrix Q as a product of RANK elementary reflectors -C (see METHOD). The first M-RANK rows contain the result -C of the RQ factorization process used. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C RCOND (input) DOUBLE PRECISION -C RCOND is used to determine the effective rank of A, which -C is defined as the order of the largest trailing triangular -C submatrix R22 in the RQ factorization with pivoting of A, -C whose estimated condition number is less than 1/RCOND. -C 0 <= RCOND <= 1. -C NOTE that when SVLMAX > 0, the estimated rank could be -C less than that defined above (see SVLMAX). -C -C SVLMAX (input) DOUBLE PRECISION -C If A is a submatrix of another matrix B, and the rank -C decision should be related to that matrix, then SVLMAX -C should be an estimate of the largest singular value of B -C (for instance, the Frobenius norm of B). If this is not -C the case, the input value SVLMAX = 0 should work. -C SVLMAX >= 0. -C -C RANK (output) INTEGER -C The effective (estimated) rank of A, i.e., the order of -C the submatrix R22. -C -C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) -C The estimates of some of the singular values of the -C triangular factor R: -C SVAL(1): largest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(2): smallest singular value of -C R(M-RANK+1:M,N-RANK+1:N); -C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), -C if RANK < MIN( M, N ), or of -C R(M-RANK+1:M,N-RANK+1:N), otherwise. -C If the triangular factorization is a rank-revealing one -C (which will be the case if the trailing rows were well- -C conditioned), then SVAL(1) will also be an estimate for -C the largest singular value of A, and SVAL(2) and SVAL(3) -C will be estimates for the RANK-th and (RANK+1)-st singular -C values of A, respectively. -C By examining these values, one can confirm that the rank -C is well defined with respect to the chosen value of RCOND. -C The ratio SVAL(1)/SVAL(2) is an estimate of the condition -C number of R(M-RANK+1:M,N-RANK+1:N). -C -C JPVT (output) INTEGER array, dimension ( M ) -C If JPVT(i) = k, then the i-th row of P*A was the k-th row -C of A. -C -C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) -C The trailing RANK elements of TAU contain the scalar -C factors of the elementary reflectors. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension ( 2*M ) -C -C ZWORK COMPLEX*16 array, dimension ( 3*M-1 ) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated RQ factorization with row -C pivoting of A, P * A = R * Q, with R defined above, and, -C during this process, finds the largest trailing submatrix whose -C estimated condition number is less than 1/RCOND, taking the -C possible positive value of SVLMAX into account. This is performed -C using an adaptation of the LAPACK incremental condition estimation -C scheme and a slightly modified rank decision test. The -C factorization process stops when RANK has been determined. -C -C The matrix Q is represented as a product of elementary reflectors -C -C Q = H(k-rank+1)' H(k-rank+2)' . . . H(k)', where k = min(m,n). -C -C Each H(i) has the form -C -C H = I - tau * v * v' -C -C where tau is a complex scalar, and v is a complex vector with -C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored -C on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). -C -C The matrix P is represented in jpvt as follows: If -C jpvt(j) = i -C then the jth row of P is the ith canonical unit vector. -C -C REFERENCES -C -C [1] Bischof, C.H. and P. Tang. -C Generalizing Incremental Condition Estimation. -C LAPACK Working Notes 32, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-132, -C May 1991. -C -C [2] Bischof, C.H. and P. Tang. -C Robust Incremental Condition Estimation. -C LAPACK Working Notes 33, Mathematics and Computer Science -C Division, Argonne National Laboratory, UT, CS-91-133, -C May 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue problem, matrix operations, unitary transformation, -C singular values. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ZERO, ONE, P05 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, RANK - DOUBLE PRECISION RCOND, SVLMAX -C .. Array Arguments .. - INTEGER JPVT( * ) - COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) - DOUBLE PRECISION DWORK( * ), SVAL( 3 ) -C .. Local Scalars .. - INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, - $ PVT - COMPLEX*16 AII, C1, C2, S1, S2 - DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DZNRM2 - EXTERNAL DZNRM2, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZLACGV, ZLAIC1, ZLARF, ZLARFG, - $ ZSCAL, ZSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - 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( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN - INFO = -5 - ELSE IF( SVLMAX.LT.ZERO ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MB3PYZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - RANK = 0 - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF -C - ISMIN = 1 - ISMAX = ISMIN + M - JWORK = ISMAX + M -C -C Initialize partial row norms and pivoting vector. The first m -C elements of DWORK store the exact row norms. -C - DO 10 I = 1, M - DWORK( I ) = DZNRM2( N, A( I, 1 ), LDA ) - DWORK( M+I ) = DWORK( I ) - JPVT( I ) = I - 10 CONTINUE -C -C Compute factorization and determine RANK using incremental -C condition estimation. -C - RANK = 0 -C - 20 CONTINUE - IF( RANK.LT.K ) THEN - I = K - RANK -C -C Determine ith pivot row and swap if necessary. -C - MKI = M - RANK - NKI = N - RANK - PVT = IDAMAX( MKI, DWORK, 1 ) -C - IF( PVT.NE.MKI ) THEN - CALL ZSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) - ITEMP = JPVT( PVT ) - JPVT( PVT ) = JPVT( MKI ) - JPVT( MKI ) = ITEMP - DWORK( PVT ) = DWORK( MKI ) - DWORK( M+PVT ) = DWORK( M+MKI ) - END IF -C - IF( NKI.GT.1 ) THEN -C -C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) -C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). -C A(m-k+i,1:n-k+i) * H(tau,v) = [0 , *] <=> -C H(conj(tau),v) A(m-k+i,1:n-k+i)^H = [0 ; *], -C using H(tau,v)^H = H(conj(tau),v). -C - CALL ZLACGV( NKI, A( MKI, 1 ), LDA ) - AII = A( MKI, NKI ) - CALL ZLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) - $ ) - END IF -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( A( M, N ) ) - IF ( SMAX.EQ.ZERO ) THEN - SVAL( 1 ) = ZERO - SVAL( 2 ) = ZERO - SVAL( 3 ) = ZERO - RETURN - END IF - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = CONE - C2 = CONE - ELSE -C -C One step of incremental condition estimation. -C - CALL ZCOPY ( RANK, A( MKI, NKI+1 ), LDA, ZWORK( JWORK ), 1 ) - CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, - $ ZWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) - CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, - $ ZWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) - END IF -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C - IF( MKI.GT.1 ) THEN -C -C Continue factorization, as rank is at least RANK. -C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. -C - AII = A( MKI, NKI ) - A( MKI, NKI ) = CONE - CALL ZLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, - $ TAU( I ), A, LDA, ZWORK( JWORK ) ) - A( MKI, NKI ) = AII -C -C Update partial row norms. -C - DO 30 J = 1, MKI - 1 - IF( DWORK( J ).NE.ZERO ) THEN - TEMP = ONE - - $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 - TEMP = MAX( TEMP, ZERO ) - TEMP2 = ONE + P05*TEMP* - $ ( DWORK( J ) / DWORK( M+J ) )**2 - IF( TEMP2.EQ.ONE ) THEN - DWORK( J ) = DZNRM2( NKI-1, A( J, 1 ), - $ LDA ) - DWORK( M+J ) = DWORK( J ) - ELSE - DWORK( J ) = DWORK( J )*SQRT( TEMP ) - END IF - END IF - 30 CONTINUE -C - END IF -C - DO 40 I = 1, RANK - ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) - ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) - 40 CONTINUE -C - ZWORK( ISMIN+RANK ) = C1 - ZWORK( ISMAX+RANK ) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) - GO TO 20 - END IF - END IF - END IF - END IF -C -C Restore the changed part of the (M-RANK)-th row and set SVAL. -C - IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN - CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) - CALL ZSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) - A( MKI, NKI ) = AII - END IF - SVAL( 1 ) = SMAX - SVAL( 2 ) = SMIN - SVAL( 3 ) = SMINPR -C - RETURN -C *** Last line of MB3PYZ *** - END diff --git a/slycot/src/MC01MD.f b/slycot/src/MC01MD.f deleted file mode 100644 index 9da419a9..00000000 --- a/slycot/src/MC01MD.f +++ /dev/null @@ -1,162 +0,0 @@ - SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate, for a given real polynomial P(x) and a real scalar -C alpha, the leading K coefficients of the shifted polynomial -C K-1 -C P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha) + ... -C -C using Horner's algorithm. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar value alpha of the problem. -C -C K (input) INTEGER -C The number of coefficients of the shifted polynomial to be -C computed. 1 <= K <= DP+1. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of P(x) in -C increasing powers of x. -C -C Q (output) DOUBLE PRECISION array, dimension (DP+1) -C The leading K elements of this array contain the first -C K coefficients of the shifted polynomial in increasing -C powers of (x - alpha), and the next (DP-K+1) elements -C are used as internal workspace. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given the real polynomial -C 2 DP -C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , -C -C the routine computes the leading K coefficients of the shifted -C polynomial -C K-1 -C P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha) -C -C as follows. -C -C Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x) -C by (x-alpha), yields -C -C P(x) = q(1) + (x-alpha) * D(x), -C -C where q(1) is the value of the constant term of the shifted -C polynomial and D(x) is the quotient polynomial of degree (DP-1) -C given by -C 2 DP-1 -C D(x) = d(2) + d(3) * x + d(4) * x + ... + d(DP+1) * x . -C -C Applying Horner's algorithm to D(x) and subsequent quotient -C polynomials yields q(2) and q(3), q(4), ..., q(K) respectively. -C -C It follows immediately that q(1) = P(alpha), and in general -C (i-1) -C q(i) = P (alpha) / (i - 1)! for i = 1, 2, ..., K. -C -C REFERENCES -C -C [1] STOER, J. and BULIRSCH, R. -C Introduction to Numerical Analysis. -C Springer-Verlag. 1980. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01AD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, K - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION P(*), Q(*) -C .. Local Scalars .. - INTEGER I, J -C .. External Subroutines .. - EXTERNAL DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( DP.LT.0 ) THEN - INFO = -1 - ELSE IF( K.LE.0 .OR. K.GT.DP+1 ) THEN - INFO = -3 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01MD', -INFO ) - RETURN - END IF -C - CALL DCOPY( DP+1, P, 1, Q, 1 ) - IF ( DP.EQ.0 .OR. ALPHA.EQ.ZERO ) - $ RETURN -C - DO 40 J = 1, K -C - DO 20 I = DP, J, -1 - Q(I) = Q(I) + ALPHA*Q(I+1) - 20 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of MC01MD *** - END diff --git a/slycot/src/MC01ND.f b/slycot/src/MC01ND.f deleted file mode 100644 index b45913fe..00000000 --- a/slycot/src/MC01ND.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the value of the real polynomial P(x) at a given -C complex point x = x0 using Horner's algorithm. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C XR (input) DOUBLE PRECISION -C XI (input) DOUBLE PRECISION -C The real and imaginary parts, respectively, of x0. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of the polynomial -C P(x) in increasing powers of x. -C -C VR (output) DOUBLE PRECISION -C VI (output) DOUBLE PRECISION -C The real and imaginary parts, respectively, of P(x0). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given the real polynomial -C 2 DP -C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , -C -C the routine computes the value of P(x0) using the recursion -C -C q(DP+1) = p(DP+1), -C q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1, -C -C which is known as Horner's algorithm (see [1]). Then q(1) = P(x0). -C -C REFERENCES -C -C [1] STOER, J and BULIRSCH, R. -C Introduction to Numerical Analysis. -C Springer-Verlag. 1980. -C -C NUMERICAL ASPECTS -C -C The algorithm requires DP operations for real arguments and 4*DP -C for complex arguments. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01BD by Serge Steer. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO - DOUBLE PRECISION VI, VR, XI, XR -C .. Array Arguments .. - DOUBLE PRECISION P(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION T -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( DP.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01ND', -INFO ) - RETURN - END IF -C - INFO = 0 - VR = P(DP+1) - VI = ZERO -C - IF ( DP.EQ.0 ) - $ RETURN -C - IF ( XI.EQ.ZERO ) THEN -C -C X real. -C - DO 20 I = DP, 1, -1 - VR = VR*XR + P(I) - 20 CONTINUE -C - ELSE -C -C X complex. -C - DO 40 I = DP, 1, -1 - T = VR*XR - VI*XI + P(I) - VI = VI*XR + VR*XI - VR = T - 40 CONTINUE -C - END IF -C - RETURN -C *** Last line of MC01ND *** - END diff --git a/slycot/src/MC01OD.f b/slycot/src/MC01OD.f deleted file mode 100644 index 2d148791..00000000 --- a/slycot/src/MC01OD.f +++ /dev/null @@ -1,147 +0,0 @@ - SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a complex polynomial P(x) from its -C zeros. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of zeros (and hence the degree) of P(x). -C K >= 0. -C -C REZ (input) DOUBLE PRECISION array, dimension (K) -C IMZ (input) DOUBLE PRECISION array, dimension (K) -C The real and imaginary parts of the i-th zero of P(x) -C must be stored in REZ(i) and IMZ(i), respectively, where -C i = 1, 2, ..., K. The zeros may be supplied in any order. -C -C REP (output) DOUBLE PRECISION array, dimension (K+1) -C IMP (output) DOUBLE PRECISION array, dimension (K+1) -C These arrays contain the real and imaginary parts, -C respectively, of the coefficients of P(x) in increasing -C powers of x. If K = 0, then REP(1) is set to one and -C IMP(1) is set to zero. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*K+2) -C If K = 0, this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes the coefficients of the complex K-th degree -C polynomial P(x) as -C -C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) -C -C where r(i) = (REZ(i),IMZ(i)), using real arithmetic. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01CD by Alan Brown and -C A.J. Geurts. -C -C REVISIONS -C -C V. Sima, May 2002. -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), IMP(*), IMZ(*), REP(*), REZ(*) -C .. Local Scalars .. - INTEGER I, K2 - DOUBLE PRECISION U, V -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( K.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFO = 0 - REP(1) = ONE - IMP(1) = ZERO - IF ( K.EQ.0 ) - $ RETURN -C - K2 = K + 2 -C - DO 20 I = 1, K - U = REZ(I) - V = IMZ(I) - DWORK(1) = ZERO - DWORK(K2) = ZERO - CALL DCOPY( I, REP, 1, DWORK(2), 1 ) - CALL DCOPY( I, IMP, 1, DWORK(K2+1), 1 ) -C - IF ( U.NE.ZERO ) THEN - CALL DAXPY( I, -U, REP, 1, DWORK, 1 ) - CALL DAXPY( I, -U, IMP, 1, DWORK(K2), 1 ) - END IF -C - IF ( V.NE.ZERO ) THEN - CALL DAXPY( I, V, IMP, 1, DWORK, 1 ) - CALL DAXPY( I, -V, REP, 1, DWORK(K2), 1 ) - END IF -C - CALL DCOPY( I+1, DWORK, 1, REP, 1 ) - CALL DCOPY( I+1, DWORK(K2), 1, IMP, 1 ) - 20 CONTINUE -C - RETURN -C *** Last line of MC01OD *** - END diff --git a/slycot/src/MC01PD.f b/slycot/src/MC01PD.f deleted file mode 100644 index f378a84b..00000000 --- a/slycot/src/MC01PD.f +++ /dev/null @@ -1,159 +0,0 @@ - SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a real polynomial P(x) from its -C zeros. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of zeros (and hence the degree) of P(x). -C K >= 0. -C -C REZ (input) DOUBLE PRECISION array, dimension (K) -C IMZ (input) DOUBLE PRECISION array, dimension (K) -C The real and imaginary parts of the i-th zero of P(x) -C must be stored in REZ(i) and IMZ(i), respectively, where -C i = 1, 2, ..., K. The zeros may be supplied in any order, -C except that complex conjugate zeros must appear -C consecutively. -C -C P (output) DOUBLE PRECISION array, dimension (K+1) -C This array contains the coefficients of P(x) in increasing -C powers of x. If K = 0, then P(1) is set to one. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (K+1) -C If K = 0, this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but -C (REZ(i-1),IMZ(i-1)) is not its conjugate. -C -C METHOD -C -C The routine computes the coefficients of the real K-th degree -C polynomial P(x) as -C -C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) -C -C where r(i) = (REZ(i),IMZ(i)). -C -C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) -C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 -C if r(i) is real. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01DD by A.J. Geurts. -C -C REVISIONS -C -C V. Sima, May 2002. -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION U, V -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( K.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFO = 0 - P(1) = ONE - IF ( K.EQ.0 ) - $ RETURN -C - I = 1 -C WHILE ( I <= K ) DO - 20 IF ( I.LE.K ) THEN - U = REZ(I) - V = IMZ(I) - DWORK(1) = ZERO -C - IF ( V.EQ.ZERO ) THEN - CALL DCOPY( I, P, 1, DWORK(2), 1 ) - CALL DAXPY( I, -U, P, 1, DWORK, 1 ) - I = I + 1 -C - ELSE - IF ( I.EQ.K ) THEN - INFO = K - RETURN - ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN - INFO = I + 1 - RETURN - END IF -C - DWORK(2) = ZERO - CALL DCOPY( I, P, 1, DWORK(3), 1 ) - CALL DAXPY( I, -(U + U), P, 1, DWORK(2), 1 ) - CALL DAXPY( I, U**2+V**2, P, 1, DWORK, 1 ) - I = I + 2 - END IF -C - CALL DCOPY( I, DWORK, 1, P, 1 ) - GO TO 20 - END IF -C END WHILE 20 -C - RETURN -C *** Last line of MC01PD *** - END diff --git a/slycot/src/MC01PY.f b/slycot/src/MC01PY.f deleted file mode 100644 index d43f9b17..00000000 --- a/slycot/src/MC01PY.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a real polynomial P(x) from its -C zeros. The coefficients are stored in decreasing order of the -C powers of x. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C K (input) INTEGER -C The number of zeros (and hence the degree) of P(x). -C K >= 0. -C -C REZ (input) DOUBLE PRECISION array, dimension (K) -C IMZ (input) DOUBLE PRECISION array, dimension (K) -C The real and imaginary parts of the i-th zero of P(x) -C must be stored in REZ(i) and IMZ(i), respectively, where -C i = 1, 2, ..., K. The zeros may be supplied in any order, -C except that complex conjugate zeros must appear -C consecutively. -C -C P (output) DOUBLE PRECISION array, dimension (K+1) -C This array contains the coefficients of P(x) in decreasing -C powers of x. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (K) -C If K = 0, this array is not referenced. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but -C (REZ(i-1),IMZ(i-1)) is not its conjugate. -C -C METHOD -C -C The routine computes the coefficients of the real K-th degree -C polynomial P(x) as -C -C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) -C -C where r(i) = (REZ(i),IMZ(i)). -C -C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) -C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 -C if r(i) is real. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, K -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION U, V -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( K.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01PY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFO = 0 - P(1) = ONE - IF ( K.EQ.0 ) - $ RETURN -C - I = 1 -C WHILE ( I <= K ) DO - 20 IF ( I.LE.K ) THEN - U = REZ(I) - V = IMZ(I) - DWORK(I) = ZERO -C - IF ( V.EQ.ZERO ) THEN - CALL DAXPY( I, -U, P, 1, DWORK, 1 ) -C - ELSE - IF ( I.EQ.K ) THEN - INFO = K - RETURN - ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN - INFO = I + 1 - RETURN - END IF -C - DWORK(I+1) = ZERO - CALL DAXPY( I, -(U + U), P, 1, DWORK, 1 ) - CALL DAXPY( I, U**2+V**2, P, 1, DWORK(2), 1 ) - I = I + 1 - END IF -C - CALL DCOPY( I, DWORK, 1, P(2), 1 ) - I = I + 1 - GO TO 20 - END IF -C END WHILE 20 -C - RETURN -C *** Last line of MC01PY *** - END diff --git a/slycot/src/MC01QD.f b/slycot/src/MC01QD.f deleted file mode 100644 index 652887bb..00000000 --- a/slycot/src/MC01QD.f +++ /dev/null @@ -1,207 +0,0 @@ - SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for two given real polynomials A(x) and B(x), the -C quotient polynomial Q(x) and the remainder polynomial R(x) of -C A(x) divided by B(x). -C -C The polynomials Q(x) and R(x) satisfy the relationship -C -C A(x) = B(x) * Q(x) + R(x), -C -C where the degree of R(x) is less than the degree of B(x). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the numerator polynomial A(x). DA >= -1. -C -C DB (input/output) INTEGER -C On entry, the degree of the denominator polynomial B(x). -C DB >= 0. -C On exit, if B(DB+1) = 0.0 on entry, then DB contains the -C index of the highest power of x for which B(DB+1) <> 0.0. -C -C A (input) DOUBLE PRECISION array, dimension (DA+1) -C This array must contain the coefficients of the -C numerator polynomial A(x) in increasing powers of x -C unless DA = -1 on entry, in which case A(x) is taken -C to be the zero polynomial. -C -C B (input) DOUBLE PRECISION array, dimension (DB+1) -C This array must contain the coefficients of the -C denominator polynomial B(x) in increasing powers of x. -C -C RQ (output) DOUBLE PRECISION array, dimension (DA+1) -C If DA < DB on exit, then this array contains the -C coefficients of the remainder polynomial R(x) in -C increasing powers of x; Q(x) is the zero polynomial. -C Otherwise, the leading DB elements of this array contain -C the coefficients of R(x) in increasing powers of x, and -C the next (DA-DB+1) elements contain the coefficients of -C Q(x) in increasing powers of x. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = k: if the degree of the denominator polynomial B(x) has -C been reduced to (DB - k) because B(DB+1-j) = 0.0 on -C entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, DB >= 0 and B(i) = 0.0, where -C i = 1, 2, ..., DB+1. -C -C METHOD -C -C Given real polynomials -C DA -C A(x) = a(1) + a(2) * x + ... + a(DA+1) * x -C -C and -C DB -C B(x) = b(1) + b(2) * x + ... + b(DB+1) * x -C -C where b(DB+1) is non-zero, the routine computes the coeffcients of -C the quotient polynomial -C DA-DB -C Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x -C -C and the remainder polynomial -C DB-1 -C R(x) = r(1) + r(2) * x + ... + r(DB) * x -C -C such that A(x) = B(x) * Q(x) + R(x). -C -C The algorithm used is synthetic division of polynomials (see [1]), -C which involves the following steps: -C -C (a) compute q(k+1) = a(DB+k+1) / b(DB+1) -C -C and -C -C (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k. -C -C Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and -C the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB. -C -C REFERENCES -C -C [1] Knuth, D.E. -C The Art of Computer Programming, (Vol. 2, Seminumerical -C Algorithms). -C Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01ED by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DA, DB, INFO, IWARN -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*), RQ(*) -C .. Local Scalars .. - INTEGER N - DOUBLE PRECISION Q -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IWARN = 0 - INFO = 0 - IF( DA.LT.-1 ) THEN - INFO = -1 - ELSE IF( DB.LT.0 ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01QD', -INFO ) - RETURN - END IF -C -C WHILE ( DB >= 0 and B(DB+1) = 0 ) DO - 20 IF ( DB.GE.0 ) THEN - IF ( B(DB+1).EQ.ZERO ) THEN - DB = DB - 1 - IWARN = IWARN + 1 - GO TO 20 - END IF - END IF -C END WHILE 20 - IF ( DB.EQ.-1 ) THEN - INFO = 1 - RETURN - END IF -C -C B(x) is non-zero. -C - IF ( DA.GE.0 ) THEN - N = DA - CALL DCOPY( N+1, A, 1, RQ, 1 ) -C WHILE ( N >= DB ) DO - 40 IF ( N.GE.DB ) THEN - IF ( RQ(N+1).NE.ZERO ) THEN - Q = RQ(N+1)/B(DB+1) - CALL DAXPY( DB, -Q, B, 1, RQ(N-DB+1), 1 ) - RQ(N+1) = Q - END IF - N = N - 1 - GO TO 40 - END IF -C END WHILE 40 - END IF -C - RETURN -C *** Last line of MC01QD *** - END diff --git a/slycot/src/MC01RD.f b/slycot/src/MC01RD.f deleted file mode 100644 index da1b3dc2..00000000 --- a/slycot/src/MC01RD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of the polynomial -C -C P(x) = P1(x) * P2(x) + alpha * P3(x), -C -C where P1(x), P2(x) and P3(x) are given real polynomials and alpha -C is a real scalar. -C -C Each of the polynomials P1(x), P2(x) and P3(x) may be the zero -C polynomial. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP1 (input) INTEGER -C The degree of the polynomial P1(x). DP1 >= -1. -C -C DP2 (input) INTEGER -C The degree of the polynomial P2(x). DP2 >= -1. -C -C DP3 (input/output) INTEGER -C On entry, the degree of the polynomial P3(x). DP3 >= -1. -C On exit, the degree of the polynomial P(x). -C -C ALPHA (input) DOUBLE PRECISION -C The scalar value alpha of the problem. -C -C P1 (input) DOUBLE PRECISION array, dimension (lenp1) -C where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise. -C If DP1 >= 0, then this array must contain the -C coefficients of P1(x) in increasing powers of x. -C If DP1 = -1, then P1(x) is taken to be the zero -C polynomial, P1 is not referenced and can be supplied -C as a dummy array. -C -C P2 (input) DOUBLE PRECISION array, dimension (lenp2) -C where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise. -C If DP2 >= 0, then this array must contain the -C coefficients of P2(x) in increasing powers of x. -C If DP2 = -1, then P2(x) is taken to be the zero -C polynomial, P2 is not referenced and can be supplied -C as a dummy array. -C -C P3 (input/output) DOUBLE PRECISION array, dimension (lenp3) -C where lenp3 = MAX(DP1+DP2,DP3,0) + 1. -C On entry, if DP3 >= 0, then this array must contain the -C coefficients of P3(x) in increasing powers of x. -C On entry, if DP3 = -1, then P3(x) is taken to be the zero -C polynomial. -C On exit, the leading (DP3+1) elements of this array -C contain the coefficients of P(x) in increasing powers of x -C unless DP3 = -1 on exit, in which case the coefficients of -C P(x) (the zero polynomial) are not stored in the array. -C This is the case, for instance, when ALPHA = 0.0 and -C P1(x) or P2(x) is the zero polynomial. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given real polynomials -C -C DP1 i DP2 i -C P1(x) = SUM a(i+1) * x , P2(x) = SUM b(i+1) * x and -C i=0 i=0 -C -C DP3 i -C P3(x) = SUM c(i+1) * x , -C i=0 -C -C the routine computes the coefficents of P(x) = P1(x) * P2(x) + -C DP3 i -C alpha * P3(x) = SUM d(i+1) * x as follows. -C i=0 -C -C Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1. -C Then if DP1 >= DP2, -C -C i -C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1, -C k=1 -C -C i -C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1 -C k=i-DP2 -C -C and -C DP1+1 -C d(i) = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1, -C k=i-DP2 -C -C where f(i) = alpha * e(i). -C -C Similar formulas hold for the case DP1 < DP2. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01FD by C. Klimann and -C A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP1, DP2, DP3, INFO - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION P1(*), P2(*), P3(*) -C .. Local Scalars .. - INTEGER D1, D2, D3, DMAX, DMIN, DSUM, E3, I, J, K, L -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( DP1.LT.-1 ) THEN - INFO = -1 - ELSE IF( DP2.LT.-1 ) THEN - INFO = -2 - ELSE IF( DP3.LT.-1 ) THEN - INFO = -3 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01RD', -INFO ) - RETURN - END IF -C -C Computation of the exact degree of the polynomials, i.e., Di such -C that either Di = -1 or Pi(Di+1) is non-zero. -C - D1 = DP1 -C WHILE ( D1 >= 0 and P1(D1+1) = 0 ) DO - 20 IF ( D1.GE.0 ) THEN - IF ( P1(D1+1).EQ.ZERO ) THEN - D1 = D1 - 1 - GO TO 20 - END IF - END IF -C END WHILE 20 - D2 = DP2 -C WHILE ( D2 >= 0 and P2(D2+1) = 0 ) DO - 40 IF ( D2.GE.0 ) THEN - IF ( P2(D2+1).EQ.ZERO ) THEN - D2 = D2 - 1 - GO TO 40 - END IF - END IF -C END WHILE 40 - IF ( ALPHA.EQ.ZERO ) THEN - D3 = -1 - ELSE - D3 = DP3 - END IF -C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO - 60 IF ( D3.GE.0 ) THEN - IF ( P3(D3+1).EQ.ZERO ) THEN - D3 = D3 - 1 - GO TO 60 - END IF - END IF -C END WHILE 60 -C -C Computation of P3(x) := ALPHA * P3(x). -C - CALL DSCAL( D3+1, ALPHA, P3, 1 ) -C - IF ( ( D1.EQ.-1 ) .OR. ( D2.EQ.-1 ) ) THEN - DP3 = D3 - RETURN - END IF -C -C P1(x) and P2(x) are non-zero polynomials. -C - DSUM = D1 + D2 - DMAX = MAX( D1, D2 ) - DMIN = DSUM - DMAX -C - IF ( D3.LT.DSUM ) THEN - P3(D3+2) = ZERO - CALL DCOPY( DSUM-D3-1, P3(D3+2), 0, P3(D3+3), 1 ) - D3 = DSUM - END IF -C - IF ( ( D1.EQ.0 ) .OR. ( D2.EQ.0 ) ) THEN -C -C D1 or D2 is zero. -C - IF ( D1.NE.0 ) THEN - CALL DAXPY( D1+1, P2(1), P1, 1, P3, 1 ) - ELSE - CALL DAXPY( D2+1, P1(1), P2, 1, P3, 1 ) - END IF - ELSE -C -C D1 and D2 are both nonzero. -C -C First part of the computation. -C - DO 80 I = 1, DMIN + 1 - P3(I) = P3(I) + DDOT( I, P1, 1, P2, -1 ) - 80 CONTINUE -C -C Second part of the computation. -C - DO 100 I = DMIN + 2, DMAX + 1 - IF ( D1.GT.D2 ) THEN - K = I - D2 - P3(I) = P3(I) + DDOT( DMIN+1, P1(K), 1, P2, -1 ) - ELSE - K = I - D1 - P3(I) = P3(I) + DDOT( DMIN+1, P2(K), -1, P1, 1 ) - END IF - 100 CONTINUE -C -C Third part of the computation. -C - E3 = DSUM + 2 -C - DO 120 I = DMAX + 2, DSUM + 1 - J = E3 - I - K = I - DMIN - L = I - DMAX - IF ( D1.GT.D2 ) THEN - P3(I) = P3(I) + DDOT( J, P1(K), 1, P2(L), -1 ) - ELSE - P3(I) = P3(I) + DDOT( J, P1(L), -1, P2(K), 1 ) - END IF - 120 CONTINUE -C - END IF -C -C Computation of the exact degree of P3(x). -C -C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO - 140 IF ( D3.GE.0 ) THEN - IF ( P3(D3+1).EQ.ZERO ) THEN - D3 = D3 - 1 - GO TO 140 - END IF - END IF -C END WHILE 140 - DP3 = D3 -C - RETURN -C *** Last line of MC01RD *** - END diff --git a/slycot/src/MC01SD.f b/slycot/src/MC01SD.f deleted file mode 100644 index d84362ee..00000000 --- a/slycot/src/MC01SD.f +++ /dev/null @@ -1,281 +0,0 @@ - SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To scale the coefficients of the real polynomial P(x) such that -C the coefficients of the scaled polynomial Q(x) = sP(tx) have -C minimal variation, where s and t are real scalars. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C P (input/output) DOUBLE PRECISION array, dimension (DP+1) -C On entry, this array must contain the coefficients of P(x) -C in increasing powers of x. -C On exit, this array contains the coefficients of the -C scaled polynomial Q(x) in increasing powers of x. -C -C S (output) INTEGER -C The exponent of the floating-point representation of the -C scaling factor s = BASE**S, where BASE is the base of the -C machine representation of floating-point numbers (see -C LAPACK Library Routine DLAMCH). -C -C T (output) INTEGER -C The exponent of the floating-point representation of the -C scaling factor t = BASE**T. -C -C MANT (output) DOUBLE PRECISION array, dimension (DP+1) -C This array contains the mantissas of the standard -C floating-point representation of the coefficients of the -C scaled polynomial Q(x) in increasing powers of x. -C -C E (output) INTEGER array, dimension (DP+1) -C This array contains the exponents of the standard -C floating-point representation of the coefficients of the -C scaled polynomial Q(x) in increasing powers of x. -C -C Workspace -C -C IWORK INTEGER array, dimension (DP+1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, P(x) is the zero polynomial. -C -C METHOD -C -C Define the variation of the coefficients of the real polynomial -C -C 2 DP -C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x -C -C whose non-zero coefficients can be represented as -C e(i) -C p(i) = m(i) * BASE (where 1 <= ABS(m(i)) < BASE) -C -C by -C -C V = max(e(i)) - min(e(i)), -C -C where max and min are taken over the indices i for which p(i) is -C non-zero. -C DP i i -C For the scaled polynomial P(cx) = SUM p(i) * c * x with -C i=0 -C j -C c = (BASE) , the variation V(j) is given by -C -C V(j) = max(e(i) + j * i) - min(e(i) + j * i). -C -C Using the fact that V(j) is a convex function of j, the routine -C determines scaling factors s = (BASE)**S and t = (BASE)**T such -C that the coefficients of the scaled polynomial Q(x) = sP(tx) -C satisfy the following conditions: -C -C (a) 1 <= q(0) < BASE and -C -C (b) the variation of the coefficients of Q(x) is minimal. -C -C Further details can be found in [1]. -C -C REFERENCES -C -C [1] Dunaway, D.K. -C Calculation of Zeros of a Real Polynomial through -C Factorization using Euclid's Algorithm. -C SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974. -C -C NUMERICAL ASPECTS -C -C Since the scaling is performed on the exponents of the floating- -C point representation of the coefficients of P(x), no rounding -C errors occur during the computation of the coefficients of Q(x). -C -C FURTHER COMMENTS -C -C The scaling factors s and t are BASE dependent. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, S, T -C .. Array Arguments .. - INTEGER E(*), IWORK(*) - DOUBLE PRECISION MANT(*), P(*) -C .. Local Scalars .. - LOGICAL OVFLOW - INTEGER BETA, DV, I, INC, J, LB, M, UB, V0, V1 -C .. External Functions .. - INTEGER MC01SX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, MC01SX -C .. External Subroutines .. - EXTERNAL MC01SW, MC01SY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, NINT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF( DP.LT.0 ) THEN - INFO = -1 -C -C Error return. -C - CALL XERBLA( 'MC01SD', -INFO ) - RETURN - END IF -C - INFO = 0 - LB = 1 -C WHILE ( LB <= DP+1 and P(LB) = 0 ) DO - 20 IF ( LB.LE.DP+1 ) THEN - IF ( P(LB).EQ.ZERO ) THEN - LB = LB + 1 - GO TO 20 - END IF - END IF -C END WHILE 20 -C -C LB = MIN( i: P(i) non-zero). -C - IF ( LB.EQ.DP+2 ) THEN - INFO = 1 - RETURN - END IF -C - UB = DP + 1 -C WHILE ( P(UB) = 0 ) DO - 40 IF ( P(UB).EQ.ZERO ) THEN - UB = UB - 1 - GO TO 40 - END IF -C END WHILE 40 -C -C UB = MAX(i: P(i) non-zero). -C - BETA = DLAMCH( 'Base' ) -C - DO 60 I = 1, DP + 1 - CALL MC01SW( P(I), BETA, MANT(I), E(I) ) - 60 CONTINUE -C -C First prescaling. -C - M = E(LB) - IF ( M.NE.0 ) THEN -C - DO 80 I = LB, UB - IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M - 80 CONTINUE -C - END IF - S = -M -C -C Second prescaling. -C - IF ( UB.GT.1 ) M = NINT( DBLE( E(UB) )/DBLE( UB-1 ) ) -C - DO 100 I = LB, UB - IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M*(I-1) - 100 CONTINUE -C - T = -M -C - V0 = MC01SX( LB, UB, E, MANT ) - J = 1 -C - DO 120 I = LB, UB - IF ( MANT(I).NE.ZERO ) IWORK(I) = E(I) + (I-1) - 120 CONTINUE -C - V1 = MC01SX( LB, UB, IWORK, MANT ) - DV = V1 - V0 - IF ( DV.NE.0 ) THEN - IF ( DV.GT.0 ) THEN - J = 0 - INC = -1 - V1 = V0 - DV = -DV -C - DO 130 I = LB, UB - IWORK(I) = E(I) - 130 CONTINUE -C - ELSE - INC = 1 - END IF -C WHILE ( DV < 0 ) DO - 140 IF ( DV.LT.0 ) THEN - V0 = V1 -C - DO 150 I = LB, UB - E(I) = IWORK(I) - 150 CONTINUE -C - J = J + INC -C - DO 160 I = LB, UB - IWORK(I) = E(I) + INC*(I-1 ) - 160 CONTINUE -C - V1 = MC01SX( LB, UB, IWORK, MANT ) - DV = V1 - V0 - GO TO 140 - END IF -C END WHILE 140 - T = T + J - INC - END IF -C -C Evaluation of the output parameters. -C - DO 180 I = LB, UB - CALL MC01SY( MANT(I), E(I), BETA, P(I), OVFLOW ) - 180 CONTINUE -C - RETURN -C *** Last line of MC01SD *** - END diff --git a/slycot/src/MC01SW.f b/slycot/src/MC01SW.f deleted file mode 100644 index 55e155e5..00000000 --- a/slycot/src/MC01SW.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE MC01SW( A, B, M, E ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the mantissa M and the exponent E of a real number A such -C that -C A = M * B**E -C 1 <= ABS( M ) < B -C if A is non-zero. If A is zero, then M and E are set to 0. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input) DOUBLE PRECISION -C The number whose mantissa and exponent are required. -C -C B (input) INTEGER -C The base of the floating-point arithmetic. -C -C M (output) DOUBLE PRECISION -C The mantissa of the floating-point representation of A. -C -C E (output) INTEGER -C The exponent of the floating-point representation of A. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GZ by A.J. Geurts. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER B, E - DOUBLE PRECISION A, M -C .. Local Scalars .. - DOUBLE PRECISION DB -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE -C .. Executable Statements .. -C -C Quick return if possible. -C - IF ( A.EQ.ZERO ) THEN - M = ZERO - E = 0 - RETURN - END IF -C -C A non-zero. -C - DB = DBLE( B ) - M = ABS( A ) - E = 0 -C WHILE ( M >= B ) DO - 20 IF ( M.GE.DB ) THEN - M = M/DB - E = E + 1 - GO TO 20 - END IF -C END WHILE 20 -C WHILE ( M < 1 ) DO - 40 IF ( M.LT.ONE ) THEN - M = M*DB - E = E - 1 - GO TO 40 - END IF -C END WHILE 40 -C - IF ( A.LT.ZERO ) M = -M -C - RETURN -C *** Last line of MC01SW *** - END diff --git a/slycot/src/MC01SX.f b/slycot/src/MC01SX.f deleted file mode 100644 index c2036015..00000000 --- a/slycot/src/MC01SX.f +++ /dev/null @@ -1,68 +0,0 @@ - INTEGER FUNCTION MC01SX( LB, UB, E, MANT ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the variation V of the exponents of a series of -C non-zero floating-point numbers: a(j) = MANT(j) * beta**(E(j)), -C where beta is the base of the machine representation of -C floating-point numbers, i.e., -C V = max(E(j)) - min(E(j)), j = LB,...,UB and MANT(j) non-zero. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GX by A.J. Geurts. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER LB, UB -C .. Array Arguments .. - INTEGER E(*) - DOUBLE PRECISION MANT(*) -C .. Local Scalars .. - INTEGER J, MAXE, MINE -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - MAXE = E(LB) - MINE = MAXE -C - DO 20 J = LB + 1, UB - IF ( MANT(J).NE.ZERO ) THEN - MAXE = MAX( MAXE, E(J) ) - MINE = MIN( MINE, E(J) ) - END IF - 20 CONTINUE -C - MC01SX = MAXE - MINE -C - RETURN -C *** Last line of MC01SX *** - END diff --git a/slycot/src/MC01SY.f b/slycot/src/MC01SY.f deleted file mode 100644 index ab187aa5..00000000 --- a/slycot/src/MC01SY.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE MC01SY( M, E, B, A, OVFLOW ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a real number A from its mantissa M and its exponent E, -C i.e., -C A = M * B**E. -C M and E need not be the standard floating-point values. -C If ABS(A) < B**(EMIN-1), i.e. the smallest positive model number, -C then the routine returns A = 0. -C If M = 0, then the routine returns A = 0 regardless of the value -C of E. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) DOUBLE PRECISION -C The mantissa of the floating-point representation of A. -C -C E (input) INTEGER -C The exponent of the floating-point representation of A. -C -C B (input) INTEGER -C The base of the floating-point arithmetic. -C -C A (output) DOUBLE PRECISION -C The value of M * B**E. -C -C OVFLOW (output) LOGICAL -C The value .TRUE., if ABS(M) * B**E >= B**EMAX (where EMAX -C is the largest possible exponent) and .FALSE. otherwise. -C A is not defined if OVFLOW = .TRUE.. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01GY by A.J. Geurts. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL OVFLOW - INTEGER B, E - DOUBLE PRECISION A, M -C .. Local Scalars .. - INTEGER EMAX, EMIN, ET, EXPON - DOUBLE PRECISION BASE, MT -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD -C .. Executable Statements .. -C - OVFLOW = .FALSE. -C - IF ( ( M.EQ.ZERO ) .OR. ( E.EQ.0 ) ) THEN - A = M - RETURN - END IF -C -C Determination of the mantissa MT and the exponent ET of the -C standard floating-point representation. -C - EMIN = DLAMCH( 'Minimum exponent' ) - EMAX = DLAMCH( 'Largest exponent' ) - MT = M - ET = E -C WHILE ( ABS( MT ) >= B ) DO - 20 IF ( ABS( MT ).GE.B ) THEN - MT = MT/B - ET = ET + 1 - GO TO 20 - END IF -C END WHILE 20 -C WHILE ( ABS( MT ) < 1 ) DO - 40 IF ( ABS( MT ).LT.ONE ) THEN - MT = MT*B - ET = ET - 1 - GO TO 40 - END IF -C END WHILE 40 -C - IF ( ET.LT.EMIN ) THEN - A = ZERO - RETURN - END IF -C - IF ( ET.GE.EMAX ) THEN - OVFLOW = .TRUE. - RETURN - END IF -C -C Computation of the value of A by the relation -C M * B**E = A * (BASE)**EXPON -C - EXPON = ABS( ET ) - A = MT - BASE = B - IF ( ET.LT.0 ) BASE = ONE/BASE -C WHILE ( not EXPON = 0 ) DO - 60 IF ( EXPON.NE.0 ) THEN - IF ( MOD( EXPON, 2 ).EQ.0 ) THEN - BASE = BASE*BASE - EXPON = EXPON/2 - ELSE - A = A*BASE - EXPON = EXPON - 1 - END IF - GO TO 60 - END IF -C END WHILE 60 -C - RETURN -C *** Last line of MC01SY *** - END diff --git a/slycot/src/MC01TD.f b/slycot/src/MC01TD.f deleted file mode 100644 index 249f5c36..00000000 --- a/slycot/src/MC01TD.f +++ /dev/null @@ -1,305 +0,0 @@ - SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine whether or not a given polynomial P(x) with real -C coefficients is stable, either in the continuous-time or discrete- -C time case. -C -C A polynomial is said to be stable in the continuous-time case -C if all its zeros lie in the left half-plane, and stable in the -C discrete-time case if all its zeros lie inside the unit circle. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Indicates whether the stability test to be applied to -C P(x) is in the continuous-time or discrete-time case as -C follows: -C = 'C': Continuous-time case; -C = 'D': Discrete-time case. -C -C Input/Output Parameters -C -C DP (input/output) INTEGER -C On entry, the degree of the polynomial P(x). DP >= 0. -C On exit, if P(DP+1) = 0.0 on entry, then DP contains the -C index of the highest power of x for which P(DP+1) <> 0.0. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of P(x) in -C increasing powers of x. -C -C STABLE (output) LOGICAL -C Contains the value .TRUE. if P(x) is stable and the value -C .FALSE. otherwise (see also NUMERICAL ASPECTS). -C -C NZ (output) INTEGER -C If INFO = 0, contains the number of unstable zeros - that -C is, the number of zeros of P(x) in the right half-plane if -C DICO = 'C' or the number of zeros of P(x) outside the unit -C circle if DICO = 'D' (see also NUMERICAL ASPECTS). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*DP+2) -C The leading (DP+1) elements of DWORK contain the Routh -C coefficients, if DICO = 'C', or the constant terms of -C the Schur-Cohn transforms, if DICO = 'D'. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = k: if the degree of the polynomial P(x) has been -C reduced to (DB - k) because P(DB+1-j) = 0.0 on entry -C for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, P(x) is the zero polynomial; -C = 2: if the polynomial P(x) is most probably unstable, -C although it may be stable with one or more zeros -C very close to either the imaginary axis if -C DICO = 'C' or the unit circle if DICO = 'D'. -C The number of unstable zeros (NZ) is not determined. -C -C METHOD -C -C The stability of the real polynomial -C 2 DP -C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x -C -C is determined as follows. -C -C In the continuous-time case (DICO = 'C') the Routh algorithm -C (see [1]) is used. The routine computes the Routh coefficients and -C if they are non-zero then the number of sign changes in the -C sequence of the coefficients is equal to the number of zeros with -C positive imaginary part. -C -C In the discrete-time case (DICO = 'D') the Schur-Cohn -C algorithm (see [2] and [3]) is applied to the reciprocal -C polynomial -C 2 DP -C Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x + ... + p(0) x . -C -C The routine computes the constant terms of the Schur transforms -C and if all of them are non-zero then the number of zeros of P(x) -C with modulus greater than unity is obtained from the sequence of -C constant terms. -C -C REFERENCES -C -C [1] Gantmacher, F.R. -C Applications of the Theory of Matrices. -C Interscience Publishers, New York, 1959. -C -C [2] Kucera, V. -C Discrete Linear Control. The Algorithmic Approach. -C John Wiley & Sons, Chichester, 1979. -C -C [3] Henrici, P. -C Applied and Computational Complex Analysis (Vol. 1). -C John Wiley & Sons, New York, 1974. -C -C NUMERICAL ASPECTS -C -C The algorithm used by the routine is numerically stable. -C -C Note that if some of the Routh coefficients (DICO = 'C') or -C some of the constant terms of the Schur-Cohn transforms (DICO = -C 'D') are small relative to EPS (the machine precision), then -C the number of unstable zeros (and hence the value of STABLE) may -C be incorrect. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01HD by F. Delebecque and -C A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations, -C stability, stability criteria, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - LOGICAL STABLE - INTEGER DP, INFO, IWARN, NZ -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), P(*) -C .. Local Scalars .. - LOGICAL DICOC - INTEGER I, K, K1, K2, SIGNUM - DOUBLE PRECISION ALPHA, P1, PK1 -C .. External Functions .. - INTEGER IDAMAX - LOGICAL LSAME - EXTERNAL IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DRSCL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC SIGN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - DICOC = LSAME( DICO, 'C' ) -C -C Test the input scalar arguments. -C - IF( .NOT.DICOC .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( DP.LT.0 ) THEN - INFO = -2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC01TD', -INFO ) - RETURN - END IF -C -C WHILE (DP >= 0 and P(DP+1) = 0 ) DO - 20 IF ( DP.GE.0 ) THEN - IF ( P(DP+1).EQ.ZERO ) THEN - DP = DP - 1 - IWARN = IWARN + 1 - GO TO 20 - END IF - END IF -C END WHILE 20 -C - IF ( DP.EQ.-1 ) THEN - INFO = 1 - RETURN - END IF -C -C P(x) is not the zero polynomial and its degree is exactly DP. -C - IF ( DICOC ) THEN -C -C Continuous-time case. -C -C Compute the Routh coefficients and the number of sign changes. -C - CALL DCOPY( DP+1, P, 1, DWORK, 1 ) - NZ = 0 - K = DP -C WHILE ( K > 0 and DWORK(K) non-zero) DO - 40 IF ( K.GT.0 ) THEN - IF ( DWORK(K).EQ.ZERO ) THEN - INFO = 2 - ELSE - ALPHA = DWORK(K+1)/DWORK(K) - IF ( ALPHA.LT.ZERO ) NZ = NZ + 1 - K = K - 1 -C - DO 60 I = K, 2, -2 - DWORK(I) = DWORK(I) - ALPHA*DWORK(I-1) - 60 CONTINUE -C - GO TO 40 - END IF - END IF -C END WHILE 40 - ELSE -C -C Discrete-time case. -C -C To apply [3], section 6.8, on the reciprocal of polynomial -C P(x) the elements of the array P are copied in DWORK in -C reverse order. -C - CALL DCOPY( DP+1, P, 1, DWORK, -1 ) -C K-1 -C DWORK(K),...,DWORK(DP+1), are the coefficients of T P(x) -C scaled with a factor alpha(K) in order to avoid over- or -C underflow, -C i-1 -C DWORK(i), i = 1,...,K, contains alpha(i) * T P(0). -C - SIGNUM = ONE - NZ = 0 - K = 1 -C WHILE ( K <= DP and DWORK(K) non-zero ) DO - 80 IF ( ( K.LE.DP ) .AND. ( INFO.EQ.0 ) ) THEN -C K -C Compute the coefficients of T P(x). -C - K1 = DP - K + 2 - K2 = DP + 2 - ALPHA = DWORK(K-1+IDAMAX( K1, DWORK(K), 1 )) - IF ( ALPHA.EQ.ZERO ) THEN - INFO = 2 - ELSE - CALL DCOPY( K1, DWORK(K), 1, DWORK(K2), 1 ) - CALL DRSCL( K1, ALPHA, DWORK(K2), 1 ) - P1 = DWORK(K2) - PK1 = DWORK(K2+K1-1) -C - DO 100 I = 1, K1 - 1 - DWORK(K+I) = P1*DWORK(DP+1+I) - PK1*DWORK(K2+K1-I) - 100 CONTINUE -C -C Compute the number of unstable zeros. -C - K = K + 1 - IF ( DWORK(K).EQ.ZERO ) THEN - INFO = 2 - ELSE - SIGNUM = SIGNUM*SIGN( ONE, DWORK(K) ) - IF ( SIGNUM.LT.ZERO ) NZ = NZ + 1 - END IF - GO TO 80 - END IF -C END WHILE 80 - END IF - END IF -C - IF ( ( INFO.EQ.0 ) .AND. ( NZ.EQ.0 ) ) THEN - STABLE = .TRUE. - ELSE - STABLE = .FALSE. - END IF -C - RETURN -C *** Last line of MC01TD *** - END diff --git a/slycot/src/MC01VD.f b/slycot/src/MC01VD.f deleted file mode 100644 index 4d03390b..00000000 --- a/slycot/src/MC01VD.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the roots of a quadratic equation with real -C coefficients. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input) DOUBLE PRECISION -C The value of the coefficient of the quadratic term. -C -C B (input) DOUBLE PRECISION -C The value of the coefficient of the linear term. -C -C C (input) DOUBLE PRECISION -C The value of the coefficient of the constant term. -C -C Z1RE (output) DOUBLE PRECISION -C Z1IM (output) DOUBLE PRECISION -C The real and imaginary parts, respectively, of the largest -C root in magnitude. -C -C Z2RE (output) DOUBLE PRECISION -C Z2IM (output) DOUBLE PRECISION -C The real and imaginary parts, respectively, of the -C smallest root in magnitude. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if on entry, either A = B = 0.0 or A = 0.0 and the -C root -C/B overflows; in this case Z1RE, Z1IM, Z2RE -C and Z2IM are unassigned; -C = 2: if on entry, A = 0.0; in this case Z1RE contains -C BIG and Z1IM contains zero, where BIG is a -C representable number near the overflow threshold -C of the machine (see LAPACK Library Routine DLAMCH); -C = 3: if on entry, either C = 0.0 and the root -B/A -C overflows or A, B and C are non-zero and the largest -C real root in magnitude cannot be computed without -C overflow; in this case Z1RE contains BIG and Z1IM -C contains zero; -C = 4: if the roots cannot be computed without overflow; in -C this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned. -C -C METHOD -C -C The routine computes the roots (r1 and r2) of the real quadratic -C equation -C 2 -C a * x + b * x + c = 0 -C -C as -C - b - SIGN(b) * SQRT(b * b - 4 * a * c) c -C r1 = --------------------------------------- and r2 = ------ -C 2 * a a * r1 -C -C unless a = 0, in which case -C -C -c -C r1 = --. -C b -C -C Precautions are taken to avoid overflow and underflow wherever -C possible. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01JD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Quadratic equation, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR=4.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO - DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE -C .. Local Scalars .. - LOGICAL OVFLOW - INTEGER BETA, EA, EAPLEC, EB, EB2, EC, ED - DOUBLE PRECISION ABSA, ABSB, ABSC, BIG, M1, M2, MA, MB, MC, MD, - $ SFMIN, W -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL MC01SW, MC01SY -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD, SIGN, SQRT -C .. Executable Statements .. -C -C Detect special cases. -C - INFO = 0 - BETA = DLAMCH( 'Base' ) - SFMIN = DLAMCH( 'Safe minimum' ) - BIG = ONE/SFMIN - IF ( A.EQ.ZERO ) THEN - IF ( B.EQ.ZERO ) THEN - INFO = 1 - ELSE - OVFLOW = .FALSE. - Z2RE = ZERO - IF ( C.NE.ZERO ) THEN - ABSB = ABS( B ) - IF ( ABSB.GE.ONE ) THEN - IF ( ABS( C ).GE.ABSB*SFMIN ) Z2RE = -C/B - ELSE - IF ( ABS( C ).LE.ABSB*BIG ) THEN - Z2RE = -C/B - ELSE - OVFLOW = .TRUE. - Z2RE = BIG - IF ( SIGN( ONE, B )*SIGN( ONE, C ).GT.ZERO ) - $ Z2RE = -BIG - END IF - END IF - END IF - IF ( OVFLOW ) THEN - INFO = 1 - ELSE - Z1RE = BIG - Z1IM = ZERO - Z2IM = ZERO - INFO = 2 - END IF - END IF - RETURN - END IF -C - IF ( C.EQ.ZERO ) THEN - OVFLOW = .FALSE. - Z1RE = ZERO - IF ( B.NE.ZERO ) THEN - ABSA = ABS( A ) - IF ( ABSA.GE.ONE ) THEN - IF ( ABS( B ).GE.ABSA*SFMIN ) Z1RE = -B/A - ELSE - IF ( ABS( B ).LE.ABSA*BIG ) THEN - Z1RE = -B/A - ELSE - OVFLOW = .TRUE. - Z1RE = BIG - END IF - END IF - END IF - IF ( OVFLOW ) INFO = 3 - Z1IM = ZERO - Z2RE = ZERO - Z2IM = ZERO - RETURN - END IF -C -C A and C are non-zero. -C - IF ( B.EQ.ZERO ) THEN - OVFLOW = .FALSE. - ABSC = SQRT( ABS( C ) ) - ABSA = SQRT( ABS( A ) ) - W = ZERO - IF ( ABSA.GE.ONE ) THEN - IF ( ABSC.GE.ABSA*SFMIN ) W = ABSC/ABSA - ELSE - IF ( ABSC.LE.ABSA*BIG ) THEN - W = ABSC/ABSA - ELSE - OVFLOW = .TRUE. - W = BIG - END IF - END IF - IF ( OVFLOW ) THEN - INFO = 4 - ELSE - IF ( SIGN( ONE, A )*SIGN( ONE, C ).GT.ZERO ) THEN - Z1RE = ZERO - Z2RE = ZERO - Z1IM = W - Z2IM = -W - ELSE - Z1RE = W - Z2RE = -W - Z1IM = ZERO - Z2IM = ZERO - END IF - END IF - RETURN - END IF -C -C A, B and C are non-zero. -C - CALL MC01SW( A, BETA, MA, EA ) - CALL MC01SW( B, BETA, MB, EB ) - CALL MC01SW( C, BETA, MC, EC ) -C -C Compute a 'near' floating-point representation of the discriminant -C D = MD * BETA**ED. -C - EAPLEC = EA + EC - EB2 = 2*EB - IF ( EAPLEC.GT.EB2 ) THEN - CALL MC01SY( MB*MB, EB2-EAPLEC, BETA, W, OVFLOW ) - W = W - FOUR*MA*MC - CALL MC01SW( W, BETA, MD, ED ) - ED = ED + EAPLEC - ELSE - CALL MC01SY( FOUR*MA*MC, EAPLEC-EB2, BETA, W, OVFLOW ) - W = MB*MB - W - CALL MC01SW( W, BETA, MD, ED ) - ED = ED + EB2 - END IF -C - IF ( MOD( ED, 2 ).NE.0 ) THEN - ED = ED + 1 - MD = MD/BETA - END IF -C -C Complex roots. -C - IF ( MD.LT.ZERO ) THEN - CALL MC01SY( -MB/( 2*MA ), EB-EA, BETA, Z1RE, OVFLOW ) - IF ( OVFLOW ) THEN - INFO = 4 - ELSE - CALL MC01SY( SQRT( -MD )/( 2*MA ), ED/2-EA, BETA, Z1IM, - $ OVFLOW ) - IF ( OVFLOW ) THEN - INFO = 4 - ELSE - Z2RE = Z1RE - Z2IM = -Z1IM - END IF - END IF - RETURN - END IF -C -C Real roots. -C - MD = SQRT( MD ) - ED = ED/2 - IF ( ED.GT.EB ) THEN - CALL MC01SY( ABS( MB ), EB-ED, BETA, W, OVFLOW ) - W = W + MD - M1 = -SIGN( ONE, MB )*W/( 2*MA ) - CALL MC01SY( M1, ED-EA, BETA, Z1RE, OVFLOW ) - IF ( OVFLOW ) THEN - Z1RE = BIG - INFO = 3 - END IF - M2 = -SIGN( ONE, MB )*2*MC/W - CALL MC01SY( M2, EC-ED, BETA, Z2RE, OVFLOW ) - ELSE - CALL MC01SY( MD, ED-EB, BETA, W, OVFLOW ) - W = W + ABS( MB ) - M1 = -SIGN( ONE, MB )*W/( 2*MA ) - CALL MC01SY( M1, EB-EA, BETA, Z1RE, OVFLOW ) - IF ( OVFLOW ) THEN - Z1RE = BIG - INFO = 3 - END IF - M2 = -SIGN( ONE, MB )*2*MC/W - CALL MC01SY( M2, EC-EB, BETA, Z2RE, OVFLOW ) - END IF - Z1IM = ZERO - Z2IM = ZERO -C - RETURN -C *** Last line of MC01VD *** - END diff --git a/slycot/src/MC01WD.f b/slycot/src/MC01WD.f deleted file mode 100644 index 5ef42154..00000000 --- a/slycot/src/MC01WD.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given real polynomial P(x) and a quadratic -C polynomial B(x), the quotient polynomial Q(x) and the linear -C remainder polynomial R(x) such that -C -C P(x) = B(x) * Q(x) + R(x), -C -C 2 -C where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x) -C and u1, u2, q(1) and q(2) are real scalars. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DP (input) INTEGER -C The degree of the polynomial P(x). DP >= 0. -C -C P (input) DOUBLE PRECISION array, dimension (DP+1) -C This array must contain the coefficients of P(x) in -C increasing powers of x. -C -C U1 (input) DOUBLE PRECISION -C The value of the constant term of the quadratic -C polynomial B(x). -C -C U2 (input) DOUBLE PRECISION -C The value of the coefficient of x of the quadratic -C polynomial B(x). -C -C Q (output) DOUBLE PRECISION array, dimension (DP+1) -C If DP >= 1 on entry, then elements Q(1) and Q(2) contain -C the coefficients q(1) and q(2), respectively, of the -C remainder polynomial R(x), and the next (DP-1) elements -C of this array contain the coefficients of the quotient -C polynomial Q(x) in increasing powers of x. -C If DP = 0 on entry, then element Q(1) contains the -C coefficient q(1) of the remainder polynomial R(x) = q(1); -C Q(x) is the zero polynomial. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given the real polynomials -C -C DP i 2 -C P(x) = SUM p(i+1) * x and B(x) = u1 + u2 * x + x -C i=0 -C -C the routine uses the recurrence relationships -C -C q(DP+1) = p(DP+1), -C -C q(DP) = p(DP) - u2 * q(DP+1) and -C -C q(i) = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1 -C -C to determine the coefficients of the quotient polynomial -C -C DP-2 i -C Q(x) = SUM q(i+3) * x -C i=0 -C -C and the remainder polynomial -C -C R(x) = q(1) + q(2) * (u2 + x). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC01KD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, polynomial operations, -C quadratic polynomial. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER DP, INFO - DOUBLE PRECISION U1, U2 -C .. Array Arguments .. - DOUBLE PRECISION P(*), Q(*) -C .. Local Scalars .. - INTEGER I, N - DOUBLE PRECISION A, B, C -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - IF ( DP.LT.0 ) THEN - INFO = -1 - CALL XERBLA( 'MC01WD', -INFO ) - RETURN - END IF -C - INFO = 0 - N = DP + 1 - Q(N) = P(N) - IF ( N.GT.1 ) THEN - B = Q(N) - Q(N-1) = P(N-1) - U2*B - IF ( N.GT.2 ) THEN - A = Q(N-1) -C - DO 20 I = N - 2, 1, -1 - C = P(I) - U2*A - U1*B - Q(I) = C - B = A - A = C - 20 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of MC01WD *** - END diff --git a/slycot/src/MC03MD.f b/slycot/src/MC03MD.f deleted file mode 100644 index 36e69719..00000000 --- a/slycot/src/MC03MD.f +++ /dev/null @@ -1,351 +0,0 @@ - SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, - $ LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31, - $ LDP32, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of the real polynomial matrix -C -C P(x) = P1(x) * P2(x) + alpha * P3(x), -C -C where P1(x), P2(x) and P3(x) are given real polynomial matrices -C and alpha is a real scalar. -C -C Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the -C zero matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C RP1 (input) INTEGER -C The number of rows of the matrices P1(x) and P3(x). -C RP1 >= 0. -C -C CP1 (input) INTEGER -C The number of columns of matrix P1(x) and the number of -C rows of matrix P2(x). CP1 >= 0. -C -C CP2 (input) INTEGER -C The number of columns of the matrices P2(x) and P3(x). -C CP2 >= 0. -C -C DP1 (input) INTEGER -C The degree of the polynomial matrix P1(x). DP1 >= -1. -C -C DP2 (input) INTEGER -C The degree of the polynomial matrix P2(x). DP2 >= -1. -C -C DP3 (input/output) INTEGER -C On entry, the degree of the polynomial matrix P3(x). -C DP3 >= -1. -C On exit, the degree of the polynomial matrix P(x). -C -C ALPHA (input) DOUBLE PRECISION -C The scalar value alpha of the problem. -C -C P1 (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*) -C If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part -C of this array must contain the coefficients of the -C polynomial matrix P1(x). Specifically, P1(i,j,k) must -C contain the coefficient of x**(k-1) of the polynomial -C which is the (i,j)-th element of P1(x), where i = 1,2,..., -C RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1. -C If DP1 = -1, then P1(x) is taken to be the zero polynomial -C matrix, P1 is not referenced and can be supplied as a -C dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and -C declare this array to be P1(1,1,1) in the calling -C program). -C -C LDP11 INTEGER -C The leading dimension of array P1. -C LDP11 >= MAX(1,RP1) if DP1 >= 0, -C LDP11 >= 1 if DP1 = -1. -C -C LDP12 INTEGER -C The second dimension of array P1. -C LDP12 >= MAX(1,CP1) if DP1 >= 0, -C LDP12 >= 1 if DP1 = -1. -C -C P2 (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*) -C If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part -C of this array must contain the coefficients of the -C polynomial matrix P2(x). Specifically, P2(i,j,k) must -C contain the coefficient of x**(k-1) of the polynomial -C which is the (i,j)-th element of P2(x), where i = 1,2,..., -C CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1. -C If DP2 = -1, then P2(x) is taken to be the zero polynomial -C matrix, P2 is not referenced and can be supplied as a -C dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and -C declare this array to be P2(1,1,1) in the calling -C program). -C -C LDP21 INTEGER -C The leading dimension of array P2. -C LDP21 >= MAX(1,CP1) if DP2 >= 0, -C LDP21 >= 1 if DP2 = -1. -C -C LDP22 INTEGER -C The second dimension of array P2. -C LDP22 >= MAX(1,CP2) if DP2 >= 0, -C LDP22 >= 1 if DP2 = -1. -C -C P3 (input/output) DOUBLE PRECISION array, dimension -C (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1. -C On entry, if DP3 >= 0, then the leading -C RP1-by-CP2-by-(DP3+1) part of this array must contain the -C coefficients of the polynomial matrix P3(x). Specifically, -C P3(i,j,k) must contain the coefficient of x**(k-1) of the -C polynomial which is the (i,j)-th element of P3(x), where -C i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1. -C If DP3 = -1, then P3(x) is taken to be the zero polynomial -C matrix. -C On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1, -C on entry, or DP1 <> -1 and DP2 <> -1), then the leading -C RP1-by-CP2-by-(DP3+1) part of this array contains the -C coefficients of P(x). Specifically, P3(i,j,k) contains the -C coefficient of x**(k-1) of the polynomial which is the -C (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2, -C ...,CP2 and k = 1,2,...,DP3+1. -C If DP3 = -1 on exit, then the coefficients of P(x) (the -C zero polynomial matrix) are not stored in the array. -C -C LDP31 INTEGER -C The leading dimension of array P3. LDP31 >= MAX(1,RP1). -C -C LDP32 INTEGER -C The second dimension of array P3. LDP32 >= MAX(1,CP2). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (CP1) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given real polynomial matrices -C -C DP1 i -C P1(x) = SUM (A(i+1) * x ), -C i=0 -C -C DP2 i -C P2(x) = SUM (B(i+1) * x ), -C i=0 -C -C DP3 i -C P3(x) = SUM (C(i+1) * x ) -C i=0 -C -C and a real scalar alpha, the routine computes the coefficients -C d ,d ,..., of the polynomial matrix -C 1 2 -C -C P(x) = P1(x) * P2(x) + alpha * P3(x) -C -C from the formula -C -C s -C d = SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1), -C i+1 k=r -C -C where i = 0,1,...,DP1+DP2 and r and s depend on the value of i -C (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i). -C -C NUMERICAL ASPECTS -C -C None. -C -C FURTHER COMMENTS -C -C Other elementary operations involving polynomial matrices can -C easily be obtained by calling the appropriate BLAS routine(s). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03AD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, input output description, -C polynomial matrix, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER CP1, CP2, DP1, DP2, DP3, INFO, LDP11, LDP12, - $ LDP21, LDP22, LDP31, LDP32, RP1 - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), P1(LDP11,LDP12,*), P2(LDP21,LDP22,*), - $ P3(LDP31,LDP32,*) -C .. Local Scalars .. - LOGICAL CFZERO - INTEGER DPOL3, E, H, I, J, K -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DCOPY, DLASET, DSCAL, XERBLA -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - IF( RP1.LT.0 ) THEN - INFO = -1 - ELSE IF( CP1.LT.0 ) THEN - INFO = -2 - ELSE IF( CP2.LT.0 ) THEN - INFO = -3 - ELSE IF( DP1.LT.-1 ) THEN - INFO = -4 - ELSE IF( DP2.LT.-1 ) THEN - INFO = -5 - ELSE IF( DP3.LT.-1 ) THEN - INFO = -6 - ELSE IF( ( DP1.EQ.-1 .AND. LDP11.LT.1 ) .OR. - $ ( DP1.GE. 0 .AND. LDP11.LT.MAX( 1, RP1 ) ) ) THEN - INFO = -9 - ELSE IF( ( DP1.EQ.-1 .AND. LDP12.LT.1 ) .OR. - $ ( DP1.GE. 0 .AND. LDP12.LT.MAX( 1, CP1 ) ) ) THEN - INFO = -10 - ELSE IF( ( DP2.EQ.-1 .AND. LDP21.LT.1 ) .OR. - $ ( DP2.GE. 0 .AND. LDP21.LT.MAX( 1, CP1 ) ) ) THEN - INFO = -12 - ELSE IF( ( DP2.EQ.-1 .AND. LDP22.LT.1 ) .OR. - $ ( DP2.GE. 0 .AND. LDP22.LT.MAX( 1, CP2 ) ) ) THEN - INFO = -13 - ELSE IF( LDP31.LT.MAX( 1, RP1 ) ) THEN - INFO = -15 - ELSE IF( LDP32.LT.MAX( 1, CP2 ) ) THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC03MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( RP1.EQ.0 .OR. CP2.EQ.0 ) - $ RETURN -C - IF ( ALPHA.EQ.ZERO ) - $ DP3 = -1 -C - IF ( DP3.GE.0 ) THEN -C -C P3(x) := ALPHA * P3(x). -C - DO 40 K = 1, DP3 + 1 -C - DO 20 J = 1, CP2 - CALL DSCAL( RP1, ALPHA, P3(1,J,K), 1 ) - 20 CONTINUE -C - 40 CONTINUE - END IF -C - IF ( ( DP1.EQ.-1 ) .OR. ( DP2.EQ.-1 ) .OR. ( CP1.EQ.0 ) ) - $ RETURN -C -C Neither of P1(x) and P2(x) is the zero polynomial. -C - DPOL3 = DP1 + DP2 - IF ( DPOL3.GT.DP3 ) THEN -C -C Initialize the additional part of P3(x) to zero. -C - DO 80 K = DP3 + 2, DPOL3 + 1 - CALL DLASET( 'Full', RP1, CP2, ZERO, ZERO, P3(1,1,K), - $ LDP31 ) - 80 CONTINUE -C - DP3 = DPOL3 - END IF -C k-1 -C The inner product of the j-th row of the coefficient of x of P1 -C i-1 -C and the h-th column of the coefficient of x of P2(x) contribute -C k+i-2 -C the (j,h)-th element of the coefficient of x of P3(x). -C - DO 160 K = 1, DP1 + 1 -C - DO 140 J = 1, RP1 - CALL DCOPY( CP1, P1(J,1,K), LDP11, DWORK, 1 ) -C - DO 120 I = 1, DP2 + 1 - E = K + I - 1 -C - DO 100 H = 1, CP2 - P3(J,H,E) = DDOT( CP1, DWORK, 1, P2(1,H,I), 1 ) + - $ P3(J,H,E) - 100 CONTINUE -C - 120 CONTINUE -C - 140 CONTINUE -C - 160 CONTINUE -C -C Computation of the exact degree of P3(x). -C - CFZERO = .TRUE. -C WHILE ( DP3 >= 0 and CFZERO ) DO - 180 IF ( ( DP3.GE.0 ) .AND. CFZERO ) THEN - DPOL3 = DP3 + 1 -C - DO 220 J = 1, CP2 -C - DO 200 I = 1, RP1 - IF ( P3(I,J,DPOL3 ).NE.ZERO ) CFZERO = .FALSE. - 200 CONTINUE -C - 220 CONTINUE -C - IF ( CFZERO ) DP3 = DP3 - 1 - GO TO 180 - END IF -C END WHILE 180 -C - RETURN -C *** Last line of MC03MD *** - END diff --git a/slycot/src/MC03ND.f b/slycot/src/MC03ND.f deleted file mode 100644 index 5ee0fd02..00000000 --- a/slycot/src/MC03ND.f +++ /dev/null @@ -1,495 +0,0 @@ - SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, - $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of a minimal polynomial basis -C DK -C K(s) = K(0) + K(1) * s + ... + K(DK) * s -C -C for the right nullspace of the MP-by-NP polynomial matrix of -C degree DP, given by -C DP -C P(s) = P(0) + P(1) * s + ... + P(DP) * s , -C -C which corresponds to solving the polynomial matrix equation -C P(s) * K(s) = 0. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the polynomial matrix P(s). -C MP >= 0. -C -C NP (input) INTEGER -C The number of columns of the polynomial matrix P(s). -C NP >= 0. -C -C DP (input) INTEGER -C The degree of the polynomial matrix P(s). DP >= 1. -C -C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array must -C contain the coefficients of the polynomial matrix P(s). -C Specifically, P(i,j,k) must contain the (i,j)-th element -C of P(k-1), which is the cofficient of s**(k-1) of P(s), -C where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MAX(1,MP). -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= MAX(1,NP). -C -C DK (output) INTEGER -C The degree of the minimal polynomial basis K(s) for the -C right nullspace of P(s) unless DK = -1, in which case -C there is no right nullspace. -C -C GAM (output) INTEGER array, dimension (DP*MP+1) -C The leading (DK+1) elements of this array contain -C information about the ordering of the right nullspace -C vectors stored in array NULLSP. -C -C NULLSP (output) DOUBLE PRECISION array, dimension -C (LDNULL,(DP*MP+1)*NP) -C The leading NP-by-SUM(i*GAM(i)) part of this array -C contains the right nullspace vectors of P(s) in condensed -C form (as defined in METHOD), where i = 1,2,...,DK+1. -C -C LDNULL INTEGER -C The leading dimension of array NULLSP. -C LDNULL >= MAX(1,NP). -C -C KER (output) DOUBLE PRECISION array, dimension -C (LDKER1,LDKER2,DP*MP+1) -C The leading NP-by-nk-by-(DK+1) part of this array contains -C the coefficients of the minimal polynomial basis K(s), -C where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically, -C KER(i,j,m) contains the (i,j)-th element of K(m-1), which -C is the coefficient of s**(m-1) of K(s), where i = 1,2,..., -C NP, j = 1,2,...,nk and m = 1,2,...,DK+1. -C -C LDKER1 INTEGER -C The leading dimension of array KER. LDKER1 >= MAX(1,NP). -C -C LDKER2 INTEGER -C The second dimension of array KER. LDKER2 >= MAX(1,NP). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C A tolerance below which matrix elements are considered -C to be zero. If the user sets TOL to be less than -C 10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is -C F F -C taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the -C F F -C machine precision (see LAPACK Library Routine DLAMCH) and -C A and E are matrices (as defined in METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension (m+2*MAX(n,m+1)+n), -C where m = DP*MP and n = (DP-1)*MP + NP. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK The length of the array DWORK. -C LDWORK >= m*n*n + 2*m*n + 2*n*n. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C > 0: if incorrect rank decisions were taken during the -C computations. This failure is not likely to occur. -C The possible values are: -C k, 1 <= k <= DK+1, the k-th diagonal submatrix had -C not a full row rank; -C DK+2, if incorrect dimensions of a full column -C rank submatrix; -C DK+3, if incorrect dimensions of a full row rank -C submatrix. -C -C METHOD -C -C The computation of the right nullspace of the MP-by-NP polynomial -C matrix P(s) of degree DP given by -C DP-1 DP -C P(s) = P(0) + P(1) * s + ... + P(DP-1) * s + P(DP) * s -C -C is performed via the pencil s*E - A, associated with P(s), where -C -C | I | | 0 -P(DP) | -C | . | | I . . | -C A = | . | and E = | . . . |. (1) -C | . | | . 0 . | -C | I | | I 0 -P(2) | -C | P(0) | | I -P(1) | -C -C The pencil s*E - A is transformed by unitary matrices Q and Z such -C that -C -C | sE(eps)-A(eps) | X | X | -C |----------------|----------------|------------| -C | 0 | sE(inf)-A(inf) | X | -C Q'(s*E-A)Z = |=================================|============|. -C | | | -C | 0 | sE(r)-A(r) | -C -C Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the -C minimal polynomial basis for the right nullspace of Q'(s*E-A)Z -C (and consequently the basis for the right nullspace of s*E - A) is -C completely determined by s*E(eps)-A(eps). -C -C Let Veps(s) be a minimal polynomial basis for the right nullspace -C of s*E(eps)-A(eps). Then -C -C | Veps(s) | -C V(s) = Z * |---------| -C | 0 | -C -C is a minimal polynomial basis for the right nullspace of s*E - A. -C From the structure of s*E - A it can be shown that if V(s) is -C partitioned as -C -C | Vo(s) | (DP-1)*MP -C V(s) = |------ | -C | Ve(s) | NP -C -C then the columns of Ve(s) form a minimal polynomial basis for the -C right nullspace of P(s). -C -C The vectors of Ve(s) are computed and stored in array NULLSP in -C the following condensed form: -C -C || || | || | | || | | -C || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |, -C || || | || | | || | | -C -C where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block -C of columns of K(j), the j-th coefficient of the polynomial matrix -C representation for the right nullspace -C DK -C K(s) = K(0) + K(1) * s + . . . + K(DK) * s . -C -C The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices -C given by -C -C K(0) = | U1,0 | U2,0 | U3,0 | . . . | U(DK+1,0) | -C -C K(1) = | 0 | U2,1 | U3,1 | . . . | U(DK+1,1) | -C -C K(2) = | 0 | 0 | U3,2 | . . . | U(DK+1,2) | -C -C . . . . . . . . . . -C -C K(DK) = | 0 | 0 | 0 | . . . | 0 | U(DK+1,DK)|. -C -C Note that the degree of K(s) satisfies the inequality DK <= -C DP * MIN(MP,NP) and that the dimension of K(s) satisfies the -C inequality (NP-MP) <= nk <= NP. -C -C REFERENCES -C -C [1] Beelen, Th.G.J. -C New Algorithms for Computing the Kronecker structure of a -C Pencil with Applications to Systems and Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, 1987. -C -C [2] Van Den Hurk, G.J.H.H. -C New Algorithms for Solving Polynomial Matrix Problems. -C Master's Thesis, Eindhoven University of Technology, 1987. -C -C NUMERICAL ASPECTS -C -C The algorithm used by the routine involves the construction of a -C special block echelon form with pivots considered to be non-zero -C when they are larger than TOL. These pivots are then inverted in -C order to construct the columns of the kernel of the polynomial -C matrix. If TOL is chosen to be too small then these inversions may -C be sensitive whereas increasing TOL will make the inversions more -C robust but will affect the block echelon form (and hence the -C column degrees of the polynomial kernel). Furthermore, if the -C elements of the computed polynomial kernel are large relative to -C the polynomial matrix, then the user should consider trying -C several values of TOL. -C -C FURTHER COMMENTS -C -C It also possible to compute a minimal polynomial basis for the -C right nullspace of a pencil, since a pencil is a polynomial matrix -C of degree 1. Thus for the pencil (s*E - A), the required input is -C P(1) = E and P(0) = -A. -C -C The routine can also be used to compute a minimal polynomial -C basis for the left nullspace of a polynomial matrix by simply -C transposing P(s). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by -C Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk. -C -C REVISIONS -C -C Jan. 1998. -C -C KEYWORDS -C -C Echelon form, elementary polynomial operations, input output -C description, polynomial matrix, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TEN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) -C .. Scalar Arguments .. - INTEGER DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1, - $ LDP2, LDWORK, MP, NP - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER GAM(*), IWORK(*) - DOUBLE PRECISION DWORK(*), KER(LDKER1,LDKER2,*), - $ NULLSP(LDNULL,*), P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE, - $ JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS, - $ NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL, - $ VC1, VR2 - DOUBLE PRECISION TOLER -C .. Local Arrays .. - INTEGER MNEI(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLAPY2 -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX, - $ MC03NY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - M = DP*MP - H = M - MP - N = H + NP - INFO = 0 - IF( MP.LT.0 ) THEN - INFO = -1 - ELSE IF( NP.LT.0 ) THEN - INFO = -2 - ELSE IF( DP.LE.0 ) THEN - INFO = -3 - ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN - INFO = -5 - ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN - INFO = -6 - ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN - INFO = -10 - ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC03ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN - DK = -1 - RETURN - END IF -C - JWORKA = 1 - JWORKE = JWORKA + M*N - JWORKZ = JWORKE + M*N - JWORKV = JWORKZ + N*N - JWORKQ = JWORKA -C -C Construct the matrices A and E in the pencil s*E-A in (1). -C Workspace: 2*M*N. -C - CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M, - $ DWORK(JWORKE), M ) -C -C Computation of the tolerance. -C - TOLER = MAX( DLANGE( 'F', M, NP, DWORK(JWORKE+H*M), M, DWORK ), - $ DLANGE( 'F', MP, NP, P, LDP1, DWORK ) ) - TOLER = TEN*DLAMCH( 'Epsilon' ) - $ *DLAPY2( TOLER, SQRT( DBLE( H ) ) ) - IF ( TOLER.LE.TOL ) TOLER = TOL -C -C Reduction of E to column echelon form E0 = Q' x E x Z and -C transformation of A, A0 = Q' x A x Z. -C Workspace: 2*M*N + N*N + max(M,N). -C - CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M, - $ DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N, - $ RANKE, IWORK, TOLER, DWORK(JWORKV), INFO ) -C -C The contents of ISTAIR is transferred from MB04UD to MB04VD by -C IWORK(i), i=1,...,M. -C In the sequel the arrays IMUK and INUK are part of IWORK, namely: -C IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK, -C IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK. -C IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains -C IMUK0 (not needed), and is also used as workspace. -C - MUK = M + 1 - NUK = MUK + MAX( N, M+1 ) - TAIL = NUK + MAX( N, M+1 ) -C - CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE, - $ DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M, - $ DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK), - $ IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL), - $ INFO ) - IF ( INFO.GT.0 ) THEN -C -C Incorrect rank decisions. -C - INFO = INFO + NBLCKS - RETURN - END IF -C -C If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is -C zero, then there is no right nullspace. -C - IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN - DK = -1 - RETURN - END IF -C -C Start of the computation of the minimal basis. -C - DK = NBLCKS - 1 - NRA = MNEI(1) - NCA = MNEI(2) -C -C Determine a minimal basis VEPS(s) for the right nullspace of the -C pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s). -C Workspace: 2*M*N + N*N + N*N*(M+1). -C - CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M, - $ IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO ) -C - IF ( INFO.GT.0 ) - $ RETURN -C - NCV = IWORK(MUK) - IWORK(NUK) - GAM(1) = NCV - IWORK(1) = 0 - IWORK(TAIL) = IWORK(MUK) -C - DO 20 I = 2, NBLCKS - IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1) - GAM(I) = IDIFF - IWORK(I) = NCV - NCV = NCV + I*IDIFF - IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1) - 20 CONTINUE -C -C Determine a basis for the right nullspace of the polynomial -C matrix P(s). This basis is stored in array NULLSP in condensed -C form. -C - CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL ) -C -C |VEPS(s)| -C The last NP rows of the product matrix Z x |-------| contain the -C | 0 | -C polynomial basis for the right nullspace of the polynomial matrix -C P(s) in condensed form. The multiplication is restricted to the -C nonzero submatrices Vij,k of VEPS, the result is stored in the -C array NULLSP. -C - VC1 = 1 -C - DO 60 I = 1, NBLCKS - VR2 = IWORK(TAIL+I-1) -C - DO 40 J = 1, I -C -C Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in -C VEPS(1:VR2,VC1:VC1+GAM(I)-1). -C - CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2, - $ ONE, DWORK(JWORKZ+H), N, - $ DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1), - $ LDNULL ) - VC1 = VC1 + GAM(I) - VR2 = VR2 - IWORK(MUK+I-J) - 40 CONTINUE -C - 60 CONTINUE -C -C Transfer of the columns of NULLSP to KER in order to obtain the -C polynomial matrix representation of K(s), the right nullspace -C of P(s). -C - SGAMK = 1 -C - DO 100 K = 1, NBLCKS - CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K), - $ LDKER1 ) - IFIR = SGAMK -C -C Copy the appropriate columns of NULLSP into KER(k). -C SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial -C column of KER(k), the first SGAMK - 1 columns of KER(k) are -C zero. IFIR denotes the position of the first column in KER(k) -C in the set of columns copied for a value of J. -C VC1 is the first column of NULLSP to be copied. -C - DO 80 J = K, NBLCKS - GAMJ = GAM(J) - VC1 = IWORK(J) + (K-1)*GAMJ + 1 - CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL, - $ KER(1,IFIR,K), LDKER1 ) - IFIR = IFIR + GAMJ - 80 CONTINUE -C - SGAMK = SGAMK + GAM(K) - 100 CONTINUE -C - RETURN -C *** Last line of MC03ND *** - END diff --git a/slycot/src/MC03NX.f b/slycot/src/MC03NX.f deleted file mode 100644 index 7376234d..00000000 --- a/slycot/src/MC03NX.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Given an MP-by-NP polynomial matrix of degree dp -C dp-1 dp -C P(s) = P(0) + ... + P(dp-1) * s + P(dp) * s (1) -C -C the routine composes the related pencil s*E-A where -C -C | I | | O -P(dp) | -C | . | | I . . | -C A = | . | and E = | . . . |. (2) -C | . | | . O . | -C | I | | I O -P(2) | -C | P(0) | | I -P(1) | -C -C ================================================================== -C REMARK: This routine is intended to be called only from the SLICOT -C routine MC03ND. -C ================================================================== -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the polynomial matrix P(s). -C MP >= 0. -C -C NP (input) INTEGER -C The number of columns of the polynomial matrix P(s). -C NP >= 0. -C -C DP (input) INTEGER -C The degree of the polynomial matrix P(s). DP >= 1. -C -C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array must -C contain the coefficients of the polynomial matrix P(s) -C in (1) in increasing powers of s. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MAX(1,MP). -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= MAX(1,NP). -C -C A (output) DOUBLE PRECISION array, dimension -C (LDA,(DP-1)*MP+NP) -C The leading DP*MP-by-((DP-1)*MP+NP) part of this array -C contains the matrix A as described in (2). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,DP*MP). -C -C E (output) DOUBLE PRECISION array, dimension -C (LDE,(DP-1)*MP+NP) -C The leading DP*MP-by-((DP-1)*MP+NP) part of this array -C contains the matrix E as described in (2). -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,DP*MP). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03BX by G.J.H.H. van den Hurk. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary polynomial operations, input output description, -C polynomial matrix, polynomial operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, LDA, LDE, LDP1, LDP2, MP, NP -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER H1, HB, HE, HI, J, K -C .. External Subroutines .. - EXTERNAL DLACPY, DLASET, DSCAL -C .. Executable Statements .. -C - IF ( MP.LE.0 .OR. NP.LE.0 ) - $ RETURN -C -C Initialisation of matrices A and E. -C - H1 = DP*MP - HB = H1 - MP - HE = HB + NP - CALL DLASET( 'Full', H1, HE, ZERO, ONE, A, LDA ) - CALL DLASET( 'Full', MP, HB, ZERO, ZERO, E, LDE ) - CALL DLACPY( 'Full', HB, HB, A, LDA, E(MP+1,1), LDE ) -C -C Insert the matrices P(0), P(1), ..., P(dp) at the right places -C in the matrices A and E. -C - HB = HB + 1 - CALL DLACPY( 'Full', MP, NP, P(1,1,1), LDP1, A(HB,HB), LDA ) - HI = 1 -C - DO 20 K = DP + 1, 2, -1 - CALL DLACPY( 'Full', MP, NP, P(1,1,K), LDP1, E(HI,HB), LDE ) - HI = HI + MP - 20 CONTINUE -C - DO 40 J = HB, HE - CALL DSCAL( H1, -ONE, E(1,J), 1 ) - 40 CONTINUE -C - RETURN -C *** Last line of MC03NX *** - END diff --git a/slycot/src/MC03NY.f b/slycot/src/MC03NY.f deleted file mode 100644 index 9966e02a..00000000 --- a/slycot/src/MC03NY.f +++ /dev/null @@ -1,412 +0,0 @@ - SUBROUTINE MC03NY( NBLCKS, NRA, NCA, A, LDA, E, LDE, IMUK, INUK, - $ VEPS, LDVEPS, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a minimal basis of the right nullspace of the -C subpencil s*E(eps)-A(eps) using the method given in [1] (see -C Eqs.(4.6.8), (4.6.9)). -C This pencil only contains Kronecker column indices, and it must be -C in staircase form as supplied by SLICOT Library Routine MB04VD. -C The basis vectors are represented by matrix V(s) having the form -C -C | V11(s) V12(s) V13(s) . . V1n(s) | -C | V22(s) V23(s) V2n(s) | -C | V33(s) . | -C V(s) = | . . | -C | . . | -C | . . | -C | Vnn(s) | -C -C where n is the number of full row rank blocks in matrix A(eps) and -C -C k j-i -C Vij(s) = Vij,0 + Vij,1*s +...+ Vij,k*s +...+ Vij,j-i*s . (1) -C -C In other words, Vij,k is the coefficient corresponding to degree k -C in the matrix polynomial Vij(s). -C Vij,k has dimensions mu(i)-by-(mu(j)-nu(j)). -C The coefficients Vij,k are stored in the matrix VEPS as follows -C (for the case n = 3): -C -C sizes m1-n1 m2-n2 m2-n2 m3-n3 m3-n3 m3-n3 -C -C m1 { | V11,0 || V12,0 | V12,1 || V13,0 | V13,1 | V13,2 || -C | || | || | | || -C VEPS = m2 { | || V22,0 | || V23,0 | V23,1 | || -C | || | || | | || -C m3 { | || | || V33,0 | | || -C -C where mi = mu(i), ni = nu(i). -C Matrix VEPS has dimensions nrv-by-ncv where -C nrv = Sum(i=1,...,n) mu(i) -C ncv = Sum(i=1,...,n) i*(mu(i)-nu(i)) -C -C ================================================================== -C REMARK: This routine is intended to be called only from the SLICOT -C routine MC03ND. -C ================================================================== -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NBLCKS (input) INTEGER -C Number of full row rank blocks in subpencil -C s*E(eps)-A(eps) that contains all Kronecker column indices -C of s*E-A. NBLCKS >= 0. -C -C NRA (input) INTEGER -C Number of rows of the subpencil s*E(eps)-A(eps) in s*E-A. -C NRA = nu(1) + nu(2) + ... + nu(NBLCKS). NRA >= 0. -C -C NCA (input) INTEGER -C Number of columns of the subpencil s*E(eps)-A(eps) in -C s*E-A. -C NCA = mu(1) + mu(2) + ... + mu(NBLCKS). NCA >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,NCA) -C E (input/output) DOUBLE PRECISION array, dimension (LDE,NCA) -C On entry, the leading NRA-by-NCA part of these arrays must -C contain the matrices A and E, where s*E-A is the -C transformed pencil s*E0-A0 which is the pencil associated -C with P(s) as described in [1] Section 4.6. The pencil -C s*E-A is assumed to be in generalized Schur form. -C On exit, these arrays contain no useful information. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NRA). -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,NRA). -C -C IMUK (input) INTEGER array, dimension (NBLCKS) -C This array must contain the column dimensions mu(k) of the -C full column rank blocks in the subpencil s*E(eps)-A(eps) -C of s*E-A. The content of IMUK is modified by the routine -C but restored on exit. -C -C INUK (input) INTEGER array, dimension (NBLCKS) -C This array must contain the row dimensions nu(k) of the -C full row rank blocks in the subpencil s*E(eps)-A(eps) of -C s*E-A. -C -C VEPS (output) DOUBLE PRECISION array, dimension (LDVEPS,ncv) -C Let nrv = Sum(i=1,...,NBLCKS) mu(i) = NCA, -C ncv = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). -C The leading nrv-by-ncv part of this array contains the -C column vectors of a minimal polynomial basis for the right -C nullspace of the subpencil s*E(eps)-A(eps). (See [1] -C Section 4.6.4.) An upper bound for ncv is (NRA+1)*NCA. -C -C LDVEPS INTEGER -C The leading dimension of array VEPS. -C LDVEPS >= MAX(1,NCA). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = k, the k-th diagonal block of A had not a -C full row rank. -C -C REFERENCES -C -C [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker -C structure of a Pencil with Applications to Systems and -C Control Theory. -C Ph.D.Thesis, Eindhoven University of Technology, 1987. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. -C Supersedes Release 2.0 routine MC03BY by Th.G.J. Beelen, -C A.J. Geurts, and G.J.H.H. van den Hurk. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Elementary polynomial operations, Kronecker form, polynomial -C matrix, polynomial operations, staircase form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDE, LDVEPS, NBLCKS, NCA, NRA -C .. Array Arguments .. - INTEGER IMUK(*), INUK(*) - DOUBLE PRECISION A(LDA,*), E(LDE,*), VEPS(LDVEPS,*) -C .. Local Scalars .. - INTEGER AC1, AC2, AR1, ARI, ARK, DIF, EC1, ER1, I, J, K, - $ MUI, NCV, NRV, NUI, SMUI, SMUI1, VC1, VC2, VR1, - $ VR2, WC1, WR1 -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLASET, DSCAL, DTRTRS, XERBLA -C .. Executable Statements .. -C - INFO = 0 - IF( NBLCKS.LT.0 ) THEN - INFO = -1 - ELSE IF( NRA.LT.0 ) THEN - INFO = -2 - ELSE IF( NCA.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, NRA ) ) THEN - INFO = -5 - ELSE IF( LDE.LT.MAX( 1, NRA ) ) THEN - INFO = -7 - ELSE IF( LDVEPS.LT.MAX( 1, NCA ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MC03NY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( NBLCKS.EQ.0 .OR. NRA.EQ.0 .OR. NCA.EQ.0 ) - $ RETURN -C -C Computation of the nonzero parts of W1 and W2: -C -C | AH11 AH12 ... AH1n | | EH11 EH12 ... EH1n | -C | AH22 AH2n | | EH22 EH2n | -C W1 = | . . |, W2 = | . . | -C | . . | | . . | -C | AHnn | | EHnn | -C -C with AHij = -pinv(Aii) * Aij, EHij = pinv(Aii) * Eij and EHii = 0, -C AHij and EHij have dimensions mu(i)-by-mu(j), Aii = [ Oi | Ri ], -C and -C Ri is a regular nu(i)-by-nu(i) upper triangular matrix; -C Oi is a not necessarily square null matrix. -C Note that the first mu(i)-nu(i) rows in AHij and EHij are zero. -C For memory savings, the nonzero parts of W1 and W2 are constructed -C over A and E, respectively. -C -C (AR1,AC1) denotes the position of the first element of the -C submatrix Ri in matrix Aii. -C EC1 is the index of the first column of Ai,i+1/Ei,i+1. -C - EC1 = 1 - AR1 = 1 -C - DO 40 I = 1, NBLCKS - 1 - NUI = INUK(I) - IF ( NUI.EQ.0 ) GO TO 60 - MUI = IMUK(I) - EC1 = EC1 + MUI - AC1 = EC1 - NUI - CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, - $ NCA-EC1+1, A(AR1,AC1), LDA, E(AR1,EC1), LDE, - $ INFO ) - IF ( INFO.GT.0 ) THEN - INFO = I - RETURN - END IF -C - DO 20 J = 1, NUI - CALL DSCAL( J, -ONE, A(AR1,AC1+J-1), 1 ) - 20 CONTINUE -C - CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, - $ NCA-EC1+1, A(AR1,AC1), LDA, A(AR1,EC1), LDA, - $ INFO ) - AR1 = AR1 + NUI - 40 CONTINUE -C - 60 CONTINUE -C -C The contents of the array IMUK is changed for temporary use in -C this routine as follows: -C -C IMUK(i) = Sum(j=1,...,i) mu(j). -C -C On return, the original contents of IMUK is restored. -C In the same loop the actual number of columns of VEPS is computed. -C The number of rows of VEPS is NCA. -C -C NRV = Sum(i=1,...,NBLCKS) mu(i) = NCA, -C NCV = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). -C - SMUI = 0 - NCV = 0 -C - DO 80 I = 1, NBLCKS - MUI = IMUK(I) - SMUI = SMUI + MUI - IMUK(I) = SMUI - NCV = NCV + I*( MUI - INUK(I) ) - 80 CONTINUE -C - NRV = NCA -C -C Computation of the matrix VEPS. -C -C Initialisation of VEPS to zero. -C - CALL DLASET( 'Full', NRV, NCV, ZERO, ZERO, VEPS, LDVEPS ) -C | I | -C Set Vii,0 = Kii in VEPS , i=1,...,NBLCKS, where Kii = |---| -C | O | -C and I is an identity matrix of size mu(i)-nu(i), -C O is a null matrix, dimensions nu(i)-by-(mu(i)-nu(i)). -C -C WR1 := Sum(j=1,...,i-1) mu(j) + 1 -C is the index of the first row in Vii,0 in VEPS. -C WC1 := Sum(j=1,...,i-1) j*(mu(j)-nu(j)) + 1 -C is the index of the first column in Vii,0 in VEPS. -C - DUMMY(1) = ONE - NUI = IMUK(1) - INUK(1) - CALL DCOPY( NUI, DUMMY, 0, VEPS, LDVEPS+1 ) - WR1 = IMUK(1) + 1 - WC1 = NUI + 1 -C - DO 100 I = 2, NBLCKS - NUI = IMUK(I) - IMUK(I-1) - INUK(I) - CALL DCOPY( NUI, DUMMY, 0, VEPS(WR1,WC1), LDVEPS+1 ) - WR1 = IMUK(I) + 1 - WC1 = WC1 + I*NUI - 100 CONTINUE -C -C Determination of the remaining nontrivial matrices in Vij,k -C block column by block column with decreasing block row index. -C -C The computation starts with the second block column since V11,0 -C has already been determined. -C The coefficients Vij,k satisfy the recurrence relation: -C -C Vij,k = Sum(r=i+1,...,j-k) AHir*Vrj,k + -C + Sum(r=i+1,...,j-k+1) EHir*Vrj,k-1, i + k < j, -C -C = EHi,i+1 * Vi+1,j,k-1 i + k = j. -C -C This recurrence relation can be derived from [1], (4.6.8) -C and formula (1) in Section PURPOSE. -C - VC1 = IMUK(1) - INUK(1) + 1 - ARI = 1 -C - DO 180 J = 2, NBLCKS - DIF = IMUK(J) - IMUK(J-1) - INUK(J) - ARI = ARI + INUK(J-1) - ARK = ARI -C -C Computation of the matrices Vij,k where i + k < j. -C Each matrix Vij,k has dimension mu(i)-by-(mu(j) - nu(j)). -C - DO 160 K = 0, J - 2 -C -C VC1, VC2 are the first and last column index of Vij,k. -C - VC2 = VC1 + DIF - 1 - AC2 = IMUK(J-K) - AR1 = ARK - ARK = ARK - INUK(J-K-1) -C - DO 120 I = J - K - 1, 1, -1 -C -C Compute the first part of Vij,k in decreasing order: -C Vij,k := Vij,k + Sum(r=i+1,..,j-k) AHir*Vrj,k. -C The non-zero parts of AHir are stored in -C A(AR1:AR1+nu(i)-1,AC1:AC2) and Vrj,k are stored in -C VEPS(AC1:AC2,VC1:VC2). -C The non-zero part of the result is stored in -C VEPS(VR1:VR2,VC1:VC2). -C - VR2 = IMUK(I) - AC1 = VR2 + 1 - VR1 = AC1 - INUK(I) - AR1 = AR1 - INUK(I) - CALL DGEMM( 'No transpose', 'No transpose', INUK(I), - $ DIF, AC2-VR2, ONE, A(AR1,AC1), LDA, - $ VEPS(AC1,VC1), LDVEPS, ONE, VEPS(VR1,VC1), - $ LDVEPS ) - 120 CONTINUE -C - ER1 = 1 -C - DO 140 I = 1, J - K - 1 -C -C Compute the second part of Vij,k+1 in normal order: -C Vij,k+1 := Sum(r=i+1,..,j-k) EHir*Vrj,k. -C The non-zero parts of EHir are stored in -C E(ER1:ER1+nu(i)-1,EC1:AC2) and Vrj,k are stored in -C VEPS(EC1:AC2,VC1:VC2). -C The non-zero part of the result is stored in -C VEPS(VR1:VR2,VC2+1:VC2+DIF), where -C DIF = VC2 - VC1 + 1 = mu(j) - nu(j). -C This code portion also computes Vij,k+1 for i + k = j. -C - VR2 = IMUK(I) - EC1 = VR2 + 1 - VR1 = EC1 - INUK(I) - CALL DGEMM( 'No transpose', 'No transpose', INUK(I), - $ DIF, AC2-VR2, ONE, E(ER1,EC1), LDE, - $ VEPS(EC1,VC1), LDVEPS, ZERO, VEPS(VR1,VC2+1), - $ LDVEPS ) - ER1 = ER1 + INUK(I) - 140 CONTINUE -C - VC1 = VC2 + 1 - 160 CONTINUE -C - VC1 = VC1 + DIF - 180 CONTINUE -C -C Restore original contents of the array IMUK. -C -C Since, at the moment: -C IMUK(i) = Sum(j=1,...,i) mu(j), (i=1,...,NBLCKS), -C the original values are: -C mu(i) = IMUK(i) - IMUK(i-1) with IMUK(0 ) = 0. -C - SMUI1 = 0 -C - DO 200 I = 1, NBLCKS - SMUI = IMUK(I) - IMUK(I) = SMUI - SMUI1 - SMUI1 = SMUI - 200 CONTINUE -C - RETURN -C *** Last line of MC03NY *** - END diff --git a/slycot/src/MD03AD.f b/slycot/src/MD03AD.f deleted file mode 100644 index 6eca057c..00000000 --- a/slycot/src/MD03AD.f +++ /dev/null @@ -1,973 +0,0 @@ - SUBROUTINE MD03AD( XINIT, ALG, STOR, UPLO, FCN, JPJ, M, N, ITMAX, - $ NPRINT, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, NJEV, TOL, CGTOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To minimize the sum of the squares of m nonlinear functions, e, in -C n variables, x, by a modification of the Levenberg-Marquardt -C algorithm, using either a Cholesky-based or a conjugate gradients -C solver. The user must provide a subroutine FCN which calculates -C the functions and the Jacobian J (possibly by finite differences), -C and another subroutine JPJ, which computes either J'*J + par*I -C (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is -C the Levenberg factor, exploiting the possible structure of the -C Jacobian matrix. Template implementations of these routines are -C included in the SLICOT Library. -C -C ARGUMENTS -C -C Mode Parameters -C -C XINIT CHARACTER*1 -C Specifies how the variables x are initialized, as follows: -C = 'R' : the array X is initialized to random values; the -C entries DWORK(1:4) are used to initialize the -C random number generator: the first three values -C are converted to integers between 0 and 4095, and -C the last one is converted to an odd integer -C between 1 and 4095; -C = 'G' : the given entries of X are used as initial values -C of variables. -C -C ALG CHARACTER*1 -C Specifies the algorithm used for solving the linear -C systems involving a Jacobian matrix J, as follows: -C = 'D' : a direct algorithm, which computes the Cholesky -C factor of the matrix J'*J + par*I is used; -C = 'I' : an iterative Conjugate Gradients algorithm, which -C only needs the matrix J, is used. -C In both cases, matrix J is stored in a compressed form. -C -C STOR CHARACTER*1 -C If ALG = 'D', specifies the storage scheme for the -C symmetric matrix J'*J, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C The option STOR = 'F' usually ensures a faster execution. -C This parameter is not relevant if ALG = 'I'. -C -C UPLO CHARACTER*1 -C If ALG = 'D', specifies which part of the matrix J'*J -C is stored, as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C The option UPLO = 'U' usually ensures a faster execution. -C This parameter is not relevant if ALG = 'I'. -C -C Function Parameters -C -C FCN EXTERNAL -C Subroutine which evaluates the functions and the Jacobian. -C FCN must be declared in an external statement in the user -C calling program, and must have the following interface: -C -C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, -C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE, -C $ DWORK, LDWORK, INFO ) -C -C where -C -C IFLAG (input/output) INTEGER -C On entry, this parameter must contain a value -C defining the computations to be performed: -C = 0 : Optionally, print the current iterate X, -C function values E, and Jacobian matrix J, -C or other results defined in terms of these -C values. See the argument NPRINT of MD03AD. -C Do not alter E and J. -C = 1 : Calculate the functions at X and return -C this vector in E. Do not alter J. -C = 2 : Calculate the Jacobian at X and return -C this matrix in J. Also return J'*e in JTE -C and NFEVL (see below). Do not alter E. -C = 3 : Do not compute neither the functions nor -C the Jacobian, but return in LDJ and -C IPAR/DPAR1,DPAR2 (some of) the integer/real -C parameters needed. -C On exit, the value of this parameter should not be -C changed by FCN unless the user wants to terminate -C execution of MD03AD, in which case IFLAG must be -C set to a negative integer. -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix or needed for problem solving. -C IPAR is an input parameter, except for IFLAG = 3 -C on entry, when it is also an output parameter. -C On exit, if IFLAG = 3, IPAR(1) contains the length -C of the array J, for storing the Jacobian matrix, -C and the entries IPAR(2:5) contain the workspace -C required by FCN for IFLAG = 1, FCN for IFLAG = 2, -C JPJ for ALG = 'D', and JPJ for ALG = 'I', -C respectively. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for -C describing or solving the problem. -C DPAR1 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR1 could -C store the input trajectory of a system. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array -C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, -C if leading dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for -C describing or solving the problem. -C DPAR2 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR2 could -C store the output trajectory of a system. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array -C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, -C if leading dimension.) -C -C X (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the value of the -C variables x where the functions or the Jacobian -C must be evaluated. -C -C NFEVL (input/output) INTEGER -C The number of function evaluations needed to -C compute the Jacobian by a finite difference -C approximation. -C NFEVL is an input parameter if IFLAG = 0, or an -C output parameter if IFLAG = 2. If the Jacobian is -C computed analytically, NFEVL should be set to a -C non-positive value. -C -C E (input/output) DOUBLE PRECISION array, -C dimension (M) -C This array contains the value of the (error) -C functions e evaluated at X. -C E is an input parameter if IFLAG = 0 or 2, or an -C output parameter if IFLAG = 1. -C -C J (input/output) DOUBLE PRECISION array, dimension -C (LDJ,NC), where NC is the number of columns -C needed. -C This array contains a possibly compressed -C representation of the Jacobian matrix evaluated -C at X. If full Jacobian is stored, then NC = N. -C J is an input parameter if IFLAG = 0, or an output -C parameter if IFLAG = 2. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. LDJ >= 1. -C LDJ is essentially used inside the routines FCN -C and JPJ. -C LDJ is an input parameter, except for IFLAG = 3 -C on entry, when it is an output parameter. -C It is assumed in MD03AD that LDJ is not larger -C than needed. -C -C JTE (output) DOUBLE PRECISION array, dimension (N) -C If IFLAG = 2, the matrix-vector product J'*e. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine FCN. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine FCN). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine FCN. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C JPJ EXTERNAL -C Subroutine which computes J'*J + par*I, if ALG = 'D', and -C J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as -C described above. -C -C JPJ must have the following interface: -C -C SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, -C $ J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) -C -C if ALG = 'D', and -C -C SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, -C $ INCX, DWORK, LDWORK, INFO ) -C -C if ALG = 'I', where -C -C STOR (input) CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix J'*J, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO (input) CHARACTER*1 -C Specifies which part of the matrix J'*J is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C N (input) INTEGER -C The number of columns of the matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C DPAR(1) must contain an initial estimate of the -C Levenberg-Marquardt parameter, par. DPAR(1) >= 0. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension -C (LDJ, NC), where NC is the number of columns. -C The leading NR-by-NC part of this array must -C contain the (compressed) representation of the -C Jacobian matrix J, where NR is the number of rows -C of J (function of IPAR entries). -C -C LDJ (input) INTEGER -C The leading dimension of array J. -C LDJ >= MAX(1,NR). -C -C JTJ (output) DOUBLE PRECISION array, -C dimension (LDJTJ,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 -C (if STOR = 'P') part of this array contains the -C upper or lower triangle of the matrix J'*J+par*I, -C depending on UPLO = 'U', or UPLO = 'L', -C respectively, stored either as a two-dimensional, -C or one-dimensional array, depending on STOR. -C -C LDJTJ (input) INTEGER -C The leading dimension of the array JTJ. -C LDJTJ >= MAX(1,N), if STOR = 'F'. -C LDJTJ >= 1, if STOR = 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine JPJ. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine JPJ). -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine JPJ. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO -C values. INFO must be zero if the subroutine -C finished successfully. -C -C If ALG = 'I', the parameters in common with those for -C ALG = 'D', have the same meaning, and the additional -C parameters are: -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value -C of the matrix-vector product (J'*J + par)*x. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX > 0. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C ITMAX (input) INTEGER -C The maximum number of iterations. ITMAX >= 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C with X, E, and J available for printing. If NPRINT is not -C positive, no special calls of FCN with IFLAG = 0 are made. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed, for instance, for -C describing the structure of the Jacobian matrix, which -C are handed over to the routines FCN and JPJ. -C The first five entries of this array are modified -C internally by a call to FCN (with IFLAG = 3), but are -C restored on exit. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03AD -C routine, but it is passed to the routine FCN. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array DPAR1, as -C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading -C dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03AD -C routine, but it is passed to the routine FCN. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array DPAR2, as -C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading -C dimension.) -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if XINIT = 'G', this array must contain the -C vector of initial variables x to be optimized. -C If XINIT = 'R', this array need not be set before entry, -C and random values will be used to initialize x. -C On exit, if INFO = 0, this array contains the vector of -C values that (approximately) minimize the sum of squares of -C error functions. The values returned in IWARN and -C DWORK(1:5) give details on the iterative process. -C -C NFEV (output) INTEGER -C The number of calls to FCN with IFLAG = 1. If FCN is -C properly implemented, this includes the function -C evaluations needed for finite difference approximation -C of the Jacobian. -C -C NJEV (output) INTEGER -C The number of calls to FCN with IFLAG = 2. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If TOL >= 0, the tolerance which measures the relative -C error desired in the sum of squares. Termination occurs -C when the actual relative reduction in the sum of squares -C is at most TOL. If the user sets TOL < 0, then SQRT(EPS) -C is used instead TOL, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). -C -C CGTOL DOUBLE PRECISION -C If ALG = 'I' and CGTOL > 0, the tolerance which measures -C the relative residual of the solutions computed by the -C conjugate gradients (CG) algorithm. Termination of a -C CG process occurs when the relative residual is at -C most CGTOL. If the user sets CGTOL <= 0, then SQRT(EPS) -C is used instead CGTOL. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, DWORK(4) returns the total number of conjugate -C gradients iterations performed (zero, if ALG = 'D'), and -C DWORK(5) returns the final Levenberg factor. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 5, M + 2*N + size(J) + -C max( DW( FCN|IFLAG = 1 ) + N, -C DW( FCN|IFLAG = 2 ), -C DW( sol ) ) ), -C where size(J) is the size of the Jacobian (provided by FCN -C in IPAR(1), for IFLAG = 3), DW( f ) is the workspace -C needed by the routine f, where f is FCN or JPJ (provided -C by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the -C workspace needed for solving linear systems, -C DW( sol ) = N*N + DW( JPJ ), if ALG = 'D', STOR = 'F'; -C DW( sol ) = N*(N+1)/2 + DW( JPJ ), -C if ALG = 'D', STOR = 'P'; -C DW( sol ) = 3*N + DW( JPJ ), if ALG = 'I'. -C -C Warning Indicator -C -C IWARN INTEGER -C < 0: the user set IFLAG = IWARN in the subroutine FCN; -C = 0: no warning; -C = 1: if the iterative process did not converge in ITMAX -C iterations with tolerance TOL; -C = 2: if ALG = 'I', and in one or more iterations of the -C Levenberg-Marquardt algorithm, the conjugate -C gradient algorithm did not finish after 3*N -C iterations, with the accuracy required in the -C call; -C = 3: the cosine of the angle between e and any column of -C the Jacobian is at most FACTOR*EPS in absolute -C value, where FACTOR = 100 is defined in a PARAMETER -C statement; -C = 4: TOL is too small: no further reduction in the sum -C of squares is possible. -C In all these cases, DWORK(1:5) are set as described -C above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 1; -C = 2: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 2; -C = 3: SLICOT Library routine MB02XD, if ALG = 'D', or -C SLICOT Library routine MB02WD, if ALG = 'I' (or -C user-defined routine JPJ), returned with INFO <> 0. -C -C METHOD -C -C If XINIT = 'R', the initial value for X is set to a vector of -C pseudo-random values uniformly distributed in [-1,1]. -C -C The Levenberg-Marquardt algorithm (described in [1]) is used for -C optimizing the parameters. This algorithm needs the Jacobian -C matrix J, which is provided by the subroutine FCN. The algorithm -C tries to update x by the formula -C -C x = x - p, -C -C using the solution of the system of linear equations -C -C (J'*J + PAR*I)*p = J'*e, -C -C where I is the identity matrix, and e the error function vector. -C The Levenberg factor PAR is decreased after each successfull step -C and increased in the other case. -C -C If ALG = 'D', a direct method, which evaluates the matrix product -C J'*J + par*I and then factors it using Cholesky algorithm, -C implemented in the SLICOT Libray routine MB02XD, is used for -C solving the linear system above. -C -C If ALG = 'I', the Conjugate Gradients method, described in [2], -C and implemented in the SLICOT Libray routine MB02WD, is used for -C solving the linear system above. The main advantage of this method -C is that in most cases the solution of the system can be computed -C in less time than the time needed to compute the matrix J'*J -C This is, however, problem dependent. -C -C REFERENCES -C -C [1] Kelley, C.T. -C Iterative Methods for Optimization. -C Society for Industrial and Applied Mathematics (SIAM), -C Philadelphia (Pa.), 1999. -C -C [2] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, -C 1996. -C -C [3] More, J.J. -C The Levenberg-Marquardt algorithm: implementation and theory. -C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in -C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg -C and New York, pp. 105-116, 1978. -C -C NUMERICAL ASPECTS -C -C The Levenberg-Marquardt algorithm described in [3] is scaling -C invariant and globally convergent to (maybe local) minima. -C According to [1], the convergence rate near a local minimum is -C quadratic, if the Jacobian is computed analytically, and linear, -C if the Jacobian is computed numerically. -C -C Whether or not the direct algorithm is faster than the iterative -C Conjugate Gradients algorithm for solving the linear systems -C involved depends on several factors, including the conditioning -C of the Jacobian matrix, and the ratio between its dimensions. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Mar. 2002. -C -C KEYWORDS -C -C Conjugate gradients, least-squares approximation, -C Levenberg-Marquardt algorithm, matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, FOUR, FIVE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, - $ FIVE = 5.0D0 ) - DOUBLE PRECISION FACTOR, MARQF, MINIMP, PARMAX - PARAMETER ( FACTOR = 10.0D0**2, MARQF = 2.0D0**2, - $ MINIMP = 2.0D0**(-3), PARMAX = 1.0D20 ) -C .. Scalar Arguments .. - CHARACTER ALG, STOR, UPLO, XINIT - INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, - $ LIPAR, M, N, NFEV, NJEV, NPRINT - DOUBLE PRECISION CGTOL, TOL -C .. Array Arguments .. - DOUBLE PRECISION DPAR1(LDPAR1,*), DPAR2(LDPAR2,*), DWORK(*), X(*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL CHOL, FULL, INIT, UPPER - INTEGER DWJTJ, E, I, IFLAG, INFOL, ITER, ITERCG, IW1, - $ IW2, IWARNL, JAC, JTE, JW1, JW2, JWORK, LDJ, - $ LDW, LFCN1, LFCN2, LJTJ, LJTJD, LJTJI, NFEVL, - $ SIZEJ, WRKOPT - DOUBLE PRECISION ACTRED, BIGNUM, CGTDEF, EPSMCH, FNORM, FNORM1, - $ GNORM, GSMIN, PAR, SMLNUM, SQREPS, TOLDEF -C .. Local Arrays .. - INTEGER SEED(4) -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLABAD, DLARNV, FCN, JPJ, MB02WD, MB02XD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, MOD, SQRT -C .. -C .. Executable Statements .. -C -C Decode the scalar input parameters. -C - INIT = LSAME( XINIT, 'R' ) - CHOL = LSAME( ALG, 'D' ) - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C -C Check the scalar input parameters. -C - IWARN = 0 - INFO = 0 - IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN - INFO = -2 - ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -3 - ELSEIF ( CHOL .AND. .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -4 - ELSEIF ( M.LT.0 ) THEN - INFO = -7 - ELSEIF ( N.LT.0 .OR. N.GT.M ) THEN - INFO = -8 - ELSEIF ( ITMAX.LT.0 ) THEN - INFO = -9 - ELSEIF ( LIPAR.LT.5 ) THEN - INFO = -12 - ELSEIF( LDPAR1.LT.0 ) THEN - INFO = -14 - ELSEIF( LDPAR2.LT.0 ) THEN - INFO = -16 - ELSEIF ( LDWORK.LT.5 ) THEN - INFO = -23 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03AD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - NFEV = 0 - NJEV = 0 - IF ( MIN( N, ITMAX ).EQ.0 ) THEN - DWORK(1) = FIVE - DWORK(2) = ZERO - DWORK(3) = ZERO - DWORK(4) = ZERO - DWORK(5) = ZERO - RETURN - ENDIF -C -C Call FCN to get the size of the array J, for storing the Jacobian -C matrix, the leading dimension LDJ and the workspace required -C by FCN for IFLAG = 1 and IFLAG = 2, and JPJ. The entries -C DWORK(1:4) should not be modified by the special call of FCN -C below, if XINIT = 'R' and the values in DWORK(1:4) are explicitly -C desired for initialization of the random number generator. -C - IFLAG = 3 - IW1 = IPAR(1) - IW2 = IPAR(2) - JW1 = IPAR(3) - JW2 = IPAR(4) - LJTJ = IPAR(5) -C - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK, DWORK, LDJ, DWORK, DWORK, LDWORK, - $ INFOL ) -C - SIZEJ = IPAR(1) - LFCN1 = IPAR(2) - LFCN2 = IPAR(3) - LJTJD = IPAR(4) - LJTJI = IPAR(5) -C - IPAR(1) = IW1 - IPAR(2) = IW2 - IPAR(3) = JW1 - IPAR(4) = JW2 - IPAR(5) = LJTJ -C -C Define pointers to the array variables stored in DWORK. -C - JAC = 1 - E = JAC + SIZEJ - JTE = E + M - IW1 = JTE + N - IW2 = IW1 + N - JW1 = IW2 - JW2 = IW2 + N -C -C Check the workspace length. -C - JWORK = JW1 - IF ( CHOL ) THEN - IF ( FULL ) THEN - LDW = N*N - ELSE - LDW = ( N*( N + 1 ) ) / 2 - ENDIF - DWJTJ = JWORK - JWORK = DWJTJ + LDW - LJTJ = LJTJD - ELSE - LDW = 3*N - LJTJ = LJTJI - ENDIF - IF ( LDWORK.LT.MAX( 5, SIZEJ + M + 2*N + - $ MAX( LFCN1 + N, LFCN2, LDW + LJTJ ) ) ) - $ THEN - INFO = -23 - ENDIF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03AD', -INFO ) - RETURN - ENDIF -C -C Set default tolerances. SQREPS is the square root of the machine -C precision, and GSMIN is used in the tests of the gradient norm. -C - EPSMCH = DLAMCH( 'Epsilon' ) - SQREPS = SQRT( EPSMCH ) - TOLDEF = TOL - IF ( TOLDEF.LT.ZERO ) - $ TOLDEF = SQREPS - CGTDEF = CGTOL - IF ( CGTDEF.LE.ZERO ) - $ CGTDEF = SQREPS - GSMIN = FACTOR*EPSMCH - WRKOPT = 5 -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Initialization. -C - IF ( INIT ) THEN -C -C SEED is the initial state of the random number generator. -C SEED(4) must be odd. -C - SEED(1) = MOD( INT( DWORK(1) ), 4096 ) - SEED(2) = MOD( INT( DWORK(2) ), 4096 ) - SEED(3) = MOD( INT( DWORK(3) ), 4096 ) - SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) - CALL DLARNV( 2, SEED, N, X ) - ENDIF -C -C Evaluate the function at the starting point and calculate -C its norm. -C Workspace: need: SIZEJ + M + 2*N + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JTE), - $ DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - NFEV = 1 - FNORM = DNRM2( M, DWORK(E), 1 ) - ACTRED = ZERO - ITERCG = 0 - ITER = 0 - IWARNL = 0 - PAR = ZERO - IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) - $ GO TO 40 -C -C Set the initial vector for the conjugate gradients algorithm. -C - DWORK(IW1) = ZERO - CALL DCOPY( N, DWORK(IW1), 0, DWORK(IW1), 1 ) -C -C WHILE ( nonconvergence and ITER < ITMAX ) DO -C -C Beginning of the outer loop. -C - 10 CONTINUE -C -C Calculate the Jacobian matrix. -C Workspace: need: SIZEJ + M + 2*N + LFCN2; -C prefer: larger. -C - ITER = ITER + 1 - IFLAG = 2 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Compute the gradient norm. -C - GNORM = DNRM2( N, DWORK(JTE), 1 ) - IF ( NFEVL.GT.0 ) - $ NFEV = NFEV + NFEVL - NJEV = NJEV + 1 - IF ( GNORM.LE.GSMIN ) - $ IWARN = 3 - IF ( IWARN.NE.0 ) - $ GO TO 40 - IF ( ITER.EQ.1 ) THEN - WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - PAR = MIN( GNORM, SQRT( PARMAX ) ) - END IF - IF ( IFLAG.LT.0 ) - $ GO TO 40 -C -C If requested, call FCN to enable printing of iterates. -C - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( IFLAG.LT.0 ) - $ GO TO 40 - END IF - END IF -C -C Beginning of the inner loop. -C - 20 CONTINUE -C -C Store the Levenberg factor in DWORK(E) (which is no longer -C needed), to pass it to JPJ routine. -C - DWORK(E) = PAR -C -C Solve (J'*J + PAR*I)*x = J'*e, and store x in DWORK(IW1). -C Additional workspace: -C N*N + DW(JPJ), if ALG = 'D', STOR = 'F'; -C N*( N + 1)/2 + DW(JPJ), if ALG = 'D', STOR = 'P'; -C 3*N + DW(JPJ), if ALG = 'I'. -C - IF ( CHOL ) THEN - CALL DCOPY( N, DWORK(JTE), 1, DWORK(IW1), 1 ) - CALL MB02XD( 'Function', STOR, UPLO, JPJ, M, N, 1, IPAR, - $ LIPAR, DWORK(E), 1, DWORK(JAC), LDJ, - $ DWORK(IW1), N, DWORK(DWJTJ), N, - $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) - ELSE - CALL MB02WD( 'Function', JPJ, N, IPAR, LIPAR, DWORK(E), - $ 1, 3*N, DWORK(JAC), LDJ, DWORK(JTE), 1, - $ DWORK(IW1), 1, CGTOL*GNORM, DWORK(JWORK), - $ LDWORK-JWORK+1, IWARN, INFOL ) - ITERCG = ITERCG + INT( DWORK(JWORK) ) - IWARNL = MAX( 2*IWARN, IWARNL ) - ENDIF -C - IF ( INFOL.NE.0 ) THEN - INFO = 3 - RETURN - ENDIF -C -C Compute updated X. -C - DO 30 I = 0, N - 1 - DWORK(IW2+I) = X(I+1) - DWORK(IW1+I) - 30 CONTINUE -C -C Evaluate the function at x - p and calculate its norm. -C Workspace: need: SIZEJ + M + 3*N + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, DWORK(IW2), NFEVL, DWORK(E), DWORK(JAC), - $ LDJ, DWORK(JTE), DWORK(JW2), LDWORK-JW2+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - NFEV = NFEV + 1 - IF ( IFLAG.LT.0 ) - $ GO TO 40 - FNORM1 = DNRM2( M, DWORK(E), 1 ) -C -C Now, check whether this step was successful and update the -C Levenberg factor. -C - IF ( FNORM.LT.FNORM1 ) THEN -C -C Unsuccessful step: increase PAR. -C - ACTRED = ONE - IF ( PAR.GT.PARMAX ) THEN - IF ( PAR/MARQF.LE.BIGNUM ) - $ PAR = PAR*MARQF - ELSE - PAR = PAR*MARQF - END IF -C - ELSE -C -C Successful step: update PAR, X, and FNORM. -C - ACTRED = ONE - ( FNORM1/FNORM )**2 - IF ( ( FNORM - FNORM1 )*( FNORM + FNORM1 ) .LT. - $ MINIMP*DDOT( N, DWORK(IW1), 1, - $ DWORK(JTE), 1 ) ) THEN - IF ( PAR.GT.PARMAX ) THEN - IF ( PAR/MARQF.LE.BIGNUM ) - $ PAR = PAR*MARQF - ELSE - PAR = PAR*MARQF - END IF - ELSE - PAR = MAX( PAR/MARQF, SMLNUM ) - ENDIF - CALL DCOPY( N, DWORK(IW2), 1, X, 1 ) - FNORM = FNORM1 - ENDIF -C - IF ( ( ACTRED.LE.TOLDEF ) .OR. ( ITER.GT.ITMAX ) .OR. - $ ( PAR.GT.PARMAX ) ) - $ GO TO 40 - IF ( ACTRED.LE.EPSMCH ) THEN - IWARN = 4 - GO TO 40 - ENDIF -C -C End of the inner loop. Repeat if unsuccessful iteration. -C - IF ( FNORM.LT.FNORM1 ) - $ GO TO 20 -C -C End of the outer loop. -C - GO TO 10 -C -C END WHILE 10 -C - 40 CONTINUE -C -C Termination, either normal or user imposed. -C - IF ( ACTRED.GT.TOLDEF ) - $ IWARN = 1 - IF ( IWARNL.NE.0 ) - $ IWARN = 2 -C - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - END IF -C - DWORK(1) = WRKOPT - DWORK(2) = FNORM - DWORK(3) = ITER - DWORK(4) = ITERCG - DWORK(5) = PAR -C - RETURN -C *** Last line of MD03AD *** - END diff --git a/slycot/src/MD03BA.f b/slycot/src/MD03BA.f deleted file mode 100644 index ac2782e3..00000000 --- a/slycot/src/MD03BA.f +++ /dev/null @@ -1,151 +0,0 @@ - SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, - $ GNORM, IPVT, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the QR factorization with column pivoting of an -C m-by-n Jacobian matrix J (m >= n), that is, J*P = Q*R, where Q is -C a matrix with orthogonal columns, P a permutation matrix, and -C R an upper trapezoidal matrix with diagonal elements of -C nonincreasing magnitude, and to apply the transformation Q' on -C the error vector e (in-situ). The 1-norm of the scaled gradient -C is also returned. -C -C This routine is an interface to SLICOT Library routine MD03BX, -C for solving standard nonlinear least squares problems using SLICOT -C routine MD03BD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain the number of rows M of the Jacobian -C matrix J. M >= N. -C IPAR is provided for compatibility with SLICOT Library -C routine MD03BD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 1. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) -C On entry, the leading M-by-N part of this array must -C contain the Jacobian matrix J. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular factor R of the -C Jacobian matrix. Note that for efficiency of the later -C calculations, the matrix R is delivered with the leading -C dimension MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,M). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the error vector e. -C On exit, this array contains the updated vector Q'*e. -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the columns -C of the Jacobian matrix, considered in the initial order. -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector -C J'*Q'*e/FNORM, with each element i further divided -C by JNORMS(i) (if JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if N = 0 or M = 1; -C LDWORK >= 4*N+1, if N > 1. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine calls SLICOT Library routine MD03BX to perform the -C calculations. -C -C FURTHER COMMENTS -C -C For efficiency, the arguments are not checked. This is done in -C the routine MD03BX (except for LIPAR). -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, Jacobian matrix, matrix algebra, -C matrix operations. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, LDJ, LDWORK, LIPAR, N - DOUBLE PRECISION FNORM, GNORM -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*) - DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) -C .. External Subroutines .. - EXTERNAL MD03BX -C .. -C .. Executable Statements .. -C - CALL MD03BX( IPAR(1), N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, - $ DWORK, LDWORK, INFO ) - RETURN -C -C *** Last line of MD03BA *** - END diff --git a/slycot/src/MD03BB.f b/slycot/src/MD03BB.f deleted file mode 100644 index 67772e40..00000000 --- a/slycot/src/MD03BB.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, - $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a value for the parameter PAR such that if x solves -C the system -C -C A*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where A is an m-by-n matrix, D is an -C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if -C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, -C then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C It is assumed that a QR factorization, with column pivoting, of A -C is available, that is, A*P = Q*R, where P is a permutation matrix, -C Q has orthogonal columns, and R is an upper triangular matrix -C with diagonal elements of nonincreasing magnitude. -C The routine needs the full upper triangle of R, the permutation -C matrix P, and the first n components of Q'*b (' denotes the -C transpose). On output, MD03BB also provides an upper triangular -C matrix S such that -C -C P'*(A'*A + PAR*D*D)*P = S'*S . -C -C Matrix S is used in the solution process. -C -C This routine is an interface to SLICOT Library routine MD03BY, -C for solving standard nonlinear least squares problems using SLICOT -C routine MD03BD. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrices R and S -C should be estimated, as follows: -C = 'E' : use incremental condition estimation for R and S; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R and S for zero values; -C = 'U' : use the rank already stored in RANKS (for R). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R. IPAR and LIPAR are not used by this routine, -C but are provided for compatibility with SLICOT Library -C routine MD03BD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C A*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of the -C Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this parameter. -C -C RANKS (input or output) INTEGER array, dimension (1) -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical rank of the matrix R. -C On exit, this array contains the numerical rank of the -C matrix S. -C RANKS is defined as an array for compatibility with SLICOT -C Library routine MD03BD. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system A*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -R*P'*x. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C rank of the matrices R and S. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 4*N, if COND = 'E'; -C LDWORK >= 2*N, if COND <> 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C This routine calls SLICOT Library routine MD03BY to perform the -C calculations. -C -C FURTHER COMMENTS -C -C For efficiency, the arguments are not checked. This is done in -C the routine MD03BY (except for LIPAR). -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, LIPAR, N - DOUBLE PRECISION DELTA, PAR, TOL -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*), RANKS(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) -C .. External Subroutines .. - EXTERNAL MD03BY -C .. -C .. Executable Statements .. -C - CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, - $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) - RETURN -C -C *** Last line of MD03BB *** - END diff --git a/slycot/src/MD03BD.f b/slycot/src/MD03BD.f deleted file mode 100644 index eccd179e..00000000 --- a/slycot/src/MD03BD.f +++ /dev/null @@ -1,1206 +0,0 @@ - SUBROUTINE MD03BD( XINIT, SCALE, COND, FCN, QRFACT, LMPARM, M, N, - $ ITMAX, FACTOR, NPRINT, IPAR, LIPAR, DPAR1, - $ LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, NJEV, - $ FTOL, XTOL, GTOL, TOL, IWORK, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To minimize the sum of the squares of m nonlinear functions, e, in -C n variables, x, by a modification of the Levenberg-Marquardt -C algorithm. The user must provide a subroutine FCN which calculates -C the functions and the Jacobian (possibly by finite differences). -C In addition, specialized subroutines QRFACT, for QR factorization -C with pivoting of the Jacobian, and LMPARM, for the computation of -C Levenberg-Marquardt parameter, exploiting the possible structure -C of the Jacobian matrix, should be provided. Template -C implementations of these routines are included in SLICOT Library. -C -C ARGUMENTS -C -C Mode Parameters -C -C XINIT CHARACTER*1 -C Specifies how the variables x are initialized, as follows: -C = 'R' : the array X is initialized to random values; the -C entries DWORK(1:4) are used to initialize the -C random number generator: the first three values -C are converted to integers between 0 and 4095, and -C the last one is converted to an odd integer -C between 1 and 4095; -C = 'G' : the given entries of X are used as initial values -C of variables. -C -C SCALE CHARACTER*1 -C Specifies how the variables will be scaled, as follows: -C = 'I' : use internal scaling; -C = 'S' : use specified scaling factors, given in DIAG. -C -C COND CHARACTER*1 -C Specifies whether the condition of the linear systems -C involved should be estimated, as follows: -C = 'E' : use incremental condition estimation to find the -C numerical rank; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of matrices for zero values. -C -C Function Parameters -C -C FCN EXTERNAL -C Subroutine which evaluates the functions and the Jacobian. -C FCN must be declared in an external statement in the user -C calling program, and must have the following interface: -C -C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, -C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, DWORK, -C $ LDWORK, INFO ) -C -C where -C -C IFLAG (input/output) INTEGER -C On entry, this parameter must contain a value -C defining the computations to be performed: -C = 0 : Optionally, print the current iterate X, -C function values E, and Jacobian matrix J, -C or other results defined in terms of these -C values. See the argument NPRINT of MD03BD. -C Do not alter E and J. -C = 1 : Calculate the functions at X and return -C this vector in E. Do not alter J. -C = 2 : Calculate the Jacobian at X and return -C this matrix in J. Also return NFEVL -C (see below). Do not alter E. -C = 3 : Do not compute neither the functions nor -C the Jacobian, but return in LDJ and -C IPAR/DPAR1,DPAR2 (some of) the integer/real -C parameters needed. -C On exit, the value of this parameter should not be -C changed by FCN unless the user wants to terminate -C execution of MD03BD, in which case IFLAG must be -C set to a negative integer. -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix or needed for problem solving. -C IPAR is an input parameter, except for IFLAG = 3 -C on entry, when it is also an output parameter. -C On exit, if IFLAG = 3, IPAR(1) contains the length -C of the array J, for storing the Jacobian matrix, -C and the entries IPAR(2:5) contain the workspace -C required by FCN for IFLAG = 1, FCN for IFLAG = 2, -C QRFACT, and LMPARM, respectively. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for -C describing or solving the problem. -C DPAR1 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR1 could -C store the input trajectory of a system. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array -C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, -C if leading dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for -C describing or solving the problem. -C DPAR2 can also be used as an additional array for -C intermediate results when computing the functions -C or the Jacobian. For control problems, DPAR2 could -C store the output trajectory of a system. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array -C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, -C if leading dimension.) -C -C X (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the value of the -C variables x where the functions or the Jacobian -C must be evaluated. -C -C NFEVL (input/output) INTEGER -C The number of function evaluations needed to -C compute the Jacobian by a finite difference -C approximation. -C NFEVL is an input parameter if IFLAG = 0, or an -C output parameter if IFLAG = 2. If the Jacobian is -C computed analytically, NFEVL should be set to a -C non-positive value. -C -C E (input/output) DOUBLE PRECISION array, -C dimension (M) -C This array contains the value of the (error) -C functions e evaluated at X. -C E is an input parameter if IFLAG = 0 or 2, or an -C output parameter if IFLAG = 1. -C -C J (input/output) DOUBLE PRECISION array, dimension -C (LDJ,NC), where NC is the number of columns -C needed. -C This array contains a possibly compressed -C representation of the Jacobian matrix evaluated -C at X. If full Jacobian is stored, then NC = N. -C J is an input parameter if IFLAG = 0, or an output -C parameter if IFLAG = 2. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. LDJ >= 1. -C LDJ is essentially used inside the routines FCN, -C QRFACT and LMPARM. -C LDJ is an input parameter, except for IFLAG = 3 -C on entry, when it is an output parameter. -C It is assumed in MD03BD that LDJ is not larger -C than needed. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine FCN. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine FCN). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine FCN. The LAPACK Library routine XERBLA -C should be used in conjunction with negative INFO. -C INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C QRFACT EXTERNAL -C Subroutine which computes the QR factorization with -C (block) column pivoting of the Jacobian matrix, J*P = Q*R. -C QRFACT must be declared in an external statement in the -C calling program, and must have the following interface: -C -C SUBROUTINE QRFACT( N, IPAR, LIPAR, FNORM, J, LDJ, E, -C $ JNORMS, GNORM, IPVT, DWORK, LDWORK, -C $ INFO ) -C -C where -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. -C N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension -C (LDJ, NC), where NC is the number of columns. -C On entry, the leading NR-by-NC part of this array -C must contain the (compressed) representation -C of the Jacobian matrix J, where NR is the number -C of rows of J (function of IPAR entries). -C On exit, the leading N-by-NC part of this array -C contains a (compressed) representation of the -C upper triangular factor R of the Jacobian matrix. -C For efficiency of the later calculations, the -C matrix R is delivered with the leading dimension -C MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,NR). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension -C (NR) -C On entry, this array contains the error vector e. -C On exit, this array contains the updated vector -C Z*Q'*e, where Z is a block row permutation matrix -C (possibly identity) used in the QR factorization -C of J. (See, for example, the SLICOT Library -C routine NF01BS, Section METHOD.) -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the -C columns of the Jacobian matrix (in the original -C order). -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector -C J'*e/FNORM, with each element i further divided -C by JNORMS(i) (if JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such -C that J*P = Q*R. Column j of P is column IPVT(j) of -C the identity matrix. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine QRFACT. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine QRFACT). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine QRFACT. The LAPACK Library routine -C XERBLA should be used in conjunction with negative -C INFO. INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C LMPARM EXTERNAL -C Subroutine which determines a value for the Levenberg- -C Marquardt parameter PAR such that if x solves the system -C -C J*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where J is an m-by-n matrix, -C D is an n-by-n nonsingular diagonal matrix, and b is an -C m-vector, and if DELTA is a positive number, DXNORM is -C the Euclidean norm of D*x, then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C It is assumed that a block QR factorization, with column -C pivoting, of J is available, that is, J*P = Q*R, where P -C is a permutation matrix, Q has orthogonal columns, and -C R is an upper triangular matrix (possibly stored in a -C compressed form), with diagonal elements of nonincreasing -C magnitude for each block. On output, LMPARM also provides -C a (compressed) representation of an upper triangular -C matrix S, such that -C -C P'*(J'*J + PAR*D*D)*P = S'*S . -C -C LMPARM must be declared in an external statement in the -C calling program, and must have the following interface: -C -C SUBROUTINE LMPARM( COND, N, IPAR, LIPAR, R, LDR, IPVT, -C $ DIAG, QTB, DELTA, PAR, RANKS, X, RX, -C $ TOL, DWORK, LDWORK, INFO ) -C -C where -C -C COND CHARACTER*1 -C Specifies whether the condition of the linear -C systems involved should be estimated, as follows: -C = 'E' : use incremental condition estimation -C to find the numerical rank; -C = 'N' : do not use condition estimation, but -C check the diagonal entries for zero -C values; -C = 'U' : use the ranks already stored in RANKS -C (for R). -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of -C the Jacobian matrix. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension -C (LDR, NC), where NC is the number of columns. -C On entry, the leading N-by-NC part of this array -C must contain the (compressed) representation (Rc) -C of the upper triangular matrix R. -C On exit, the full upper triangular part of R -C (in representation Rc), is unaltered, and the -C remaining part contains (part of) the (compressed) -C representation of the transpose of the upper -C triangular matrix S. -C -C LDR (input) INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P -C such that J*P = Q*R. Column j of P is column -C IPVT(j) of the identity matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of -C the matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of -C the vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. -C DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of -C the Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this -C parameter. -C -C RANKS (input or output) INTEGER array, dimension (r), -C where r is the number of diagonal blocks R_k in R, -C corresponding to the block column structure of J. -C On entry, if COND = 'U' and N > 0, this array must -C contain the numerical ranks of the submatrices -C R_k, k = 1:r. The number r is defined in terms of -C the entries of IPAR. -C On exit, if N > 0, this array contains the -C numerical ranks of the submatrices S_k, k = 1:r. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of -C the system J*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -C -R*P'*x. -C -C TOL (input) DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for -C finding the ranks of the submatrices R_k and S_k. -C If the user sets TOL > 0, then the given value of -C TOL is used as a lower bound for the reciprocal -C condition number; a (sub)matrix whose estimated -C condition number is less than 1/TOL is considered -C to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS, is used instead, -C where EPS is the machine precision (see LAPACK -C Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' -C or 'N'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C The workspace array for subroutine LMPARM. -C On exit, if INFO = 0, DWORK(1) returns the optimal -C value of LDWORK. -C -C LDWORK (input) INTEGER -C The size of the array DWORK (as large as needed -C in the subroutine LMPARM). LDWORK >= 1. -C -C INFO INTEGER -C Error indicator, set to a negative value if an -C input (scalar) argument is erroneous, and to -C positive values for other possible errors in the -C subroutine LMPARM. The LAPACK Library routine -C XERBLA should be used in conjunction with negative -C INFO. INFO must be zero if the subroutine finished -C successfully. -C -C Parameters marked with "(input)" must not be changed. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of functions. M >= 0. -C -C N (input) INTEGER -C The number of variables. M >= N >= 0. -C -C ITMAX (input) INTEGER -C The maximum number of iterations. ITMAX >= 0. -C -C FACTOR (input) DOUBLE PRECISION -C The value used in determining the initial step bound. This -C bound is set to the product of FACTOR and the Euclidean -C norm of DIAG*X if nonzero, or else to FACTOR itself. -C In most cases FACTOR should lie in the interval (.1,100). -C A generally recommended value is 100. FACTOR > 0. -C -C NPRINT (input) INTEGER -C This parameter enables controlled printing of iterates if -C it is positive. In this case, FCN is called with IFLAG = 0 -C at the beginning of the first iteration and every NPRINT -C iterations thereafter and immediately prior to return, -C with X, E, and J available for printing. Note that when -C called immediately prior to return, J normally contains -C the result returned by QRFACT and LMPARM (the compressed -C R and S factors). If NPRINT is not positive, no special -C calls of FCN with IFLAG = 0 are made. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed, for instance, for -C describing the structure of the Jacobian matrix, which -C are handed over to the routines FCN, QRFACT and LMPARM. -C The first five entries of this array are modified -C internally by a call to FCN (with IFLAG = 3), but are -C restored on exit. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 5. -C -C DPAR1 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR1,*) or (LDPAR1) -C A first set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03BD -C routine, but it is passed to the routine FCN. -C -C LDPAR1 (input) INTEGER -C The leading dimension or the length of the array DPAR1, as -C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading -C dimension.) -C -C DPAR2 (input/output) DOUBLE PRECISION array, dimension -C (LDPAR2,*) or (LDPAR2) -C A second set of real parameters needed for describing or -C solving the problem. This argument is not used by MD03BD -C routine, but it is passed to the routine FCN. -C -C LDPAR2 (input) INTEGER -C The leading dimension or the length of the array DPAR2, as -C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading -C dimension.) -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if XINIT = 'G', this array must contain the -C vector of initial variables x to be optimized. -C If XINIT = 'R', this array need not be set before entry, -C and random values will be used to initialize x. -C On exit, if INFO = 0, this array contains the vector of -C values that (approximately) minimize the sum of squares of -C error functions. The values returned in IWARN and -C DWORK(1:4) give details on the iterative process. -C -C DIAG (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if SCALE = 'S', this array must contain some -C positive entries that serve as multiplicative scale -C factors for the variables x. DIAG(I) > 0, I = 1,...,N. -C If SCALE = 'I', DIAG is internally set. -C On exit, this array contains the scale factors used -C (or finally used, if SCALE = 'I'). -C -C NFEV (output) INTEGER -C The number of calls to FCN with IFLAG = 1. If FCN is -C properly implemented, this includes the function -C evaluations needed for finite difference approximation -C of the Jacobian. -C -C NJEV (output) INTEGER -C The number of calls to FCN with IFLAG = 2. -C -C Tolerances -C -C FTOL DOUBLE PRECISION -C If FTOL >= 0, the tolerance which measures the relative -C error desired in the sum of squares. Termination occurs -C when both the actual and predicted relative reductions in -C the sum of squares are at most FTOL. If the user sets -C FTOL < 0, then SQRT(EPS) is used instead FTOL, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C XTOL DOUBLE PRECISION -C If XTOL >= 0, the tolerance which measures the relative -C error desired in the approximate solution. Termination -C occurs when the relative error between two consecutive -C iterates is at most XTOL. If the user sets XTOL < 0, -C then SQRT(EPS) is used instead XTOL. -C -C GTOL DOUBLE PRECISION -C If GTOL >= 0, the tolerance which measures the -C orthogonality desired between the function vector e and -C the columns of the Jacobian J. Termination occurs when -C the cosine of the angle between e and any column of the -C Jacobian J is at most GTOL in absolute value. If the user -C sets GTOL < 0, then EPS is used instead GTOL. -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the matrices of linear systems to be solved. If -C the user sets TOL > 0, then the given value of TOL is used -C as a lower bound for the reciprocal condition number; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS, is used instead. -C This parameter is not relevant if COND = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+r), where r is the number -C of diagonal blocks R_k in R (see description of LMPARM). -C On output, if INFO = 0, the first N entries of this array -C define a permutation matrix P such that J*P = Q*R, where -C J is the final calculated Jacobian, Q is an orthogonal -C matrix (not stored), and R is upper triangular with -C diagonal elements of nonincreasing magnitude (possibly -C for each block column of J). Column j of P is column -C IWORK(j) of the identity matrix. If INFO = 0, the entries -C N+1:N+r of this array contain the ranks of the final -C submatrices S_k (see description of LMPARM). -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the residual error norm (the -C sum of squares), DWORK(3) returns the number of iterations -C performed, and DWORK(4) returns the final Levenberg -C factor. If INFO = 0, N > 0, and IWARN >= 0, the elements -C DWORK(5) to DWORK(4+M) contain the final matrix-vector -C product Z*Q'*e, and the elements DWORK(5+M) to -C DWORK(4+M+N*NC) contain the (compressed) representation of -C final upper triangular matrices R and S (if IWARN <> 4). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max( 4, M + max( size(J) + -C max( DW( FCN|IFLAG = 1 ), -C DW( FCN|IFLAG = 2 ), -C DW( QRFACT ) + N ), -C N*NC + N + -C max( M + DW( FCN|IFLAG = 1 ), -C N + DW( LMPARM ) ) ) ), -C where size(J) is the size of the Jacobian (provided by FCN -C in IPAR(1), for IFLAG = 3), and DW( f ) is the workspace -C needed by the routine f, where f is FCN, QRFACT, or LMPARM -C (provided by FCN in IPAR(2:5), for IFLAG = 3). -C -C Warning Indicator -C -C IWARN INTEGER -C < 0: the user set IFLAG = IWARN in the subroutine FCN; -C = 1: both actual and predicted relative reductions in -C the sum of squares are at most FTOL; -C = 2: relative error between two consecutive iterates is -C at most XTOL; -C = 3: conditions for IWARN = 1 and IWARN = 2 both hold; -C = 4: the cosine of the angle between e and any column of -C the Jacobian is at most GTOL in absolute value; -C = 5: the number of iterations has reached ITMAX without -C satisfying any convergence condition; -C = 6: FTOL is too small: no further reduction in the sum -C of squares is possible; -C = 7: XTOL is too small: no further improvement in the -C approximate solution x is possible; -C = 8: GTOL is too small: e is orthogonal to the columns of -C the Jacobian to machine precision. -C In all these cases, DWORK(1:4) are set as described above. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 1; -C = 2: user-defined routine FCN returned with INFO <> 0 -C for IFLAG = 2; -C = 3: user-defined routine QRFACT returned with INFO <> 0; -C = 4: user-defined routine LMPARM returned with INFO <> 0. -C -C METHOD -C -C If XINIT = 'R', the initial value for x is set to a vector of -C pseudo-random values uniformly distributed in (-1,1). -C -C The Levenberg-Marquardt algorithm (described in [1,3]) is used for -C optimizing the variables x. This algorithm needs the Jacobian -C matrix J, which is provided by the subroutine FCN. A trust region -C method is used. The algorithm tries to update x by the formula -C -C x = x - p, -C -C using an approximate solution of the system of linear equations -C -C (J'*J + PAR*D*D)*p = J'*e, -C -C with e the error function vector, and D a diagonal nonsingular -C matrix, where either PAR = 0 and -C -C ( norm( D*x ) - DELTA ) <= 0.1*DELTA , -C -C or PAR > 0 and -C -C ABS( norm( D*x ) - DELTA ) <= 0.1*DELTA . -C -C DELTA is the radius of the trust region. If the Gauss-Newton -C direction is not acceptable, then an iterative algorithm obtains -C improved lower and upper bounds for the Levenberg-Marquardt -C parameter PAR. Only a few iterations are generally needed for -C convergence of the algorithm. The trust region radius DELTA -C and the Levenberg factor PAR are updated based on the ratio -C between the actual and predicted reduction in the sum of squares. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C [2] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, -C 1996. -C -C [3] More, J.J. -C The Levenberg-Marquardt algorithm: implementation and theory. -C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in -C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg -C and New York, pp. 105-116, 1978. -C -C NUMERICAL ASPECTS -C -C The Levenberg-Marquardt algorithm described in [3] is scaling -C invariant and globally convergent to (maybe local) minima. -C The convergence rate near a local minimum is quadratic, if the -C Jacobian is computed analytically, and linear, if the Jacobian -C is computed numerically. -C -C FURTHER COMMENTS -C -C This routine is a more general version of the subroutines LMDER -C and LMDER1 from the MINPACK package [1], which enables to exploit -C the structure of the problem, and optionally use condition -C estimation. Unstructured problems could be solved as well. -C -C Template SLICOT Library implementations for FCN, QRFACT and -C LMPARM routines are: -C MD03BF, MD03BA, and MD03BB, respectively, for standard problems; -C NF01BF, NF01BS, and NF01BP, respectively, for optimizing the -C parameters of Wiener systems (structured problems). -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Feb. 15, 2004. -C -C KEYWORDS -C -C Least-squares approximation, Levenberg-Marquardt algorithm, -C matrix operations, optimization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, FOUR, P1, P5, P25, P75, P0001 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, - $ P1 = 1.0D-1, P5 = 5.0D-1, P25 = 2.5D-1, - $ P75 = 7.5D-1, P0001 = 1.0D-4 ) -C .. Scalar Arguments .. - CHARACTER COND, SCALE, XINIT - INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, - $ LIPAR, M, N, NFEV, NJEV, NPRINT - DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL -C .. Array Arguments .. - INTEGER IPAR(*), IWORK(*) - DOUBLE PRECISION DIAG(*), DPAR1(*), DPAR2(*), DWORK(*), X(*) -C .. Local Scalars .. - LOGICAL BADSCL, INIT, ISCAL, SSCAL - INTEGER E, IFLAG, INFOL, ITER, IW1, IW2, IW3, J, JAC, - $ JW1, JW2, JWORK, L, LDJ, LDJSAV, LFCN1, LFCN2, - $ LLMP, LQRF, NC, NFEVL, SIZEJ, WRKOPT - DOUBLE PRECISION ACTRED, DELTA, DIRDER, EPSMCH, FNORM, FNORM1, - $ FTDEF, GNORM, GTDEF, PAR, PNORM, PRERED, RATIO, - $ TEMP, TEMP1, TEMP2, TOLDEF, XNORM, XTDEF -C .. Local Arrays .. - INTEGER SEED(4) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARNV, FCN, LMPARM, QRFACT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INIT = LSAME( XINIT, 'R' ) - ISCAL = LSAME( SCALE, 'I' ) - SSCAL = LSAME( SCALE, 'S' ) - INFO = 0 - IWARN = 0 - IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN - INFO = -1 - ELSEIF( .NOT.( ISCAL .OR. SSCAL ) ) THEN - INFO = -2 - ELSEIF( .NOT.( LSAME( COND, 'E' ) .OR. LSAME( COND, 'N' ) ) ) THEN - INFO = -3 - ELSEIF( M.LT.0 ) THEN - INFO = -7 - ELSEIF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -8 - ELSEIF( ITMAX.LT.0 ) THEN - INFO = -9 - ELSEIF( FACTOR.LE.ZERO ) THEN - INFO = -10 - ELSEIF( LIPAR.LT.5 ) THEN - INFO = -13 - ELSEIF( LDPAR1.LT.0 ) THEN - INFO = -15 - ELSEIF( LDPAR2.LT.0 ) THEN - INFO = -17 - ELSEIF ( LDWORK.LT.4 ) THEN - INFO = -28 - ELSEIF ( SSCAL ) THEN - BADSCL = .FALSE. -C - DO 10 J = 1, N - BADSCL = BADSCL .OR. DIAG(J).LE.ZERO - 10 CONTINUE -C - IF ( BADSCL ) - $ INFO = -19 - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03BD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - NFEV = 0 - NJEV = 0 - IF ( N.EQ.0 ) THEN - DWORK(1) = FOUR - DWORK(2) = ZERO - DWORK(3) = ZERO - DWORK(4) = ZERO - RETURN - END IF -C -C Call FCN to get the size of the array J, for storing the Jacobian -C matrix, the leading dimension LDJ and the workspace required -C by FCN for IFLAG = 1 and IFLAG = 2, QRFACT and LMPARM. The -C entries DWORK(1:4) should not be modified by the special call of -C FCN below, if XINIT = 'R' and the values in DWORK(1:4) are -C explicitly desired for initialization of the random number -C generator. -C - IFLAG = 3 - IW1 = IPAR(1) - IW2 = IPAR(2) - IW3 = IPAR(3) - JW1 = IPAR(4) - JW2 = IPAR(5) -C - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK, DWORK, LDJSAV, DWORK, LDWORK, INFOL ) - SIZEJ = IPAR(1) - LFCN1 = IPAR(2) - LFCN2 = IPAR(3) - LQRF = IPAR(4) - LLMP = IPAR(5) - IF ( LDJSAV.GT.0 ) THEN - NC = SIZEJ/LDJSAV - ELSE - NC = SIZEJ - END IF -C - IPAR(1) = IW1 - IPAR(2) = IW2 - IPAR(3) = IW3 - IPAR(4) = JW1 - IPAR(5) = JW2 -C -C Check the workspace length. -C - E = 1 - JAC = E + M - JW1 = JAC + SIZEJ - JW2 = JW1 + N - IW1 = JAC + N*NC - IW2 = IW1 + N - IW3 = IW2 + N - JWORK = IW2 + M -C - L = MAX( 4, M + MAX( SIZEJ + MAX( LFCN1, LFCN2, N + LQRF ), - $ N*NC + N + MAX( M + LFCN1, N + LLMP ) ) ) - IF ( LDWORK.LT.L ) THEN - INFO = -28 - CALL XERBLA( 'MD03BD', -INFO ) - RETURN - ENDIF -C -C Set default tolerances. EPSMCH is the machine precision. -C - EPSMCH = DLAMCH( 'Epsilon' ) - FTDEF = FTOL - XTDEF = XTOL - GTDEF = GTOL - TOLDEF = TOL - IF ( MIN( FTDEF, XTDEF, GTDEF, TOLDEF ).LE.ZERO ) THEN - IF ( FTDEF.LT.ZERO ) - $ FTDEF = SQRT( EPSMCH ) - IF ( XTDEF.LT.ZERO ) - $ XTDEF = SQRT( EPSMCH ) - IF ( GTDEF.LT.ZERO ) - $ GTDEF = EPSMCH - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DBLE( N )*EPSMCH - ENDIF - WRKOPT = 1 -C -C Initialization. -C - IF ( INIT ) THEN -C -C SEED is the initial state of the random number generator. -C SEED(4) must be odd. -C - SEED(1) = MOD( INT( DWORK(1) ), 4096 ) - SEED(2) = MOD( INT( DWORK(2) ), 4096 ) - SEED(3) = MOD( INT( DWORK(3) ), 4096 ) - SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) - CALL DLARNV( 2, SEED, N, X ) - ENDIF -C -C Initialize Levenberg-Marquardt parameter and iteration counter. -C - PAR = ZERO - ITER = 1 -C -C Evaluate the function at the starting point -C and calculate its norm. -C Workspace: need: M + SIZEJ + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, - $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JW1), - $ LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - NFEV = 1 - FNORM = DNRM2( M, DWORK(E), 1 ) - IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) - $ GO TO 90 -C -C Beginning of the outer loop. -C - 20 CONTINUE -C -C Calculate the Jacobian matrix. -C Workspace: need: M + SIZEJ + LFCN2; -C prefer: larger. -C - LDJ = LDJSAV - IFLAG = 2 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( INFOL.NE.0 ) THEN - INFO = 2 - RETURN - END IF - IF ( ITER.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) - IF ( NFEVL.GT.0 ) - $ NFEV = NFEV + NFEVL - NJEV = NJEV + 1 - IF ( IFLAG.LT.0 ) - $ GO TO 90 -C -C If requested, call FCN to enable printing of iterates. -C - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JW1), LDWORK-JW1+1, INFOL ) -C - IF ( IFLAG.LT.0 ) - $ GO TO 90 - END IF - END IF -C -C Compute the QR factorization of the Jacobian. -C Workspace: need: M + SIZEJ + N + LQRF; -C prefer: larger. -C - CALL QRFACT( N, IPAR, LIPAR, FNORM, DWORK(JAC), LDJ, DWORK(E), - $ DWORK(JW1), GNORM, IWORK, DWORK(JW2), - $ LDWORK-JW2+1, INFOL ) - IF ( INFOL.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -C On the first iteration and if SCALE = 'I', scale according -C to the norms of the columns of the initial Jacobian. -C - IF ( ITER.EQ.1 ) THEN - WRKOPT = MAX( WRKOPT, INT( DWORK(JW2) ) + JW2 - 1 ) - IF ( ISCAL ) THEN -C - DO 30 J = 1, N - DIAG(J) = DWORK(JW1+J-1) - IF ( DIAG(J).EQ.ZERO ) - $ DIAG(J) = ONE - 30 CONTINUE -C - END IF -C -C On the first iteration, calculate the norm of the scaled -C x and initialize the step bound DELTA. -C - DO 40 J = 1, N - DWORK(IW1+J-1) = DIAG(J)*X(J) - 40 CONTINUE -C - XNORM = DNRM2( N, DWORK(IW1), 1 ) - DELTA = FACTOR*XNORM - IF ( DELTA.EQ.ZERO ) - $ DELTA = FACTOR - ELSE -C -C Rescale if necessary. -C - IF ( ISCAL ) THEN -C - DO 50 J = 1, N - DIAG(J) = MAX( DIAG(J), DWORK(JW1+J-1) ) - 50 CONTINUE -C - END IF - END IF -C -C Test for convergence of the gradient norm. -C - IF ( GNORM.LE.GTDEF ) - $ IWARN = 4 - IF ( IWARN.NE.0 ) - $ GO TO 90 -C -C Beginning of the inner loop. -C - 60 CONTINUE -C -C Determine the Levenberg-Marquardt parameter and the -C direction p, and compute -R*P'*p. -C Workspace: need: M + N*NC + 2*N + LLMP; -C prefer: larger. -C - CALL LMPARM( COND, N, IPAR, LIPAR, DWORK(JAC), LDJ, - $ IWORK, DIAG, DWORK(E), DELTA, PAR, IWORK(N+1), - $ DWORK(IW1), DWORK(IW2), TOLDEF, DWORK(IW3), - $ LDWORK-IW3+1, INFOL ) - IF ( INFOL.NE.0 ) THEN - INFO = 4 - RETURN - END IF - IF ( ITER.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(IW3) ) + IW3 - 1 ) -C - TEMP1 = DNRM2( N, DWORK(IW2), 1 )/FNORM -C -C Store the direction p and x - p. -C - DO 70 J = 0, N - 1 - DWORK(IW2+J) = DIAG(J+1)*DWORK(IW1+J) - DWORK(IW1+J) = X(J+1) - DWORK(IW1+J) - 70 CONTINUE -C -C Compute the norm of scaled p and the scaled predicted -C reduction and the scaled directional derivative. -C - PNORM = DNRM2( N, DWORK(IW2), 1 ) - TEMP2 = ( SQRT( PAR )*PNORM )/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -( TEMP1**2 + TEMP2**2 ) -C -C On the first iteration, adjust the initial step bound. -C - IF ( ITER.EQ.1 ) - $ DELTA = MIN( DELTA, PNORM ) -C -C Evaluate the function at x - p and calculate its norm. -C Workspace: need: 2*M + N*NC + N + LFCN1; -C prefer: larger. -C - IFLAG = 1 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, DWORK(IW1), NFEVL, DWORK(IW2), DWORK(JAC), - $ LDJ, DWORK(JWORK), LDWORK-JWORK+1, INFOL ) - IF ( INFOL.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - NFEV = NFEV + 1 - IF ( IFLAG.LT.0 ) - $ GO TO 90 - FNORM1 = DNRM2( M, DWORK(IW2), 1 ) -C -C Compute the scaled actual reduction. -C - ACTRED = -ONE - IF ( P1*FNORM1.LT.FNORM ) - $ ACTRED = ONE - ( FNORM1/FNORM )**2 -C -C Compute the ratio of the actual to the predicted reduction. -C - RATIO = ZERO - IF ( PRERED.NE.ZERO ) - $ RATIO = ACTRED/PRERED -C -C Update the step bound. -C - IF ( RATIO.LE.P25 ) THEN - IF ( ACTRED.GE.ZERO ) THEN - TEMP = P5 - ELSE - TEMP = P5*DIRDER/( DIRDER + P5*ACTRED ) - END IF - IF ( P1*FNORM1.GE.FNORM .OR. TEMP.LT.P1 ) - $ TEMP = P1 - DELTA = TEMP*MIN( DELTA, PNORM/P1 ) - PAR = PAR/TEMP - ELSE - IF ( PAR.EQ.ZERO .OR. RATIO.GE.P75 ) THEN - DELTA = PNORM/P5 - PAR = P5*PAR - END IF - END IF -C -C Test for successful iteration. -C - IF ( RATIO.GE.P0001 ) THEN -C -C Successful iteration. Update x, e, and their norms. -C - DO 80 J = 1, N - X(J) = DWORK(IW1+J-1) - DWORK(IW1+J-1) = DIAG(J)*X(J) - 80 CONTINUE -C - CALL DCOPY( M, DWORK(IW2), 1, DWORK(E), 1 ) - XNORM = DNRM2( N, DWORK(IW1), 1 ) - FNORM = FNORM1 - ITER = ITER + 1 - END IF -C -C Tests for convergence. -C - IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. - $ P5*RATIO.LE.ONE ) - $ IWARN = 1 - IF ( DELTA.LE.XTDEF*XNORM ) - $ IWARN = 2 - IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. - $ P5*RATIO.LE.ONE .AND. IWARN.EQ.2 ) - $ IWARN = 3 - IF ( IWARN.NE.0 ) - $ GO TO 90 -C -C Tests for termination and stringent tolerances. -C - IF ( ITER.GE.ITMAX ) - $ IWARN = 5 - IF ( ABS( ACTRED ).LE.EPSMCH .AND. PRERED.LE.EPSMCH .AND. - $ P5*RATIO.LE.ONE ) - $ IWARN = 6 - IF ( DELTA.LE.EPSMCH*XNORM ) - $ IWARN = 7 - IF ( GNORM.LE.EPSMCH ) - $ IWARN = 8 - IF ( IWARN.NE.0 ) - $ GO TO 90 -C -C End of the inner loop. Repeat if unsuccessful iteration. -C - IF ( RATIO.LT.P0001 ) GO TO 60 -C -C End of the outer loop. -C - GO TO 20 -C - 90 CONTINUE -C -C Termination, either normal or user imposed. -C Note that DWORK(JAC) normally contains the results returned by -C QRFACT and LMPARM (the compressed R and S factors). -C - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - IF ( NPRINT.GT.0 ) THEN - IFLAG = 0 - CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, - $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) - IF ( IFLAG.LT.0 ) - $ IWARN = IFLAG - END IF -C - IF ( IWARN.GE.0 ) THEN - DO 100 J = M + N*NC, 1, -1 - DWORK(4+J) = DWORK(J) - 100 CONTINUE - END IF - DWORK(1) = WRKOPT - DWORK(2) = FNORM - DWORK(3) = ITER - DWORK(4) = PAR -C - RETURN -C *** Last line of MD03BD *** - END diff --git a/slycot/src/MD03BF.f b/slycot/src/MD03BF.f deleted file mode 100644 index 232ac807..00000000 --- a/slycot/src/MD03BF.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, - $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for solving a standard nonlinear least -C squares problem using SLICOT Library routine MD03BD. See the -C parameter FCN in the routine MD03BD for the description of -C parameters. -C -C The example programmed in this routine is adapted from that -C accompanying the MINPACK routine LMDER. -C -C ****************************************************************** -C -C .. Parameters .. -C .. NOUT is the unit number for printing intermediate results .. - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR, - $ M, N, NFEVL -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*), - $ X(*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. DATA Statements .. - DOUBLE PRECISION Y(15) - DATA Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8), - $ Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15) - $ / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, - $ 3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1, - $ 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0 / -C -C .. Executable Statements .. -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Compute the error function values. -C - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - IF ( I.GT.8 ) THEN - TMP3 = TMP2 - ELSE - TMP3 = TMP1 - END IF - E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) ) - 10 CONTINUE -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Compute the Jacobian. -C - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - IF ( I.GT.8 ) THEN - TMP3 = TMP2 - ELSE - TMP3 = TMP1 - END IF - TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2 - J(I,1) = -ONE - J(I,2) = TMP1*TMP2/TMP4 - J(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE -C - NFEVL = 0 -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), MD03BA and MD03BB. -C - LDJ = M - IPAR(1) = M*N - IPAR(2) = 0 - IPAR(3) = 0 - IPAR(4) = 4*N + 1 - IPAR(5) = 4*N -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( M, E, 1 ) - WRITE( 1, '('' Norm of current error = '', D15.6)') ERR -C - END IF -C - RETURN -C -C *** Last line of MD03BF *** - END diff --git a/slycot/src/MD03BX.f b/slycot/src/MD03BX.f deleted file mode 100644 index 7ffef61d..00000000 --- a/slycot/src/MD03BX.f +++ /dev/null @@ -1,255 +0,0 @@ - SUBROUTINE MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the QR factorization with column pivoting of an -C m-by-n matrix J (m >= n), that is, J*P = Q*R, where Q is a matrix -C with orthogonal columns, P a permutation matrix, and R an upper -C trapezoidal matrix with diagonal elements of nonincreasing -C magnitude, and to apply the transformation Q' on the error -C vector e (in-situ). The 1-norm of the scaled gradient is also -C returned. The matrix J could be the Jacobian of a nonlinear least -C squares problem. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the Jacobian matrix J. M >= 0. -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. -C M >= N >= 0. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) -C On entry, the leading M-by-N part of this array must -C contain the Jacobian matrix J. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular factor R of the -C Jacobian matrix. Note that for efficiency of the later -C calculations, the matrix R is delivered with the leading -C dimension MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,M). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the error vector e. -C On exit, this array contains the updated vector Q'*e. -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the columns of -C the Jacobian matrix, considered in the initial order. -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector -C J'*Q'*e/FNORM, with each element i further divided by -C JNORMS(i) (if JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if N = 0 or M = 1; -C LDWORK >= 4*N+1, if N > 1. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm uses QR factorization with column pivoting of the -C matrix J, J*P = Q*R, and applies the orthogonal matrix Q' to the -C vector e. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, Jacobian matrix, matrix algebra, -C matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDJ, LDWORK, M, N - DOUBLE PRECISION FNORM, GNORM -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) -C .. Local Scalars .. - INTEGER I, ITAU, JWORK, L, WRKOPT - DOUBLE PRECISION SUM -C .. External Functions .. - DOUBLE PRECISION DDOT, DNRM2 - EXTERNAL DDOT, DNRM2 -C .. External Subroutines .. - EXTERNAL DGEQP3, DLACPY, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( M.LT.0 ) THEN - INFO = -1 - ELSEIF ( N.LT.0.OR. M.LT.N ) THEN - INFO = -2 - ELSEIF ( FNORM.LT.ZERO ) THEN - INFO = -3 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE - IF ( N.EQ.0 .OR. M.EQ.1 ) THEN - JWORK = 1 - ELSE - JWORK = 4*N + 1 - END IF - IF ( LDWORK.LT.JWORK ) - $ INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MD03BX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - GNORM = ZERO - IF ( N.EQ.0 ) THEN - LDJ = 1 - DWORK(1) = ONE - RETURN - ELSEIF ( M.EQ.1 ) THEN - JNORMS(1) = ABS( J(1) ) - IF ( FNORM*J(1).NE.ZERO ) - $ GNORM = ABS( E(1)/FNORM ) - LDJ = 1 - IPVT(1) = 1 - DWORK(1) = ONE - RETURN - END IF -C -C Initialize the column pivoting indices. -C - DO 10 I = 1, N - IPVT(I) = 0 - 10 CONTINUE -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - ITAU = 1 - JWORK = ITAU + N - WRKOPT = 1 -C -C Compute the QR factorization with pivoting of J, and apply Q' to -C the vector e. -C -C Workspace: need: 4*N + 1; -C prefer: 3*N + ( N+1 )*NB. -C - CALL DGEQP3( M, N, J, LDJ, IPVT, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Workspace: need: N + 1; -C prefer: N + NB. -C - CALL DORMQR( 'Left', 'Transpose', M, 1, N, J, LDJ, DWORK(ITAU), E, - $ M, DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C - IF ( LDJ.GT.N ) THEN -C -C Reshape the array J to have the leading dimension N. -C This destroys the details of the orthogonal matrix Q. -C - CALL DLACPY( 'Upper', N, N, J, LDJ, J, N ) - LDJ = N - END IF -C -C Compute the norm of the scaled gradient and original column norms. -C - IF ( FNORM.NE.ZERO ) THEN -C - DO 20 I = 1, N - L = IPVT(I) - JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) - IF ( JNORMS(L).NE.ZERO ) THEN - SUM = DDOT( I, J((I-1)*LDJ+1), 1, E, 1 )/FNORM - GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) - END IF - 20 CONTINUE -C - ELSE -C - DO 30 I = 1, N - L = IPVT(I) - JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) - 30 CONTINUE -C - END IF -C - DWORK(1) = WRKOPT - RETURN -C -C *** Last line of MD03BX *** - END diff --git a/slycot/src/MD03BY.f b/slycot/src/MD03BY.f deleted file mode 100644 index ec4637ce..00000000 --- a/slycot/src/MD03BY.f +++ /dev/null @@ -1,514 +0,0 @@ - SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, - $ RANK, X, RX, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a value for the parameter PAR such that if x solves -C the system -C -C A*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where A is an m-by-n matrix, D is an -C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if -C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, -C then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C It is assumed that a QR factorization, with column pivoting, of A -C is available, that is, A*P = Q*R, where P is a permutation matrix, -C Q has orthogonal columns, and R is an upper triangular matrix -C with diagonal elements of nonincreasing magnitude. -C The routine needs the full upper triangle of R, the permutation -C matrix P, and the first n components of Q'*b (' denotes the -C transpose). On output, MD03BY also provides an upper triangular -C matrix S such that -C -C P'*(A'*A + PAR*D*D)*P = S'*S . -C -C Matrix S is used in the solution process. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrices R and S -C should be estimated, as follows: -C = 'E' : use incremental condition estimation for R and S; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R and S for zero values; -C = 'U' : use the rank already stored in RANK (for R). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N >= 0. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the full upper triangle is unaltered, and the -C strict lower triangle contains the strict upper triangle -C (transposed) of the upper triangular matrix S. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C A*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of the -C Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this parameter. -C -C RANK (input or output) INTEGER -C On entry, if COND = 'U', this parameter must contain the -C (numerical) rank of the matrix R. -C On exit, this parameter contains the numerical rank of -C the matrix S. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system A*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -R*P'*x. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C rank of the matrices R and S. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 4*N, if COND = 'E'; -C LDWORK >= 2*N, if COND <> 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm computes the Gauss-Newton direction. A least squares -C solution is found if the Jacobian is rank deficient. If the Gauss- -C Newton direction is not acceptable, then an iterative algorithm -C obtains improved lower and upper bounds for the parameter PAR. -C Only a few iterations are generally needed for convergence of the -C algorithm. If, however, the limit of ITMAX = 10 iterations is -C reached, then the output PAR will contain the best value obtained -C so far. If the Gauss-Newton step is acceptable, it is stored in x, -C and PAR is set to zero, hence S = R. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C This routine is a LAPACK-based modification of LMPAR from the -C MINPACK package [1], and with optional condition estimation. -C The option COND = 'U' is useful when dealing with several -C right-hand side vectors, but RANK should be reset. -C If COND = 'E', but the matrix S is guaranteed to be nonsingular -C and well conditioned relative to TOL, i.e., rank(R) = N, and -C min(DIAG) > 0, then its condition is not estimated. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 10 ) - DOUBLE PRECISION P1, P001, ZERO, SVLMAX - PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, - $ SVLMAX = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, N, RANK - DOUBLE PRECISION DELTA, PAR, TOL -C .. Array Arguments .. - INTEGER IPVT(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) -C .. Local Scalars .. - INTEGER ITER, J, L, N2 - DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, - $ PARU, TEMP, TOLDEF - LOGICAL ECOND, NCOND, SING, UCOND - CHARACTER CONDL -C .. Local Arrays .. - DOUBLE PRECISION DUM(3) -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSWAP, DTRMV, DTRSV, MB02YD, - $ MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - UCOND = LSAME( COND, 'U' ) - INFO = 0 - IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( DELTA.LE.ZERO ) THEN - INFO = -8 - ELSEIF( PAR.LT.ZERO ) THEN - INFO = -9 - ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN - INFO = -10 - ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN - INFO = -15 - ELSEIF ( N.GT.0 ) THEN - DMINO = DIAG(1) - SING = .FALSE. -C - DO 10 J = 1, N - IF ( DIAG(J).LT.DMINO ) - $ DMINO = DIAG(J) - SING = SING .OR. DIAG(J).EQ.ZERO - 10 CONTINUE -C - IF ( SING ) - $ INFO = -6 - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'MD03BY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - PAR = ZERO - RANK = 0 - RETURN - END IF -C -C DWARF is the smallest positive magnitude. -C - DWARF = DLAMCH( 'Underflow' ) - N2 = N -C -C Estimate the rank of R, if required. -C - IF ( ECOND ) THEN - N2 = 2*N - TEMP = TOL - IF ( TEMP.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - TEMP = DBLE( N )*DLAMCH( 'Epsilon' ) - END IF -C -C Estimate the reciprocal condition number of R and set the rank. -C Workspace: 2*N. -C - CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TEMP, SVLMAX, DWORK, - $ RANK, DUM, DWORK, LDWORK, INFO ) -C - ELSEIF ( NCOND ) THEN - J = 1 -C - 20 CONTINUE - IF ( R(J,J).NE.ZERO ) THEN - J = J + 1 - IF ( J.LE.N ) - $ GO TO 20 - END IF -C - RANK = J - 1 - END IF -C -C Compute and store in x the Gauss-Newton direction. If the -C Jacobian is rank-deficient, obtain a least squares solution. -C The array RX is used as workspace. -C - CALL DCOPY( RANK, QTB, 1, RX, 1 ) - DUM(1) = ZERO - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) - CALL DTRSV( 'Upper', 'No transpose', 'Non unit', RANK, R, LDR, - $ RX, 1 ) -C - DO 30 J = 1, N - L = IPVT(J) - X(L) = RX(J) - 30 CONTINUE -C -C Initialize the iteration counter. -C Evaluate the function at the origin, and test -C for acceptance of the Gauss-Newton direction. -C - ITER = 0 -C - DO 40 J = 1, N - DWORK(J) = DIAG(J)*X(J) - 40 CONTINUE -C - DXNORM = DNRM2( N, DWORK, 1 ) - FP = DXNORM - DELTA - IF ( FP.GT.P1*DELTA ) THEN -C -C Set an appropriate option for estimating the condition of -C the matrix S. -C - IF ( UCOND ) THEN - IF ( LDWORK.GE.4*N ) THEN - CONDL = 'E' - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ELSE - CONDL = 'N' - TOLDEF = TOL - END IF - ELSE - CONDL = COND - TOLDEF = TOL - END IF -C -C If the Jacobian is not rank deficient, the Newton -C step provides a lower bound, PARL, for the zero of -C the function. Otherwise set this bound to zero. -C - IF ( RANK.EQ.N ) THEN -C - DO 50 J = 1, N - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) - 50 CONTINUE -C - CALL DTRSV( 'Upper', 'Transpose', 'Non unit', N, R, LDR, - $ RX, 1 ) - TEMP = DNRM2( N, RX, 1 ) - PARL = ( ( FP/DELTA )/TEMP )/TEMP -C -C For efficiency, use CONDL = 'U', if possible. -C - IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) - $ CONDL = 'U' - ELSE - PARL = ZERO - END IF -C -C Calculate an upper bound, PARU, for the zero of the function. -C - DO 60 J = 1, N - L = IPVT(J) - RX(J) = DDOT( J, R(1,J), 1, QTB, 1 )/DIAG(L) - 60 CONTINUE -C - GNORM = DNRM2( N, RX, 1 ) - PARU = GNORM/DELTA - IF ( PARU.EQ.ZERO ) - $ PARU = DWARF/MIN( DELTA, P1 )/P001 -C -C If the input PAR lies outside of the interval (PARL,PARU), -C set PAR to the closer endpoint. -C - PAR = MAX( PAR, PARL ) - PAR = MIN( PAR, PARU ) - IF ( PAR.EQ.ZERO ) - $ PAR = GNORM/DXNORM -C -C Beginning of an iteration. -C - 70 CONTINUE - ITER = ITER + 1 -C -C Evaluate the function at the current value of PAR. -C - IF ( PAR.EQ.ZERO ) - $ PAR = MAX( DWARF, P001*PARU ) - TEMP = SQRT( PAR ) -C - DO 80 J = 1, N - RX(J) = TEMP*DIAG(J) - 80 CONTINUE -C -C Solve the system A*x = b , sqrt(PAR)*D*x = 0 , in a least -C square sense. The first N elements of DWORK contain the -C diagonal elements of the upper triangular matrix S, and -C the next N elements contain the vector z, so that x = P*z. -C The vector z is preserved if COND = 'E'. -C Workspace: 4*N, if CONDL = 'E'; -C 2*N, if CONDL <> 'E'. -C - CALL MB02YD( CONDL, N, R, LDR, IPVT, RX, QTB, RANK, X, - $ TOLDEF, DWORK, LDWORK, INFO ) -C - DO 90 J = 1, N - DWORK(N2+J) = DIAG(J)*X(J) - 90 CONTINUE -C - DXNORM = DNRM2( N, DWORK(N2+1), 1 ) - TEMP = FP - FP = DXNORM - DELTA -C -C If the function is small enough, accept the current value -C of PAR. Also test for the exceptional cases where PARL -C is zero or the number of iterations has reached ITMAX. -C - IF ( ABS( FP ).GT.P1*DELTA .AND. - $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. - $ ITER.LT.ITMAX ) THEN -C -C Compute the Newton correction. -C - DO 100 J = 1, RANK - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(N2+L)/DXNORM ) - 100 CONTINUE -C - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) - CALL DSWAP( N, R, LDR+1, DWORK, 1 ) - CALL DTRSV( 'Lower', 'No transpose', 'Non Unit', RANK, - $ R, LDR, RX, 1 ) - CALL DSWAP( N, R, LDR+1, DWORK, 1 ) - TEMP = DNRM2( RANK, RX, 1 ) - PARC = ( ( FP/DELTA )/TEMP )/TEMP -C -C Depending on the sign of the function, update PARL -C or PARU. -C - IF ( FP.GT.ZERO ) THEN - PARL = MAX( PARL, PAR ) - ELSE IF ( FP.LT.ZERO ) THEN - PARU = MIN( PARU, PAR ) - END IF -C -C Compute an improved estimate for PAR. -C - PAR = MAX( PARL, PAR + PARC ) -C -C End of an iteration. -C - GO TO 70 - END IF - END IF -C -C Compute -R*P'*x = -R*z. -C - IF ( ECOND .AND. ITER.GT.0 ) THEN -C - DO 110 J = 1, N - RX(J) = -DWORK(N+J) - 110 CONTINUE -C - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, R, LDR, - $ RX, 1 ) - ELSE -C - DO 120 J = 1, N - RX(J) = ZERO - L = IPVT(J) - CALL DAXPY( J, -X(L), R(1,J), 1, RX, 1 ) - 120 CONTINUE -C - END IF -C -C Termination. If PAR = 0, set S. -C - IF ( ITER.EQ.0 ) THEN - PAR = ZERO -C - DO 130 J = 1, N - 1 - DWORK(J) = R(J,J) - CALL DCOPY( N-J, R(J,J+1), LDR, R(J+1,J), 1 ) - 130 CONTINUE -C - DWORK(N) = R(N,N) - END IF -C - RETURN -C -C *** Last line of MD03BY *** - END diff --git a/slycot/src/NF01AD.f b/slycot/src/NF01AD.f deleted file mode 100644 index 16af66a2..00000000 --- a/slycot/src/NF01AD.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the output y of the Wiener system -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t) = f(z(t),wb(1:L)), -C -C where t = 1, 2, ..., NSMP, and f is a nonlinear function, -C evaluated by the SLICOT Library routine NF01AY. The parameter -C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), -C where wb(i), i = 1:L, correspond to the nonlinear part, theta -C corresponds to the linear part, and the notation is fully -C described below. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C M (input) INTEGER -C The length of each input sample. M >= 0. -C -C L (input) INTEGER -C The length of each output sample. L >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed. -C IPAR(1) must contain the order of the linear part, -C referred to as N below. N >= 0. -C IPAR(2) must contain the number of neurons for the -C nonlinear part, referred to as NN below. -C NN >= 0. -C -C LIPAR (input) INTEGER -C The length of IPAR. LIPAR >= 2. -C -C X (input) DOUBLE PRECISION array, dimension (LX) -C The parameter vector, partitioned as -C X = (wb(1), ..., wb(L), theta), where the vectors -C wb(i), of length NN*(L+2)+1, are parameters for the -C static nonlinearity, which is simulated by the -C SLICOT Library routine NF01AY. See the documentation of -C NF01AY for further details. The vector theta, of length -C N*(M + L + 1) + L*M, represents the matrices A, B, C, -C D and x(1), and it can be retrieved from these matrices -C by SLICOT Library routine TB01VD and retranslated by -C TB01VY. -C -C LX (input) INTEGER -C The length of the array X. -C LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of the array U. LDU >= MAX(1,NSMP). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array contains the -C simulated output. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ) -C if M > 0; -C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M = 0. -C A larger value of LDWORK could improve the efficiency. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C METHOD -C -C BLAS routines are used for the matrix-vector multiplications and -C the routine NF01AY is called for the calculation of the nonlinear -C function. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Mar. 2001, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Dec. 2001. -C -C KEYWORDS -C -C Nonlinear system, output normal form, simulation, state-space -C representation, Wiener system. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, L, LDU, LDWORK, LDY, LX, LIPAR, M, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER AC, BD, IX, JW, LDAC, LTHS, N, NN, NTHS, Z -C .. External Subroutines .. - EXTERNAL NF01AY, TB01VY, TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( NSMP.LT.0 ) THEN - INFO = -1 - ELSEIF ( M.LT.0 ) THEN - INFO = -2 - ELSEIF ( L.LT.0 ) THEN - INFO = -3 - ELSEIF ( LIPAR.LT.2 ) THEN - INFO = -5 - ELSE -C - N = IPAR(1) - NN = IPAR(2) - LDAC = N + L - NTHS = ( NN*( L + 2 ) + 1 )*L - LTHS = N*( M + L + 1 ) + L*M -C - IF ( N.LT.0 .OR. NN.LT.0 ) THEN - INFO = -4 - ELSEIF ( LX.LT.NTHS + LTHS ) THEN - INFO = -7 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -9 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -11 - ELSE - IF ( M.GT.0 ) THEN - JW = MAX( N*LDAC, N + M + L ) - ELSE - JW = MAX( N*LDAC, L ) - END IF - IF ( LDWORK.LT.NSMP*L + MAX( 2*NN, LDAC*( N + M ) + 2*N + - $ JW ) ) - $ INFO = -13 - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01AD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, L ).EQ.0 ) - $ RETURN -C -C Compute the output of the linear part. -C Workspace: need NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). -C (NSMP*L locations are reserved for the output of the linear part.) -C - Z = 1 - AC = Z + NSMP*L - BD = AC + LDAC*N - IX = BD + LDAC*M - JW = IX + N -C - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, - $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), - $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) -C -C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, if M>0; -C NSMP*L + (N + L)*N + 2*N + L, if M=0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), - $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) -C -C Simulate the static nonlinearity. -C Workspace: need NSMP*L + 2*NN; -C prefer larger. -C - JW = AC - CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), - $ NSMP, Y, LDY, DWORK(JW), LDWORK-JW+1, INFO ) -C - RETURN -C -C *** Last line of NF01AD *** - END diff --git a/slycot/src/NF01AY.f b/slycot/src/NF01AY.f deleted file mode 100644 index cc9782a8..00000000 --- a/slycot/src/NF01AY.f +++ /dev/null @@ -1,353 +0,0 @@ - SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ, - $ Y, LDY, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the output of a set of neural networks with the -C structure -C -C - tanh(w1'*z+b1) - -C / : \ -C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, -C \ : / -C - tanh(wn'*z+bn) - -C -C given the input z and the parameter vectors wi, ws, and b, -C where z, w1, ..., wn are vectors of length NZ, ws is a vector -C of length n, b(1), ..., b(n+1) are scalars, and n is called the -C number of neurons in the hidden layer, or just number of neurons. -C Such a network is used for each L output variables. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C NZ (input) INTEGER -C The length of each input sample. NZ >= 0. -C -C L (input) INTEGER -C The length of each output sample. L >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters needed. -C IPAR(1) must contain the number of neurons, n, per output -C variable, denoted NN in the sequel. NN >= 0. -C -C LIPAR (input) INTEGER -C The length of the vector IPAR. LIPAR >= 1. -C -C WB (input) DOUBLE PRECISION array, dimension (LWB) -C The leading (NN*(NZ+2)+1)*L part of this array must -C contain the weights and biases of the network. This vector -C is partitioned into L vectors of length NN*(NZ+2)+1, -C WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L, -C corresponds to one output variable, and has the structure -C wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ), -C ws(1), ..., ws(n), b(1), ..., b(n+1) ], -C where wi(j) are the weights of the hidden layer, -C ws(i) are the weights of the linear output layer, and -C b(i) are the biases, as in the scheme above. -C -C LWB (input) INTEGER -C The length of the array WB. -C LWB >= ( NN*(NZ + 2) + 1 )*L. -C -C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) -C The leading NSMP-by-NZ part of this array must contain the -C set of input samples, -C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= MAX(1,NSMP). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY, L) -C The leading NSMP-by-L part of this array contains the set -C of output samples, -C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= MAX(1,NSMP). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 2*NN. -C For better performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C BLAS routines are used to compute the matrix-vector products. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Input output description, neural network, nonlinear system, -C simulation, system response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, L, LDWORK, LDY, LDZ, LIPAR, LWB, NSMP, NZ -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), WB(*), Y(LDY,*), Z(LDZ,*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL LAST - INTEGER I, IB, J, K, LDWB, LJ, LK, M, MF, NN, NV, WS - DOUBLE PRECISION BIGNUM, DF, SMLNUM, TMP -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD -C .. -C .. Executable Statements .. -C - INFO = 0 - NN = IPAR(1) - LDWB = NN*( NZ + 2 ) + 1 - IF ( NSMP.LT.0 ) THEN - INFO = -1 - ELSEIF ( NZ.LT.0 ) THEN - INFO = -2 - ELSEIF ( L.LT.0 ) THEN - INFO = -3 - ELSEIF ( NN.LT.0 ) THEN - INFO = -4 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( LWB.LT.LDWB*L ) THEN - INFO = -7 - ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN - INFO = -9 - ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN - INFO = -11 - ELSEIF ( LDWORK.LT.2*NN ) THEN - INFO = -13 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01AY', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, L ).EQ.0 ) - $ RETURN -C -C Set parameters to avoid overflows and increase accuracy for -C extreme values. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = LOG( SMLNUM ) - BIGNUM = LOG( BIGNUM ) -C - WS = NZ*NN + 1 - IB = WS + NN - 1 - LK = 0 - IF ( MIN( NZ, NN ).EQ.0 ) THEN - NV = 2 - ELSE - NV = ( LDWORK - NN )/NN - END IF -C - IF ( NV.GT.2 ) THEN - MF = ( NSMP/NV )*NV - LAST = MOD( NSMP, NV ).NE.0 -C -C Some BLAS 3 calculations can be used. -C - DO 70 K = 0, L - 1 - TMP = WB(IB+NN+1+LK) -C - DO 10 J = 1, NN - DWORK(J) = TWO*WB(IB+J+LK) - 10 CONTINUE -C - DO 40 I = 1, MF, NV -C -C Compute -2*[w1 w2 ... wn]'*Z', where -C Z = [z(i)';...; z(i+NV-1)']. -C - CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, - $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), - $ NN ) - LJ = NN -C - DO 30 M = 1, NV - DO 20 J = 1, NN -C -C Compute tanh(wj'*z(i) + bj), j = 1:n. -C - LJ = LJ + 1 - DF = DWORK(LJ) - DWORK(J) - IF ( ABS( DF ).GE.BIGNUM ) THEN - IF ( DF.GT.ZERO ) THEN - DWORK(LJ) = -ONE - ELSE - DWORK(LJ) = ONE - END IF - ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN - DWORK(LJ) = ZERO - ELSE - DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE - END IF - 20 CONTINUE -C - 30 CONTINUE -C - Y(I, K+1) = TMP - CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) - CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, - $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) - 40 CONTINUE -C - IF ( LAST ) THEN -C -C Process the last samples. -C - NV = NSMP - MF - I = MF + 1 -C -C Compute -2*[w1 w2 ... wn]'*Z', where -C Z = [z(i)';...; z(NSMP)']. -C - CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, - $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), - $ NN ) - LJ = NN -C - DO 60 M = 1, NV - DO 50 J = 1, NN -C -C Compute tanh(wj'*z(i) + bj), j = 1:n. -C - LJ = LJ + 1 - DF = DWORK(LJ) - DWORK(J) - IF ( ABS( DF ).GE.BIGNUM ) THEN - IF ( DF.GT.ZERO ) THEN - DWORK(LJ) = -ONE - ELSE - DWORK(LJ) = ONE - END IF - ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN - DWORK(LJ) = ZERO - ELSE - DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE - END IF - 50 CONTINUE -C - 60 CONTINUE -C - Y(I, K+1) = TMP - IF ( NV.GT.1 ) - $ CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) - CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, - $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) - END IF -C - LK = LK + LDWB - 70 CONTINUE -C - ELSE -C -C BLAS 2 calculations only can be used. -C - DO 110 K = 0, L - 1 - TMP = WB(IB+NN+1+LK) -C - DO 80 J = 1, NN - DWORK(J) = TWO*WB(IB+J+LK) - 80 CONTINUE -C - DO 100 I = 1, NSMP -C -C Compute -2*[w1 w2 ... wn]'*z(i). -C - IF ( NZ.EQ.0 ) THEN - DWORK(NN+1) = ZERO - CALL DCOPY( NN, DWORK(NN+1), 0, DWORK(NN+1), 1 ) - ELSE - CALL DGEMV( 'Transpose', NZ, NN, -TWO, WB(1+LK), NZ, - $ Z(I,1), LDZ, ZERO, DWORK(NN+1), 1 ) - END IF -C - DO 90 J = NN + 1, 2*NN -C -C Compute tanh(wj'*z(i) + bj), j = 1:n. -C - DF = DWORK(J) - DWORK(J-NN) - IF ( ABS( DF ).GE.BIGNUM ) THEN - IF ( DF.GT.ZERO ) THEN - DWORK(J) = -ONE - ELSE - DWORK(J) = ONE - END IF - ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN - DWORK(J) = ZERO - ELSE - DWORK(J) = TWO/( ONE + EXP( DF ) ) - ONE - END IF - 90 CONTINUE -C - Y(I, K+1) = DDOT( NN, WB(WS+LK), 1, DWORK(NN+1), 1 ) + - $ TMP - 100 CONTINUE -C - LK = LK + LDWB - 110 CONTINUE -C - END IF - RETURN -C -C *** Last line of NF01AY *** - END diff --git a/slycot/src/NF01BA.f b/slycot/src/NF01BA.f deleted file mode 100644 index 98c344a3..00000000 --- a/slycot/src/NF01BA.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE NF01BA( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, - $ NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing the parameters of the -C nonlinear part of a Wiener system (initialization phase), using -C SLICOT Library routine MD03AD. See the argument FCN in the -C routine MD03AD for the description of parameters. Note that -C NF01BA is called for each output of the Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to activate the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'C' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, - $ NFEVL, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), X(*), - $ Y(LDY,*), Z(LDZ,*) -C .. Local Scalars .. - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AY, NF01BY -C -C .. Executable Statements .. -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AY to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array Z must -C contain the output of the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(2) must contain the number of outputs. -C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); -C prefer: larger. -C - CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, - $ E, NSMP, DWORK, LDWORK, INFO ) - CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) - DWORK(1) = 2*IPAR(3) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BY to compute the Jacobian in a compressed form. -C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. -C Workspace: need: 0. -C - CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, - $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) - NFEVL = 0 - DWORK(1) = ZERO -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), and JPJ. -C - LDJ = NSMP - IPAR(1) = NSMP*N - IPAR(2) = 2*IPAR(3) - IPAR(3) = 0 - IPAR(4) = NSMP -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NSMP, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BA *** - END diff --git a/slycot/src/NF01BB.f b/slycot/src/NF01BB.f deleted file mode 100644 index ec39f9b3..00000000 --- a/slycot/src/NF01BB.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE NF01BB( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, - $ X, NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing all parameters of a Wiener -C system using SLICOT Library routine MD03AD. See the argument FCN -C in the routine MD03AD for the description of parameters. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to activate the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'C' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, - $ NFEVL, NFUN -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), U(LDU,*), - $ X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AD, NF01BD -C -C .. Executable Statements .. -C - L = IPAR(2) - M = IPAR(5) - N = IPAR(6) - IF ( L.EQ.0 ) THEN - NSMP = NFUN - ELSE - NSMP = NFUN/L - END IF -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AD to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array U must -C contain the input to the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(6) must contain the number of states of the linear part, n. -C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ), -C if M>0, -C NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M=0, -C where NN = IPAR(7) (number of neurons); -C prefer: larger. -C - CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, - $ NSMP, DWORK, LDWORK, INFO ) -C - DO 10 I = 1, L - CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) - 10 CONTINUE -C - DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BD to compute the Jacobian in a compressed form. -C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L )), -C if M > 0, -C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), -C if M = 0; -C prefer: larger. -C - CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, - $ LDU, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) - NFEVL = IPAR(6)*( M + L + 1 ) + L*M - DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), and JTJ. -C - ST = IPAR(1) - BSN = IPAR(4) - NN = IPAR(7) -C - LDJ = NFUN - IPAR(1) = NFUN*( BSN + ST ) - IF ( M.GT.0 ) THEN - JWORK = MAX( N*( N + L ), N + M + L ) - ELSE - JWORK = MAX( N*( N + L ), L ) - END IF - IPAR(2) = LDJ + MAX( ( N + L )*( N + M ) + 2*N + JWORK, 2*NN ) - IPAR(3) = LDJ + IPAR(2) - IPAR(4) = 0 - IPAR(5) = NFUN -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NFUN, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BB *** - END diff --git a/slycot/src/NF01BD.f b/slycot/src/NF01BD.f deleted file mode 100644 index 3f15bc2a..00000000 --- a/slycot/src/NF01BD.f +++ /dev/null @@ -1,381 +0,0 @@ - SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, - $ E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the Jacobian dy/dX of the Wiener system -C -C x(t+1) = A*x(t) + B*u(t) -C z(t) = C*x(t) + D*u(t), -C -C y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i), -C -C where t = 1, 2, ..., NSMP, -C i = 1, 2, ..., L, -C k = 1, 2, ..., NN. -C -C NN is arbitrary eligible and has to be provided in IPAR(2), and -C X = ( wb(1), ..., wb(L), theta ) is described below. -C -C Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form -C -C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta -C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta -C ..... ..... ..... ..... ..... -C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta -C -C but it will be returned without the zero blocks, in the form -C -C dy(1)/dwb(1) dy(1)/dtheta -C ... -C dy(L)/dwb(L) dy(L)/dtheta. -C -C dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY; -C dy(i)/dtheta is computed by a forward-difference approximation. -C -C ARGUMENTS -C -C Mode Parameters -C -C CJTE CHARACTER*1 -C Specifies whether the matrix-vector product J'*e should be -C computed or not, as follows: -C = 'C' : compute J'*e; -C = 'N' : do not compute J'*e. -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C M (input) INTEGER -C The length of each input sample. M >= 0. -C -C L (input) INTEGER -C The length of each output sample. L >= 0. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C On entry, the first entries of this array must contain -C the integer parameters needed; specifically, -C IPAR(1) must contain the order of the linear part, N; -C actually, N = abs(IPAR(1)), since setting -C IPAR(1) < 0 has a special meaning (see below); -C IPAR(2) must contain the number of neurons for the -C nonlinear part, NN, NN >= 0. -C On exit, if IPAR(1) < 0 on entry, then no computations are -C performed, except the needed tests on input parameters, -C but the following values are returned: -C IPAR(1) contains the length of the array J, LJ; -C LDJ contains the leading dimension of array J. -C Otherwise, IPAR(1) and LDJ are unchanged on exit. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 2. -C -C X (input) DOUBLE PRECISION array, dimension (LX) -C The leading LPAR entries of this array must contain the -C set of system parameters, where -C LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. -C X has the form (wb(1), ..., wb(L), theta), where the -C vectors wb(i) have the structure -C (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L), -C ws(1), ..., ws(NN), b(1), ..., b(NN+1) ), -C and the vector theta represents the matrices A, B, C, D -C and x(1), and it can be retrieved from these matrices -C by SLICOT Library routine TB01VD and retranslated by -C TB01VY. -C -C LX (input) INTEGER -C The length of X. -C LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. -C -C U (input) DOUBLE PRECISION array, dimension (LDU, M) -C The leading NSMP-by-M part of this array must contain the -C set of input samples, -C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NSMP). -C -C E (input) DOUBLE PRECISION array, dimension (NSMP*L) -C If CJTE = 'C', this array must contain a vector e, which -C will be premultiplied with J', e = vec( Y - y ), where -C Y is set of output samples, and vec denotes the -C concatenation of the columns of a matrix. -C If CJTE = 'N', this array is not referenced. -C -C J (output) DOUBLE PRECISION array, dimension (LDJ, *) -C The leading NSMP*L-by-NCOLJ part of this array contains -C the Jacobian of the error function stored in a compressed -C form, as described above, where -C NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M. -C -C LDJ INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NSMP*L). -C Note that LDJ is an input parameter, except for -C IPAR(1) < 0 on entry, when it is an output parameter. -C -C JTE (output) DOUBLE PRECISION array, dimension (LPAR) -C If CJTE = 'C', this array contains the matrix-vector -C product J'*e. -C If CJTE = 'N', this array is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ) -C if M > 0; -C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M = 0. -C A larger value of LDWORK could improve the efficiency. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C BLAS routines are used for the matrix-vector multiplications, and -C the SLICOT Library routine TB01VY is called for the conversion of -C the output normal form parameters to an LTI-system; the routine -C NF01AD is then used for the simulation of the system with given -C parameters, and the routine NF01BY is called for the (analytically -C performed) calculation of the parts referring to the parameters -C of the static nonlinearity. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Mar. 2001, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Dec. 2001. -C -C KEYWORDS -C -C Jacobian matrix, nonlinear system, output normal form, simulation, -C state-space representation, Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. -C .. EPSFCN is related to the error in computing the functions .. -C .. For EPSFCN = 0.0D0, the square root of the machine precision -C .. is used for finite difference approximation of the derivatives. - DOUBLE PRECISION ZERO, ONE, EPSFCN - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EPSFCN = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER CJTE - INTEGER INFO, L, LDJ, LDU, LDWORK, LX, LIPAR, M, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ, *), JTE(*), U(LDU,*), - $ X(*) -C .. Local Scalars .. - LOGICAL WJTE - DOUBLE PRECISION EPS, H, PARSAV - INTEGER AC, BD, BSN, I, IX, IY, JW, K, KCOL, LDAC, LPAR, - $ LTHS, N, NN, NSML, NTHS, Z -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, NF01AD, NF01AY, NF01BY, TB01VY, - $ TF01MX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C - N = IPAR(1) - NN = IPAR(2) - BSN = NN*( L + 2 ) + 1 - NSML = NSMP*L - NTHS = BSN*L - LTHS = N*( M + L + 1 ) + L*M - LPAR = NTHS + LTHS - WJTE = LSAME( CJTE, 'C' ) -C -C Check the scalar input parameters. -C - INFO = 0 - IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( NSMP.LT.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 ) THEN - INFO = -4 - ELSEIF ( NN.LT.0 ) THEN - INFO = -5 - ELSEIF ( LIPAR.LT.2 ) THEN - INFO = -6 - ELSEIF ( IPAR(1).LT.0 ) THEN - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BD', -INFO ) - ELSE - IPAR(1) = NSML*( ABS( N )*( M + L + 1 ) + L*M + BSN ) - LDJ = MAX( 1, NSML ) - ENDIF - RETURN - ELSEIF ( LX.LT.LPAR ) THEN - INFO = -8 - ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN - INFO = -10 - ELSEIF ( LDJ.LT.MAX( 1, NSML ) ) THEN - INFO = -13 - ELSE - LDAC = N + L - IF ( M.GT.0 ) THEN - JW = MAX( N*LDAC, N + M + L ) - ELSE - JW = MAX( N*LDAC, L ) - END IF - IF ( LDWORK.LT.2*NSML + MAX( 2*NN, LDAC*( N + M ) + 2*N + JW )) - $ INFO = -16 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, L ).EQ.0 ) THEN - IF ( WJTE .AND. LPAR.GE.1 ) THEN - JTE(1) = ZERO - CALL DCOPY( LPAR, JTE(1), 0, JTE(1), 1 ) - END IF - RETURN - END IF -C -C Compute the output of the linear part. -C Workspace: need 2*NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). -C (2*NSMP*L locations are reserved for computing two times the -C output of the linear part.) -C - IY = 1 - Z = IY + NSML - AC = Z + NSML - BD = AC + LDAC*N - IX = BD + LDAC*M - JW = IX + N -C - CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, - $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), - $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) -C -C Workspace: need 2*NSMP*L + (N + L)*(N + M) + 3*N + M + L, -C if M > 0; -C 2*NSMP*L + (N + L)*N + 2*N + L, if M = 0; -C prefer larger. -C - CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), - $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) -C -C Fill the blocks dy(i)/dwb(i) and the corresponding parts of JTE, -C if needed. -C - JW = AC - IF ( WJTE ) THEN -C - DO 10 I = 0, L - 1 - CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), - $ BSN, DWORK(Z), NSMP, E(I*NSMP+1), - $ J(I*NSMP+1,1), LDJ, JTE(I*BSN+1), DWORK(JW), - $ LDWORK-JW+1, INFO ) - 10 CONTINUE -C - ELSE -C - DO 20 I = 0, L - 1 - CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), - $ BSN, DWORK(Z), NSMP, DWORK, J(I*NSMP+1,1), LDJ, - $ DWORK, DWORK(JW), LDWORK-JW+1, INFO ) - 20 CONTINUE -C - END IF -C -C Compute the output of the system with unchanged parameters. -C Workspace: need 2*NSMP*L + 2*NN; -C prefer larger. -C - CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), - $ NSMP, DWORK(IY), NSMP, DWORK(JW), LDWORK-JW+1, - $ INFO ) -C -C Compute dy/dtheta numerically by forward-difference approximation. -C Workspace: need 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ), -C if M > 0; -C 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M = 0; -C prefer larger. -C - JW = Z - EPS = SQRT( MAX( EPSFCN, DLAMCH( 'Epsilon' ) ) ) -C - DO 40 K = NTHS + 1, LPAR - KCOL = K - NTHS + BSN - PARSAV = X(K) - IF ( PARSAV.EQ.ZERO ) THEN - H = EPS - ELSE - H = EPS*ABS( PARSAV ) - END IF - X(K) = X(K) + H - CALL NF01AD( NSMP, M, L, IPAR, LIPAR, X, LPAR, U, LDU, - $ J(1,KCOL), NSMP, DWORK(JW), LDWORK-JW+1, - $ INFO ) - X(K) = PARSAV -C - DO 30 I = 1, NSML - J(I,KCOL) = ( J(I,KCOL) - DWORK(I) ) / H - 30 CONTINUE -C - 40 CONTINUE -C - IF ( WJTE ) THEN -C -C Compute the last part of J'e in JTE. -C - CALL DGEMV( 'Transpose', NSML, LTHS, ONE, J(1,BSN+1), LDJ, E, - $ 1, ZERO, JTE(NTHS+1), 1 ) - END IF -C - RETURN -C -C *** Last line of NF01BD *** - END diff --git a/slycot/src/NF01BE.f b/slycot/src/NF01BE.f deleted file mode 100644 index a9ad1dde..00000000 --- a/slycot/src/NF01BE.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE NF01BE( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, - $ NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing the parameters of the -C nonlinear part of a Wiener system (initialization phase), using -C SLICOT Library routine MD03BD. See the argument FCN in the -C routine MD03BD for the description of parameters. Note that -C NF01BE is called for each output of the Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to avoid the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'N' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, - $ NFEVL, NSMP -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), X(*), Y(LDY,*), - $ Z(LDZ,*) -C .. Local Scalars .. - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AY, NF01BY -C -C .. Executable Statements .. -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AY to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array Z must -C contain the output of the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(2) must contain the number of outputs. -C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); -C prefer: larger. -C - CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, - $ E, NSMP, DWORK, LDWORK, INFO ) - CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) - DWORK(1) = 2*IPAR(3) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BY to compute the Jacobian in a compressed form. -C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. -C Workspace: need: 0. -C - CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, - $ LDZ, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) - NFEVL = 0 - DWORK(1) = ZERO -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. -C - LDJ = NSMP - IPAR(1) = NSMP*N - IPAR(2) = 2*IPAR(3) - IPAR(3) = 0 - IPAR(4) = 4*N + 1 - IPAR(5) = 4*N -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NSMP, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BE *** - END diff --git a/slycot/src/NF01BF.f b/slycot/src/NF01BF.f deleted file mode 100644 index d47b288d..00000000 --- a/slycot/src/NF01BF.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE NF01BF( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, - $ X, NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C This is the FCN routine for optimizing all parameters of a Wiener -C system using SLICOT Library routine MD03BD. See the argument FCN -C in the routine MD03BD for the description of parameters. -C -C ****************************************************************** -C -C .. Parameters .. -C .. CJTE is initialized to avoid the calculation of J'*e .. -C .. NOUT is the unit number for printing intermediate results .. - CHARACTER CJTE - PARAMETER ( CJTE = 'N' ) - INTEGER NOUT - PARAMETER ( NOUT = 6 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, - $ NFEVL, NFUN -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), U(LDU,*), X(*), - $ Y(LDY,*) -C .. Local Scalars .. - LOGICAL FULL - INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST - DOUBLE PRECISION ERR -C .. External Functions .. - DOUBLE PRECISION DNRM2 - EXTERNAL DNRM2 -C .. External Subroutines .. - EXTERNAL DAXPY, NF01AD, NF01BD -C -C .. Executable Statements .. -C - L = IPAR(2) - M = IPAR(5) - N = IPAR(6) - IF ( L.EQ.0 ) THEN - NSMP = NFUN - ELSE - NSMP = NFUN/L - END IF -C - INFO = 0 - IF ( IFLAG.EQ.1 ) THEN -C -C Call NF01AD to compute the output y of the Wiener system (in E) -C and then the error functions (also in E). The array U must -C contain the input to the linear part of the Wiener system, and -C Y must contain the original output Y of the Wiener system. -C IPAR(6) must contain the number of states of the linear part, n. -C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L ) ), -C if M>0, -C NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), if M=0, -C where NN = IPAR(7) (number of neurons); -C prefer: larger. -C - CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, - $ NSMP, DWORK, LDWORK, INFO ) -C - DO 10 I = 1, L - CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) - 10 CONTINUE -C - DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.2 ) THEN -C -C Call NF01BD to compute the Jacobian in a compressed form. -C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + -C MAX( N*(N + L), N + M + L )), -C if M > 0, -C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + -C MAX( N*(N + L), L ) ), -C if M > 0; -C prefer: larger. -C - CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, - $ LDU, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) - NFEVL = IPAR(6)*( M + L + 1 ) + L*M - DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + - $ MAX( N*(N + L), N + M + L ) ) -C - ELSE IF ( IFLAG.EQ.3 ) THEN -C -C Set the parameter LDJ, the length of the array J, and the sizes -C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. -C Condition estimation (COND = 'E') is assumed in these routines. -C - ST = IPAR(1) - BSN = IPAR(4) - NN = IPAR(7) - FULL = L.LE.1 .OR. BSN.EQ.0 -C - LDJ = NFUN - IPAR(1) = LDJ*( BSN + ST ) - IF ( M.GT.0 ) THEN - JWORK = MAX( N*( N + L ), N + M + L ) - ELSE - JWORK = MAX( N*( N + L ), L ) - END IF - IPAR(2) = LDJ + MAX( (N + L)*(N + M) + 2*N + JWORK, 2*NN ) - IPAR(3) = LDJ + IPAR(2) - JWORK = 1 - IF ( FULL ) THEN - JWORK = 4*LX + 1 - ELSEIF ( BSN.GT.0 ) THEN - JWORK = BSN + MAX( 3*BSN + 1, ST ) - IF ( NSMP.GT.BSN ) THEN - JWORK = MAX( JWORK, 4*ST + 1 ) - IF ( NSMP.LT.2*BSN ) - $ JWORK = MAX( JWORK, ( NSMP - BSN )*( L - 1 ) ) - END IF - END IF - IPAR(4) = JWORK - IF ( FULL ) THEN - JWORK = 4*LX - ELSE - JWORK = ST*( LX - ST ) + 2*LX + 2*MAX( BSN, ST ) - END IF - IPAR(5) = JWORK -C - ELSE IF ( IFLAG.EQ.0 ) THEN -C -C Special call for printing intermediate results. -C - ERR = DNRM2( NFUN, E, 1 ) - WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR - END IF - RETURN -C -C *** Last line of NF01BF *** - END diff --git a/slycot/src/NF01BP.f b/slycot/src/NF01BP.f deleted file mode 100644 index e15e17f4..00000000 --- a/slycot/src/NF01BP.f +++ /dev/null @@ -1,666 +0,0 @@ - SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, - $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a value for the Levenberg-Marquardt parameter PAR -C such that if x solves the system -C -C J*x = b , sqrt(PAR)*D*x = 0 , -C -C in the least squares sense, where J is an m-by-n matrix, D is an -C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if -C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, -C then either PAR is zero and -C -C ( DXNORM - DELTA ) .LE. 0.1*DELTA , -C -C or PAR is positive and -C -C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . -C -C The matrix J is the current Jacobian matrix of a nonlinear least -C squares problem, provided in a compressed form by SLICOT Library -C routine NF01BD. It is assumed that a block QR factorization, with -C column pivoting, of J is available, that is, J*P = Q*R, where P is -C a permutation matrix, Q has orthogonal columns, and R is an upper -C triangular matrix with diagonal elements of nonincreasing -C magnitude for each block, as returned by SLICOT Library -C routine NF01BS. The routine NF01BP needs the upper triangle of R -C in compressed form, the permutation matrix P, and the first -C n components of Q'*b (' denotes the transpose). On output, -C NF01BP also provides a compressed representation of an upper -C triangular matrix S, such that -C -C P'*(J'*J + PAR*D*D)*P = S'*S . -C -C Matrix S is used in the solution process. The matrix R has the -C following structure -C -C / R_1 0 .. 0 | L_1 \ -C | 0 R_2 .. 0 | L_2 | -C | : : .. : | : | , -C | 0 0 .. R_l | L_l | -C \ 0 0 .. 0 | R_l+1 / -C -C where the submatrices R_k, k = 1:l, have the same order BSN, -C and R_k, k = 1:l+1, are square and upper triangular. This matrix -C is stored in the compressed form -C -C / R_1 | L_1 \ -C | R_2 | L_2 | -C Rc = | : | : | , -C | R_l | L_l | -C \ X | R_l+1 / -C -C where the submatrix X is irrelevant. The matrix S has the same -C structure as R, and its diagonal blocks are denoted by S_k, -C k = 1:l+1. -C -C If l <= 1, then the full upper triangle of the matrix R is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the diagonal blocks R_k -C and S_k of the matrices R and S should be estimated, -C as follows: -C = 'E' : use incremental condition estimation for each -C diagonal block of R_k and S_k to find its -C numerical rank; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R_k and S_k for zero values; -C = 'U' : use the ranks already stored in RANKS (for R). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N = BN*BSN + ST >= 0. -C (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R, as follows: -C IPAR(1) must contain ST, the number of columns of the -C submatrices L_k and the order of R_l+1. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, l, in the -C block diagonal part of R. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C R_k, k = 1:l. BSM >= 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks R_k, k = 1:l. BSN >= 0. -C BSM is not used by this routine, but assumed equal to BSN. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C On entry, the leading N-by-NC part of this array must -C contain the (compressed) representation (Rc) of the upper -C triangular matrix R. If BN > 1, the submatrix X in Rc is -C not referenced. The zero strict lower triangles of R_k, -C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then -C the full upper triangle of R must be stored. -C On exit, the full upper triangles of R_k, k = 1:l+1, and -C L_k, k = 1:l, are unaltered, and the strict lower -C triangles of R_k, k = 1:l+1, contain the corresponding -C strict upper triangles (transposed) of the upper -C triangular matrix S. -C If BN <= 1 or BSN = 0, then the transpose of the strict -C upper triangle of S is stored in the strict lower triangle -C of R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. DIAG(I) <> 0, I = 1,...,N. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C DELTA (input) DOUBLE PRECISION -C An upper bound on the Euclidean norm of D*x. DELTA > 0. -C -C PAR (input/output) DOUBLE PRECISION -C On entry, PAR must contain an initial estimate of the -C Levenberg-Marquardt parameter. PAR >= 0. -C On exit, it contains the final estimate of this parameter. -C -C RANKS (input or output) INTEGER array, dimension (r), where -C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; -C r = BN, if ST = 0 and BSN > 0; -C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); -C r = 0, if ST = 0 and BSN = 0. -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical ranks of the submatrices R_k, k = 1:l(+1). -C On exit, if N > 0, this array contains the numerical ranks -C of the submatrices S_k, k = 1:l(+1). -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system J*x = b, sqrt(PAR)*D*x = 0. -C -C RX (output) DOUBLE PRECISION array, dimension (N) -C This array contains the matrix-vector product -R*P'*x. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the submatrices R_k and S_k. If the user sets -C TOL > 0, then the given value of TOL is used as a lower -C bound for the reciprocal condition number; a (sub)matrix -C whose estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S. -C If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST) -C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the -C matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and -C COND <> 'E'; -C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and -C COND = 'E'; -C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and -C COND <> 'E'; -C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), -C if BN > 1 and BSN > 0 and -C COND = 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The algorithm computes the Gauss-Newton direction. An approximate -C basic least squares solution is found if the Jacobian is rank -C deficient. The computations exploit the special structure and -C storage scheme of the matrix R. If one or more of the submatrices -C R_k or S_k, k = 1:l+1, is singular, then the computed result is -C not the basic least squares solution for the whole problem, but a -C concatenation of (least squares) solutions of the individual -C subproblems involving R_k or S_k, k = 1:l+1 (with adapted right -C hand sides). -C -C If the Gauss-Newton direction is not acceptable, then an iterative -C algorithm obtains improved lower and upper bounds for the -C Levenberg-Marquardt parameter PAR. Only a few iterations are -C generally needed for convergence of the algorithm. If, however, -C the limit of ITMAX = 10 iterations is reached, then the output PAR -C will contain the best value obtained so far. If the Gauss-Newton -C step is acceptable, it is stored in x, and PAR is set to zero, -C hence S = R. -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N*(BSN+ST)) operations and is backward -C stable, if R is nonsingular. -C -C FURTHER COMMENTS -C -C This routine is a structure-exploiting, LAPACK-based modification -C of LMPAR from the MINPACK package [1], and with optional condition -C estimation. The option COND = 'U' is useful when dealing with -C several right-hand side vectors, but RANKS array should be reset. -C If COND = 'E', but the matrix S is guaranteed to be nonsingular -C and well conditioned relative to TOL, i.e., rank(R) = N, and -C min(DIAG) > 0, then its condition is not estimated. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Feb. 2004. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 10 ) - DOUBLE PRECISION P1, P001, ZERO, ONE - PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, - $ ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, LIPAR, N - DOUBLE PRECISION DELTA, PAR, TOL -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*), RANKS(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) -C .. Local Scalars .. - INTEGER BN, BSM, BSN, I, IBSN, ITER, J, JW, K, L, LDS, - $ N2, NTHS, RANK, ST - DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, - $ PARU, SUM, TEMP, TOLDEF - LOGICAL BADRK, ECOND, NCOND, SING, UCOND - CHARACTER CONDL -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DDOT, DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DTRMV, MD03BY, NF01BQ, NF01BR, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - UCOND = LSAME( COND, 'U' ) - INFO = 0 - N2 = 2*N - IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -4 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF( DELTA.LE.ZERO ) THEN - INFO = -10 - ELSEIF( PAR.LT.ZERO ) THEN - INFO = -11 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -3 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -2 - ELSE - IF ( N.GT.0 ) - $ DMINO = DIAG(1) - SING = .FALSE. -C - DO 10 J = 1, N - IF ( DIAG(J).LT.DMINO ) - $ DMINO = DIAG(J) - SING = SING .OR. DIAG(J).EQ.ZERO - 10 CONTINUE -C - IF ( SING ) THEN - INFO = -8 - ELSEIF ( UCOND ) THEN - BADRK = .FALSE. - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( N.GT.0 ) - $ BADRK = RANKS(1).LT.0 .OR. RANKS(1).GT.N - ELSE - RANK = 0 -C - DO 20 K = 1, BN - BADRK = BADRK .OR. RANKS(K).LT.0 - $ .OR. RANKS(K).GT.BSN - RANK = RANK + RANKS(K) - 20 CONTINUE -C - IF ( ST.GT.0 ) THEN - BADRK = BADRK .OR. RANKS(BN+1).LT.0 .OR. - $ RANKS(BN+1).GT.ST - RANK = RANK + RANKS(BN+1) - END IF - END IF - IF ( BADRK ) - $ INFO = -12 - ELSE - JW = N2 - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( ECOND ) - $ JW = 4*N - ELSE - JW = ST*NTHS + JW - IF ( ECOND ) - $ JW = 2*MAX( BSN, ST ) + JW - END IF - IF ( LDWORK.LT.JW ) - $ INFO = -17 - ENDIF - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BP', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - PAR = ZERO - RETURN - END IF -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case: R is just an upper triangular matrix. -C Workspace: 4*N, if COND = 'E'; -C 2*N, if COND <> 'E'. -C - CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, - $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: l > 1 and BSN > 0. -C DWARF is the smallest positive magnitude. -C - DWARF = DLAMCH( 'Underflow' ) -C -C Compute and store in x the Gauss-Newton direction. If the -C Jacobian is rank-deficient, obtain a least squares solution. -C The array RX is used as workspace. -C Workspace: 2*MAX(BSN,ST), if COND = 'E'; -C 0, if COND <> 'E'. -C - CALL DCOPY( N, QTB, 1, RX, 1 ) - CALL NF01BR( COND, 'Upper', 'No transpose', N, IPAR, LIPAR, R, - $ LDR, DWORK, DWORK, 1, RX, RANKS, TOL, DWORK, LDWORK, - $ INFO ) -C - DO 30 J = 1, N - L = IPVT(J) - X(L) = RX(J) - 30 CONTINUE -C -C Initialize the iteration counter. -C Evaluate the function at the origin, and test -C for acceptance of the Gauss-Newton direction. -C - ITER = 0 -C - DO 40 J = 1, N - DWORK(J) = DIAG(J)*X(J) - 40 CONTINUE -C - DXNORM = DNRM2( N, DWORK, 1 ) - FP = DXNORM - DELTA - IF ( FP.GT.P1*DELTA ) THEN -C -C Set an appropriate option for estimating the condition of -C the matrix S. -C - LDS = MAX( 1, ST ) - JW = N2 + ST*NTHS - IF ( UCOND ) THEN - IF ( LDWORK.GE.JW + 2*MAX( BSN, ST ) ) THEN - CONDL = 'E' - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - ELSE - CONDL = 'N' - TOLDEF = TOL - END IF - ELSE - RANK = 0 -C - DO 50 K = 1, BN - RANK = RANK + RANKS(K) - 50 CONTINUE -C - IF ( ST.GT.0 ) - $ RANK = RANK + RANKS(BN+1) - CONDL = COND - TOLDEF = TOL - END IF -C -C If the Jacobian is not rank deficient, the Newton -C step provides a lower bound, PARL, for the zero of -C the function. Otherwise set this bound to zero. -C - IF ( RANK.EQ.N ) THEN -C - DO 60 J = 1, N - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) - 60 CONTINUE -C - CALL NF01BR( 'Use ranks', 'Upper', 'Transpose', N, IPAR, - $ LIPAR, R, LDR, DWORK, DWORK, 1, RX, RANKS, TOL, - $ DWORK, LDWORK, INFO ) - TEMP = DNRM2( N, RX, 1 ) - PARL = ( ( FP/DELTA )/TEMP )/TEMP -C -C For efficiency, use CONDL = 'U', if possible. -C - IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) - $ CONDL = 'U' - ELSE - PARL = ZERO - END IF -C - IBSN = 0 - K = 1 -C -C Calculate an upper bound, PARU, for the zero of the function. -C - DO 70 J = 1, N - IBSN = IBSN + 1 - IF ( J.LT.NTHS ) THEN - SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) - IF ( IBSN.EQ.BSN ) THEN - IBSN = 0 - K = K + BSN - END IF - ELSE IF ( J.EQ.NTHS ) THEN - SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) - ELSE - SUM = DDOT( J, R(1,IBSN), 1, QTB, 1 ) - END IF - L = IPVT(J) - RX(J) = SUM/DIAG(L) - 70 CONTINUE -C - GNORM = DNRM2( N, RX, 1 ) - PARU = GNORM/DELTA - IF ( PARU.EQ.ZERO ) - $ PARU = DWARF/MIN( DELTA, P1 )/P001 -C -C If the input PAR lies outside of the interval (PARL,PARU), -C set PAR to the closer endpoint. -C - PAR = MAX( PAR, PARL ) - PAR = MIN( PAR, PARU ) - IF ( PAR.EQ.ZERO ) - $ PAR = GNORM/DXNORM -C -C Beginning of an iteration. -C - 80 CONTINUE - ITER = ITER + 1 -C -C Evaluate the function at the current value of PAR. -C - IF ( PAR.EQ.ZERO ) - $ PAR = MAX( DWARF, P001*PARU ) - TEMP = SQRT( PAR ) -C - DO 90 J = 1, N - RX(J) = TEMP*DIAG(J) - 90 CONTINUE -C -C Solve the system J*x = b , sqrt(PAR)*D*x = 0 , in a least -C square sense. -C The first N elements of DWORK contain the diagonal elements -C of the upper triangular matrix S, and the next N elements -C contain the the vector z, so that x = P*z (see NF01BQ). -C The vector z is not preserved, to reduce the workspace. -C The elements 2*N+1 : 2*N+ST*(N-ST) contain the -C submatrix (S(1:N-ST,N-ST+1:N))' of the matrix S. -C Workspace: ST*(N-ST) + 2*N, if CONDL <> 'E'; -C ST*(N-ST) + 2*N + 2*MAX(BSN,ST), if CONDL = 'E'. -C - CALL NF01BQ( CONDL, N, IPAR, LIPAR, R, LDR, IPVT, RX, QTB, - $ RANKS, X, TOLDEF, DWORK, LDWORK, INFO ) -C - DO 100 J = 1, N - DWORK(N+J) = DIAG(J)*X(J) - 100 CONTINUE -C - DXNORM = DNRM2( N, DWORK(N+1), 1 ) - TEMP = FP - FP = DXNORM - DELTA -C -C If the function is small enough, accept the current value -C of PAR. Also test for the exceptional cases where PARL -C is zero or the number of iterations has reached ITMAX. -C - IF ( ABS( FP ).GT.P1*DELTA .AND. - $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. - $ ITER.LT.ITMAX ) THEN -C -C Compute the Newton correction. -C - DO 110 J = 1, N - L = IPVT(J) - RX(J) = DIAG(L)*( DWORK(N+L)/DXNORM ) - 110 CONTINUE -C - CALL NF01BR( 'Use ranks', 'Lower', 'Transpose', N, IPAR, - $ LIPAR, R, LDR, DWORK, DWORK(N2+1), LDS, RX, - $ RANKS, TOL, DWORK(JW), LDWORK-JW, INFO ) - TEMP = DNRM2( N, RX, 1 ) - PARC = ( ( FP/DELTA )/TEMP )/TEMP -C -C Depending on the sign of the function, update PARL -C or PARU. -C - IF ( FP.GT.ZERO ) THEN - PARL = MAX( PARL, PAR ) - ELSE IF ( FP.LT.ZERO ) THEN - PARU = MIN( PARU, PAR ) - END IF -C -C Compute an improved estimate for PAR. -C - PAR = MAX( PARL, PAR + PARC ) -C -C End of an iteration. -C - GO TO 80 - END IF - END IF -C -C Compute -R*P'*x = -R*z. -C - DO 120 J = 1, N - L = IPVT(J) - RX(J) = -X(L) - 120 CONTINUE -C - DO 130 I = 1, NTHS, BSN - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', BSN, R(I,1), - $ LDR, RX(I), 1 ) - 130 CONTINUE -C - IF ( ST.GT.0 ) THEN - CALL DGEMV( 'NoTranspose', NTHS, ST, ONE, R(1,BSN+1), LDR, - $ RX(NTHS+1), 1, ONE, RX, 1 ) - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', ST, - $ R(NTHS+1,BSN+1), LDR, RX(NTHS+1), 1 ) - END IF -C -C Termination. If PAR = 0, set S. -C - IF ( ITER.EQ.0 ) THEN - PAR = ZERO - I = 1 -C - DO 150 K = 1, BN -C - DO 140 J = 1, BSN - DWORK(I) = R(I,J) - CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 140 CONTINUE -C - 150 CONTINUE -C - IF ( ST.GT.0 ) THEN -C - DO 160 J = BSN + 1, BSN + ST - CALL DCOPY( NTHS, R(1,J), 1, DWORK(N+J-BSN), ST ) - DWORK(I) = R(I,J) - CALL DCOPY( BSN+ST-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 160 CONTINUE -C - END IF - ELSE -C - DO 170 K = N + 1, N + ST*NTHS - DWORK(K) = DWORK(K+N) - 170 CONTINUE -C - END IF -C - RETURN -C -C *** Last line of NF01BP *** - END diff --git a/slycot/src/NF01BQ.f b/slycot/src/NF01BQ.f deleted file mode 100644 index e07faaa2..00000000 --- a/slycot/src/NF01BQ.f +++ /dev/null @@ -1,477 +0,0 @@ - SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, - $ RANKS, X, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine a vector x which solves the system of linear -C equations -C -C J*x = b , D*x = 0 , -C -C in the least squares sense, where J is an m-by-n matrix, -C D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J -C is the current Jacobian of a nonlinear least squares problem, -C provided in a compressed form by SLICOT Library routine NF01BD. -C It is assumed that a block QR factorization, with column pivoting, -C of J is available, that is, J*P = Q*R, where P is a permutation -C matrix, Q has orthogonal columns, and R is an upper triangular -C matrix with diagonal elements of nonincreasing magnitude for each -C block, as returned by SLICOT Library routine NF01BS. The routine -C NF01BQ needs the upper triangle of R in compressed form, the -C permutation matrix P, and the first n components of Q'*b -C (' denotes the transpose). The system J*x = b, D*x = 0, is then -C equivalent to -C -C R*z = Q'*b , P'*D*P*z = 0 , (1) -C -C where x = P*z. If this system does not have full rank, then an -C approximate least squares solution is obtained (see METHOD). -C On output, NF01BQ also provides an upper triangular matrix S -C such that -C -C P'*(J'*J + D*D)*P = S'*S . -C -C The system (1) is equivalent to S*z = c , where c contains the -C first n components of the vector obtained by applying to -C [ (Q'*b)' 0 ]' the transformations which triangularized -C [ R' P'*D*P ]', getting S. -C -C The matrix R has the following structure -C -C / R_1 0 .. 0 | L_1 \ -C | 0 R_2 .. 0 | L_2 | -C | : : .. : | : | , -C | 0 0 .. R_l | L_l | -C \ 0 0 .. 0 | R_l+1 / -C -C where the submatrices R_k, k = 1:l, have the same order BSN, -C and R_k, k = 1:l+1, are square and upper triangular. This matrix -C is stored in the compressed form -C -C / R_1 | L_1 \ -C | R_2 | L_2 | -C Rc = | : | : | , -C | R_l | L_l | -C \ X | R_l+1 / -C -C where the submatrix X is irrelevant. The matrix S has the same -C structure as R, and its diagonal blocks are denoted by S_k, -C k = 1:l+1. -C -C If l <= 1, then the full upper triangle of the matrix R is stored. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of the matrices S_k should -C be estimated, as follows: -C = 'E' : use incremental condition estimation and store -C the numerical rank of S_k in the array entry -C RANKS(k), for k = 1:l+1; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of S_k for zero values; -C = 'U' : use the ranks already stored in RANKS(1:l+1). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N = BN*BSN + ST >= 0. -C (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R, as follows: -C IPAR(1) must contain ST, the number of columns of the -C submatrices L_k and the order of R_l+1. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, l, in the -C block diagonal part of R. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C R_k, k = 1:l. BSM >= 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks R_k, k = 1:l. BSN >= 0. -C BSM is not used by this routine, but assumed equal to BSN. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C On entry, the leading N-by-NC part of this array must -C contain the (compressed) representation (Rc) of the upper -C triangular matrix R. If BN > 1, the submatrix X in Rc is -C not referenced. The zero strict lower triangles of R_k, -C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then -C the full upper triangle of R must be stored. -C On exit, the full upper triangles of R_k, k = 1:l+1, and -C L_k, k = 1:l, are unaltered, and the strict lower -C triangles of R_k, k = 1:l+1, contain the corresponding -C strict upper triangles (transposed) of the upper -C triangular matrix S. -C If BN <= 1 or BSN = 0, then the transpose of the strict -C upper triangle of S is stored in the strict lower triangle -C of R. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= MAX(1,N). -C -C IPVT (input) INTEGER array, dimension (N) -C This array must define the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C DIAG (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the diagonal elements of the -C matrix D. -C -C QTB (input) DOUBLE PRECISION array, dimension (N) -C This array must contain the first n elements of the -C vector Q'*b. -C -C RANKS (input or output) INTEGER array, dimension (r), where -C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; -C r = BN, if ST = 0 and BSN > 0; -C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); -C r = 0, if ST = 0 and BSN = 0. -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical ranks of the submatrices S_k, k = 1:l(+1). -C On exit, if COND = 'E' or 'N' and N > 0, this array -C contains the numerical ranks of the submatrices S_k, -C k = 1:l(+1), estimated according to the value of COND. -C -C X (output) DOUBLE PRECISION array, dimension (N) -C This array contains the least squares solution of the -C system J*x = b, D*x = 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the submatrices S_k. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, the first N elements of this array contain the -C diagonal elements of the upper triangular matrix S, and -C the next N elements contain the solution z. -C If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST) -C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the -C matrix S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and -C COND <> 'E'; -C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and -C COND = 'E'; -C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and -C COND <> 'E'; -C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), -C if BN > 1 and BSN > 0 and -C COND = 'E'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Standard plane rotations are used to annihilate the elements of -C the diagonal matrix D, updating the upper triangular matrix R -C and the first n elements of the vector Q'*b. A basic least squares -C solution is computed. The computations exploit the special -C structure and storage scheme of the matrix R. If one or more of -C the submatrices S_k, k = 1:l+1, is singular, then the computed -C result is not the basic least squares solution for the whole -C problem, but a concatenation of (least squares) solutions of the -C individual subproblems involving R_k, k = 1:l+1 (with adapted -C right hand sides). -C -C REFERENCES -C -C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. -C User's Guide for MINPACK-1. -C Applied Math. Division, Argonne National Laboratory, Argonne, -C Illinois, Report ANL-80-74, 1980. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N*(BSN+ST)) operations and is backward -C stable, if R is nonsingular. -C -C FURTHER COMMENTS -C -C This routine is a structure-exploiting, LAPACK-based modification -C of QRSOLV from the MINPACK package [1], and with optional -C condition estimation. -C The option COND = 'U' is useful when dealing with several -C right-hand side vectors. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND - INTEGER INFO, LDR, LDWORK, LIPAR, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*), RANKS(*) - DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) -C .. Local Scalars .. - DOUBLE PRECISION QTBPJ - INTEGER BN, BSM, BSN, I, IB, IBSN, IS, ITC, ITR, J, - $ JW, K, KF, L, NC, NTHS, ST - LOGICAL ECOND -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, MB02YD, MB04OW, NF01BR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - INFO = 0 - IF( .NOT.( ECOND .OR. LSAME( COND, 'N' ) .OR. - $ LSAME( COND, 'U' ) ) ) THEN - INFO = -1 - ELSEIF( N.LT.0 ) THEN - INFO = -2 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -4 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -3 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -2 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE - JW = 2*N - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( ECOND ) - $ JW = 4*N - ELSE - JW = ST*NTHS + JW - IF ( ECOND ) - $ JW = 2*MAX( BSN, ST ) + JW - END IF - IF ( LDWORK.LT.JW ) - $ INFO = -14 - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BQ', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case: R is an upper triangular matrix. -C Workspace: 4*N, if COND = 'E'; -C 2*N, if COND <> 'E'. -C - CALL MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANKS(1), X, - $ TOL, DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: BN > 1 and BSN > 0. -C Copy R and Q'*b to preserve input and initialize S. -C In particular, save the diagonal elements of R in X. -C - IB = N + 1 - IS = IB + N - JW = IS + ST*NTHS - I = 1 - L = IS - NC = BSN + ST - KF = NC -C - DO 20 K = 1, BN -C - DO 10 J = 1, BSN - X(I) = R(I,J) - CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 10 CONTINUE -C - 20 CONTINUE -C -C DWORK(IS) contains a copy of [ L_1' ... L_l' ]. -C Workspace: ST*(N-ST)+2*N; -C - DO 30 J = BSN + 1, NC - CALL DCOPY( NTHS, R(1,J), 1, DWORK(L), ST ) - X(I) = R(I,J) - CALL DCOPY( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - L = L + 1 - 30 CONTINUE -C - CALL DCOPY( N, QTB, 1, DWORK(IB), 1 ) - IF ( ST.GT.0 ) THEN - ITR = NTHS + 1 - ITC = BSN + 1 - ELSE - ITR = 1 - ITC = 1 - END IF - IBSN = 0 -C -C Eliminate the diagonal matrix D using Givens rotations. -C - DO 50 J = 1, N - IBSN = IBSN + 1 - I = IBSN -C -C Prepare the row of D to be eliminated, locating the -C diagonal element using P from the QR factorization. -C - L = IPVT(J) - IF ( DIAG(L).NE.ZERO ) THEN - QTBPJ = ZERO - DWORK(J) = DIAG(L) -C - DO 40 K = J + 1, MIN( J + KF - 1, N ) - DWORK(K) = ZERO - 40 CONTINUE -C -C The transformations to eliminate the row of D modify only -C a single element of Q'*b beyond the first n, which is -C initially zero. -C - IF ( J.LT.NTHS ) THEN - CALL MB04OW( BSN-IBSN+1, ST, 1, R(J,IBSN), LDR, - $ R(ITR,ITC), LDR, DWORK(J), 1, DWORK(IB+J-1), - $ BSN, DWORK(IB+NTHS), ST, QTBPJ, 1 ) - IF ( IBSN.EQ.BSN ) - $ IBSN = 0 - ELSE IF ( J.EQ.NTHS ) THEN - CALL MB04OW( 1, ST, 1, R(J,IBSN), LDR, R(ITR,ITC), LDR, - $ DWORK(J), 1, DWORK(IB+J-1), BSN, - $ DWORK(IB+NTHS), ST, QTBPJ, 1 ) - KF = ST - ELSE - CALL MB04OW( 0, N-J+1, 1, R(J,IBSN), LDR, R(J,IBSN), LDR, - $ DWORK(J), 1, DWORK(IB+J-1), 1, - $ DWORK(IB+J-1), ST, QTBPJ, 1 ) - END IF - ELSE - IF ( J.LT.NTHS ) THEN - IF ( IBSN.EQ.BSN ) - $ IBSN = 0 - ELSE IF ( J.EQ.NTHS ) THEN - KF = ST - END IF - END IF -C -C Store the diagonal element of S. -C - DWORK(J) = R(J,I) - 50 CONTINUE -C -C Solve the triangular system for z. If the system is singular, -C then obtain an approximate least squares solution. -C Additional workspace: 2*MAX(BSN,ST), if COND = 'E'; -C 0, if COND <> 'E'. -C - CALL NF01BR( COND, 'Upper', 'NoTranspose', N, IPAR, LIPAR, R, LDR, - $ DWORK, DWORK(IS), 1, DWORK(IB), RANKS, TOL, - $ DWORK(JW), LDWORK-JW+1, INFO ) - I = 1 -C -C Restore the diagonal elements of R from X and interchange -C the upper and lower triangular parts of R. -C - DO 70 K = 1, BN -C - DO 60 J = 1, BSN - R(I,J) = X(I) - CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 60 CONTINUE -C - 70 CONTINUE -C - DO 80 J = BSN + 1, NC - CALL DSWAP( NTHS, R(1,J), 1, DWORK(IS), ST ) - R(I,J) = X(I) - CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - IS = IS + 1 - 80 CONTINUE -C -C Permute the components of z back to components of x. -C - DO 90 J = 1, N - L = IPVT(J) - X(L) = DWORK(N+J) - 90 CONTINUE -C - RETURN -C -C *** Last line of NF01BQ *** - END diff --git a/slycot/src/NF01BR.f b/slycot/src/NF01BR.f deleted file mode 100644 index 4a68dab2..00000000 --- a/slycot/src/NF01BR.f +++ /dev/null @@ -1,711 +0,0 @@ - SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR, - $ SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve one of the systems of linear equations -C -C R*x = b , or R'*x = b , -C -C in the least squares sense, where R is an n-by-n block upper -C triangular matrix, with the structure -C -C / R_1 0 .. 0 | L_1 \ -C | 0 R_2 .. 0 | L_2 | -C | : : .. : | : | , -C | 0 0 .. R_l | L_l | -C \ 0 0 .. 0 | R_l+1 / -C -C with the upper triangular submatrices R_k, k = 1:l+1, square, and -C the first l of the same order, BSN. The diagonal elements of each -C block R_k have nonincreasing magnitude. The matrix R is stored in -C the compressed form, as returned by SLICOT Library routine NF01BS, -C -C / R_1 | L_1 \ -C | R_2 | L_2 | -C Rc = | : | : | , -C | R_l | L_l | -C \ X | R_l+1 / -C -C where the submatrix X is irrelevant. If the matrix R does not have -C full rank, then a least squares solution is obtained. If l <= 1, -C then R is an upper triangular matrix and its full upper triangle -C is stored. -C -C Optionally, the transpose of the matrix R can be stored in the -C strict lower triangles of the submatrices R_k, k = 1:l+1, and in -C the arrays SDIAG and S, as described at the parameter UPLO below. -C -C ARGUMENTS -C -C Mode Parameters -C -C COND CHARACTER*1 -C Specifies whether the condition of submatrices R_k should -C be estimated, as follows: -C = 'E' : use incremental condition estimation and store -C the numerical rank of R_k in the array entry -C RANKS(k), for k = 1:l+1; -C = 'N' : do not use condition estimation, but check the -C diagonal entries of R_k for zero values; -C = 'U' : use the ranks already stored in RANKS(1:l+1). -C -C UPLO CHARACTER*1 -C Specifies the storage scheme for the matrix R, as follows: -C = 'U' : the upper triangular part is stored as in Rc; -C = 'L' : the lower triangular part is stored, namely, -C - the transpose of the strict upper triangle of -C R_k is stored in the strict lower triangle of -C R_k, for k = 1:l+1; -C - the diagonal elements of R_k, k = 1:l+1, are -C stored in the array SDIAG; -C - the transpose of the last block column in R -C (without R_l+1) is stored in the array S. -C -C TRANS CHARACTER*1 -C Specifies the form of the system of equations, as follows: -C = 'N': R*x = b (No transpose); -C = 'T': R'*x = b (Transpose); -C = 'C': R'*x = b (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix R. N = BN*BSN + ST >= 0. -C (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix R, as follows: -C IPAR(1) must contain ST, the number of columns of the -C submatrices L_k and the order of R_l+1. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, l, in the -C block diagonal part of R. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C R_k, k = 1:l. BSM >= 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks R_k, k = 1:l. BSN >= 0. -C BSM is not used by this routine, but assumed equal to BSN. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C R (input) DOUBLE PRECISION array, dimension (LDR, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C If UPLO = 'U', the leading N-by-NC part of this array must -C contain the (compressed) representation (Rc) of the upper -C triangular matrix R. The submatrix X in Rc and the strict -C lower triangular parts of the diagonal blocks R_k, -C k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then -C the full upper triangle of R must be stored. -C If UPLO = 'L', BN > 1 and BSN > 0, the leading -C (N-ST)-by-BSN part of this array must contain the -C transposes of the strict upper triangles of R_k, k = 1:l, -C stored in the strict lower triangles of R_k, and the -C strict lower triangle of R_l+1 must contain the transpose -C of the strict upper triangle of R_l+1. The submatrix X -C in Rc is not referenced. The diagonal elements of R_k, -C and, if COND = 'E', the upper triangular parts of R_k, -C k = 1:l+1, are modified internally, but are restored -C on exit. -C If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N -C strict lower triangular part of this array must contain -C the transpose of the strict upper triangular part of R. -C The diagonal elements and, if COND = 'E', the upper -C triangular elements are modified internally, but are -C restored on exit. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= MAX(1,N). -C -C SDIAG (input) DOUBLE PRECISION array, dimension (N) -C If UPLO = 'L', this array must contain the diagonal -C entries of R_k, k = 1:l+1. This array is modified -C internally, but is restored on exit. -C This parameter is not referenced if UPLO = 'U'. -C -C S (input) DOUBLE PRECISION array, dimension (LDS,N-ST) -C If UPLO = 'L', BN > 1, and BSN > 0, the leading -C ST-by-(N-ST) part of this array must contain the transpose -C of the rectangular part of the last block column in R, -C that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is -C modified internally, but is restored on exit. -C This parameter is not referenced if UPLO = 'U', or -C BN <= 1, or BSN = 0. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= 1, if UPLO = 'U', or BN <= 1, or BSN = 0; -C LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0. -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the right hand side -C vector b. -C On exit, this array contains the (least squares) solution -C of the system R*x = b or R'*x = b. -C -C RANKS (input or output) INTEGER array, dimension (r), where -C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; -C r = BN, if ST = 0 and BSN > 0; -C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); -C r = 0, if ST = 0 and BSN = 0. -C On entry, if COND = 'U' and N > 0, this array must contain -C the numerical ranks of the submatrices R_k, k = 1:l(+1). -C On exit, if COND = 'E' or 'N' and N > 0, this array -C contains the numerical ranks of the submatrices R_k, -C k = 1:l(+1), estimated according to the value of COND. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If COND = 'E', the tolerance to be used for finding the -C ranks of the submatrices R_k. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C the reciprocal condition number; a (sub)matrix whose -C estimated condition number is less than 1/TOL is -C considered to be of full rank. If the user sets TOL <= 0, -C then an implicitly computed, default tolerance, defined by -C TOLDEF = N*EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not relevant if COND = 'U' or 'N'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C Denote Full = ( BN <= 1 or BSN = 0 ); -C Comp = ( BN > 1 and BSN > 0 ). -C LDWORK >= 2*N, if Full and COND = 'E'; -C LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E'; -C LDWORK >= 0, in the remaining cases. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Block back or forward substitution is used (depending on TRANS -C and UPLO), exploiting the special structure and storage scheme of -C the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local -C basic least squares solution is computed. Therefore, the returned -C result is not the basic least squares solution for the whole -C problem, but a concatenation of (least squares) solutions of the -C individual subproblems involving R_k, k = 1:l+1 (with adapted -C right hand sides). -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires 0(BN*BSN + ST + N*ST) operations and is -C backward stable, if R is nonsingular. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Linear system of equations, matrix operations, plane rotations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, SVLMAX - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, SVLMAX = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COND, TRANS, UPLO - INTEGER INFO, LDR, LDS, LDWORK, LIPAR, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IPAR(*), RANKS(*) - DOUBLE PRECISION B(*), DWORK(*), R(LDR,*), S(LDS,*), SDIAG(*) -C .. Local Scalars .. - DOUBLE PRECISION TOLDEF - INTEGER BN, BSM, BSN, I, I1, J, K, L, NC, NTHS, RANK, ST - CHARACTER TRANSL, UPLOL - LOGICAL ECOND, FULL, LOWER, NCOND, TRANR -C .. Local Arrays .. - DOUBLE PRECISION DUM(3) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DSWAP, DTRSV, MB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - ECOND = LSAME( COND, 'E' ) - NCOND = LSAME( COND, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - TRANR = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - INFO = 0 - IF( .NOT.( ECOND .OR. NCOND .OR. LSAME( COND, 'U' ) ) ) THEN - INFO = -1 - ELSEIF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -2 - ELSEIF( .NOT.( TRANR .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -3 - ELSEIF( N.LT.0 ) THEN - INFO = -4 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -6 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - FULL = BN.LE.1 .OR. BSN.EQ.0 - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -5 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -4 - ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDS.LT.1 .OR. ( LOWER .AND. .NOT.FULL .AND. - $ LDS.LT.ST ) ) THEN - INFO = -11 - ELSE - IF ( ECOND ) THEN - IF ( FULL ) THEN - L = 2*N - ELSE - L = 2*MAX( BSN, ST ) - END IF - ELSE - L = 0 - END IF - IF ( LDWORK.LT.L ) - $ INFO = -16 - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BR', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - IF ( ECOND ) THEN - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in rank determination. -C - TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) - END IF - END IF -C - NC = BSN + ST - IF ( FULL ) THEN -C -C Special case: l <= 1 or BSN = 0; R is just an upper triangular -C matrix. -C - IF ( LOWER ) THEN -C -C Swap the diagonal elements of R and the elements of SDIAG -C and, if COND = 'E', swap the upper and lower triangular -C parts of R, in order to find the numerical rank. -C - CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) - IF ( ECOND ) THEN - UPLOL = 'U' - TRANSL = TRANS -C - DO 10 J = 1, N - CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) - 10 CONTINUE -C - ELSE - UPLOL = UPLO - IF ( TRANR ) THEN - TRANSL = 'N' - ELSE - TRANSL = 'T' - END IF - END IF - ELSE - UPLOL = UPLO - TRANSL = TRANS - END IF -C - IF ( ECOND ) THEN -C -C Estimate the reciprocal condition number and set the rank. -C Workspace: 2*N. -C - CALL MB03OD( 'No QR', N, N, R, LDR, IPAR, TOLDEF, SVLMAX, - $ DWORK, RANK, DUM, DWORK, LDWORK, INFO ) - RANKS(1) = RANK -C - ELSEIF ( NCOND ) THEN -C -C Determine rank(R) by checking zero diagonal entries. -C - RANK = N -C - DO 20 J = 1, N - IF ( R(J,J).EQ.ZERO .AND. RANK.EQ.N ) - $ RANK = J - 1 - 20 CONTINUE -C - RANKS(1) = RANK -C - ELSE -C -C Use the stored rank. -C - RANK = RANKS(1) - END IF -C -C Solve R*x = b, or R'*x = b using back or forward substitution. -C - DUM(1) = ZERO - IF ( RANK.LT.N ) - $ CALL DCOPY( N-RANK, DUM, 0, B(RANK+1), 1 ) - CALL DTRSV( UPLOL, TRANSL, 'NonUnit', RANK, R, LDR, B, 1 ) -C - IF ( LOWER ) THEN -C -C Swap the diagonal elements of R and the elements of SDIAG -C and, if COND = 'E', swap back the upper and lower triangular -C parts of R. -C - CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) - IF ( ECOND ) THEN -C - DO 30 J = 1, N - CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) - 30 CONTINUE -C - END IF -C - END IF - RETURN - END IF -C -C General case: l > 1 and BSN > 0. -C - I = 1 - L = BN - IF ( ECOND ) THEN -C -C Estimate the reciprocal condition numbers and set the ranks. -C - IF ( LOWER ) THEN -C -C Swap the diagonal elements of R and the elements of SDIAG -C and swap the upper and lower triangular parts of R, in order -C to find the numerical rank. Swap S and the transpose of the -C rectangular part of the last block column of R. -C - DO 50 K = 1, BN - CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) -C - DO 40 J = 1, BSN - CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 40 CONTINUE -C - 50 CONTINUE -C - IF ( ST.GT.0 ) THEN - CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) -C - DO 60 J = BSN + 1, NC - CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) - CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 60 CONTINUE -C - END IF -C - END IF -C - I1 = 1 -C -C Determine rank(R_k) using incremental condition estimation. -C Workspace 2*MAX(BSN,ST). -C - DO 70 K = 1, BN - CALL MB03OD( 'No QR', BSN, BSN, R(I1,1), LDR, IPAR, TOLDEF, - $ SVLMAX, DWORK, RANKS(K), DUM, DWORK, LDWORK, - $ INFO ) - I1 = I1 + BSN - 70 CONTINUE -C - IF ( ST.GT.0 ) THEN - L = L + 1 - CALL MB03OD( 'No QR', ST, ST, R(I1,BSN+1), LDR, IPAR, - $ TOLDEF, SVLMAX, DWORK, RANKS(L), DUM, DWORK, - $ LDWORK, INFO ) - END IF -C - ELSEIF ( NCOND ) THEN -C -C Determine rank(R_k) by checking zero diagonal entries. -C - IF ( LOWER ) THEN -C - DO 90 K = 1, BN - RANK = BSN -C - DO 80 J = 1, BSN - IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.BSN ) - $ RANK = J - 1 - I = I + 1 - 80 CONTINUE -C - RANKS(K) = RANK - 90 CONTINUE -C - IF ( ST.GT.0 ) THEN - L = L + 1 - RANK = ST -C - DO 100 J = 1, ST - IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.ST ) - $ RANK = J - 1 - I = I + 1 - 100 CONTINUE -C - RANKS(L) = RANK - END IF -C - ELSE -C - DO 120 K = 1, BN - RANK = BSN -C - DO 110 J = 1, BSN - IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.BSN ) - $ RANK = J - 1 - I = I + 1 - 110 CONTINUE -C - RANKS(K) = RANK - 120 CONTINUE -C - IF ( ST.GT.0 ) THEN - L = L + 1 - RANK = ST -C - DO 130 J = BSN + 1, NC - IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.ST ) - $ RANK = J - BSN - 1 - I = I + 1 - 130 CONTINUE -C - RANKS(L) = RANK - END IF - END IF -C - ELSE -C -C Set the number of elements of RANKS. Then use the stored ranks. -C - IF ( ST.GT.0 ) - $ L = L + 1 - END IF -C -C Solve the triangular system for x. If the system is singular, -C then obtain a basic least squares solution. -C - DUM(1) = ZERO - IF ( LOWER .AND. .NOT.ECOND ) THEN -C - IF ( .NOT.TRANR ) THEN -C -C Solve R*x = b using back substitution, with R' stored in -C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. -C - I1 = NTHS + 1 - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, - $ R(I1,BSN+1), LDR, B(I1), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - CALL DGEMV( 'Transpose', ST, NTHS, -ONE, S, LDS, - $ B(NTHS+1), 1, ONE, B, 1 ) - END IF -C - DO 140 K = BN, 1, -1 - I1 = I1 - BSN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, - $ R(I1,1), LDR, B(I1), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - 140 CONTINUE -C - ELSE -C -C Solve R'*x = b using forward substitution, with R' stored in -C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. -C - I1 = 1 - IF ( TRANR ) THEN - TRANSL = 'N' - ELSE - TRANSL = 'T' - END IF -C - DO 150 K = 1, BN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, R(I1,1), - $ LDR, B(I1), 1 ) - CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) - I1 = I1 + BSN - 150 CONTINUE -C - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DGEMV( 'NoTranspose', ST, NTHS, -ONE, S, LDS, B, 1, - $ ONE, B(I1), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, - $ R(I1,BSN+1), LDR, B(I1), 1 ) - CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) - END IF -C - END IF -C - ELSE -C - IF ( .NOT.TRANR ) THEN -C -C Solve R*x = b using back substitution. -C - I1 = NTHS + 1 - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), - $ LDR, B(I1), 1 ) - CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, - $ B(NTHS+1), 1, ONE, B, 1 ) - END IF -C - DO 160 K = BN, 1, -1 - I1 = I1 - BSN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), - $ LDR, B(I1), 1 ) - 160 CONTINUE -C - ELSE -C -C Solve R'*x = b using forward substitution. -C - I1 = 1 -C - DO 170 K = 1, BN - RANK = RANKS(K) - IF ( RANK.LT.BSN ) - $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), - $ LDR, B(I1), 1 ) - I1 = I1 + BSN - 170 CONTINUE -C - IF ( ST.GT.0 ) THEN - RANK = RANKS(L) - IF ( RANK.LT.ST ) - $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) - CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, B, 1, - $ ONE, B(I1), 1 ) - CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), - $ LDR, B(I1), 1 ) - END IF -C - END IF - END IF -C - IF ( ECOND .AND. LOWER ) THEN - I = 1 -C -C If COND = 'E' and UPLO = 'L', swap the diagonal elements of R -C and the elements of SDIAG and swap back the upper and lower -C triangular parts of R, including the part corresponding to S. -C - DO 190 K = 1, BN - CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) -C - DO 180 J = 1, BSN - CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 180 CONTINUE -C - 190 CONTINUE -C - IF ( ST.GT.0 ) THEN - CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) -C - DO 200 J = BSN + 1, NC - CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) - CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) - I = I + 1 - 200 CONTINUE -C - END IF -C - END IF -C - RETURN -C -C *** Last line of NF01BR *** - END diff --git a/slycot/src/NF01BS.f b/slycot/src/NF01BS.f deleted file mode 100644 index 3d7d6e5c..00000000 --- a/slycot/src/NF01BS.f +++ /dev/null @@ -1,610 +0,0 @@ - SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, - $ GNORM, IPVT, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the QR factorization of the Jacobian matrix J, as -C received in compressed form from SLICOT Library routine NF01BD, -C -C / dy(1)/dwb(1) | dy(1)/ dtheta \ -C Jc = | : | : | , -C \ dy(L)/dwb(L) | dy(L)/ dtheta / -C -C and to apply the transformation Q on the error vector e (in-situ). -C The factorization is J*P = Q*R, where Q is a matrix with -C orthogonal columns, P a permutation matrix, and R an upper -C trapezoidal matrix with diagonal elements of nonincreasing -C magnitude for each block column (see below). The 1-norm of the -C scaled gradient is also returned. -C -C Actually, the Jacobian J has the block form -C -C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta -C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta -C ..... ..... ..... ..... ..... -C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta -C -C but the zero blocks are omitted. The diagonal blocks have the -C same size and correspond to the nonlinear part. The last block -C column corresponds to the linear part. It is assumed that the -C Jacobian matrix has at least as many rows as columns. The linear -C or nonlinear parts can be empty. If L <= 1, the Jacobian is -C represented as a full matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. -C N = BN*BSN + ST >= 0. (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain ST, the number of parameters -C corresponding to the linear part. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, BN = L, -C for the parameters corresponding to the nonlinear -C part. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the -C number of rows of the matrix J, if BN <= 1. -C BN*BSM >= N, if BN > 0; -C BSM >= N, if BN = 0. -C IPAR(4) must contain BSN, the number of columns of the -C blocks J_k, k = 1:BN. BSN >= 0. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C FNORM (input) DOUBLE PRECISION -C The Euclidean norm of the vector e. FNORM >= 0. -C -C J (input/output) DOUBLE PRECISION array, dimension (LDJ, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C On entry, the leading NR-by-NC part of this array must -C contain the (compressed) representation (Jc) of the -C Jacobian matrix J, where NR = BSM if BN <= 1, and -C NR = BN*BSM, if BN > 1. -C On exit, the leading N-by-NC part of this array contains -C a (compressed) representation of the upper triangular -C factor R of the Jacobian matrix. The matrix R has the same -C structure as the Jacobian matrix J, but with an additional -C diagonal block. Note that for efficiency of the later -C calculations, the matrix R is delivered with the leading -C dimension MAX(1,N), possibly much smaller than the value -C of LDJ on entry. -C -C LDJ (input/output) INTEGER -C The leading dimension of array J. -C On entry, LDJ >= MAX(1,NR). -C On exit, LDJ >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (NR) -C On entry, this array contains the vector e, -C e = vec( Y - y ), where Y is set of output samples, and -C vec denotes the concatenation of the columns of a matrix. -C On exit, this array contains the updated vector Z*Q'*e, -C where Z is the block row permutation matrix used in the -C QR factorization of J (see METHOD). -C -C JNORMS (output) DOUBLE PRECISION array, dimension (N) -C This array contains the Euclidean norms of the columns -C of the Jacobian matrix, considered in the initial order. -C -C GNORM (output) DOUBLE PRECISION -C If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM, -C with each element i further divided by JNORMS(i) (if -C JNORMS(i) is nonzero). -C If FNORM = 0, the returned value of GNORM is 0. -C -C IPVT (output) INTEGER array, dimension (N) -C This array defines the permutation matrix P such that -C J*P = Q*R. Column j of P is column IPVT(j) of the identity -C matrix. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1, if N = 0 or BN <= 1 and BSM = N = 1; -C otherwise, -C LDWORK >= 4*N+1, if BN <= 1 or BSN = 0; -C LDWORK >= JWORK, if BN > 1 and BSN > 0, where JWORK is -C given by the following procedure: -C JWORK = BSN + MAX(3*BSN+1,ST); -C JWORK = MAX(JWORK,4*ST+1), if BSM > BSN; -C JWORK = MAX(JWORK,(BSM-BSN)*(BN-1)), -C if BSN < BSM < 2*BSN. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C A QR factorization with column pivoting of the matrix J is -C computed, J*P = Q*R. -C -C If l = L > 1, the R factor of the QR factorization has the same -C structure as the Jacobian, but with an additional diagonal block. -C Denote -C -C / J_1 0 .. 0 | L_1 \ -C | 0 J_2 .. 0 | L_2 | -C J = | : : .. : | : | . -C | : : .. : | : | -C \ 0 0 .. J_l | L_l / -C -C The algorithm consists in two phases. In the first phase, the -C algorithm uses QR factorizations with column pivoting for each -C block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the -C corresponding part of the last block column and of e. After all -C block rows have been processed, the block rows are interchanged -C so that the zeroed submatrices in the first l block columns are -C moved to the bottom part. The same block row permutation Z is -C also applied to the vector e. At the end of the first phase, -C the structure of the processed matrix J is -C -C / R_1 0 .. 0 | L^1_1 \ -C | 0 R_2 .. 0 | L^1_2 | -C | : : .. : | : | . -C | : : .. : | : | -C | 0 0 .. R_l | L^1_l | -C | 0 0 .. 0 | L^2_1 | -C | : : .. : | : | -C \ 0 0 .. 0 | L^2_l / -C -C In the second phase, the submatrix L^2_1:l is triangularized -C using an additional QR factorization with pivoting. (The columns -C of L^1_1:l are also permuted accordingly.) Therefore, the column -C pivoting is restricted to each such local block column. -C -C If l <= 1, the matrix J is triangularized in one phase, by one -C QR factorization with pivoting. In this case, the column -C pivoting is global. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. -C -C REVISIONS -C -C Feb. 22, 2004. -C -C KEYWORDS -C -C Elementary matrix operations, Jacobian matrix, matrix algebra, -C matrix operations, Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDJ, LDWORK, LIPAR, N - DOUBLE PRECISION FNORM, GNORM -C .. Array Arguments .. - INTEGER IPAR(*), IPVT(*) - DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) -C .. Local Scalars .. - INTEGER BN, BSM, BSN, I, IBSM, IBSN, IBSNI, ITAU, JL, - $ JLM, JWORK, K, L, M, MMN, NTHS, ST, WRKOPT - DOUBLE PRECISION SUM -C .. External Functions .. - DOUBLE PRECISION DDOT, DNRM2 - EXTERNAL DDOT, DNRM2 -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQP3, DLACPY, DLAPMT, DORMQR, DSWAP, - $ MD03BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSEIF( LIPAR.LT.4 ) THEN - INFO = -3 - ELSEIF ( FNORM.LT.ZERO ) THEN - INFO = -4 - ELSEIF ( LDJ.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - MMN = BSM - BSN - IF ( BN.GT.0 ) THEN - M = BN*BSM - ELSE - M = N - END IF - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -2 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -1 - ELSEIF ( M.LT.N ) THEN - INFO = -2 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE - IF ( N.EQ.0 ) THEN - JWORK = 1 - ELSEIF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN - IF ( BN.LE.1 .AND. BSM.EQ.1 .AND. N.EQ.1 ) THEN - JWORK = 1 - ELSE - JWORK = 4*N + 1 - END IF - ELSE - JWORK = BSN + MAX( 3*BSN + 1, ST ) - IF ( BSM.GT.BSN ) THEN - JWORK = MAX( JWORK, 4*ST + 1 ) - IF ( BSM.LT.2*BSN ) - $ JWORK = MAX( JWORK, MMN*( BN - 1 ) ) - END IF - END IF - IF ( LDWORK.LT.JWORK ) - $ INFO = -12 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'NF01BS', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - GNORM = ZERO - IF ( N.EQ.0 ) THEN - LDJ = 1 - DWORK(1) = ONE - RETURN - END IF -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case, l <= 1 or BSN = 0: the Jacobian is represented -C as a full matrix. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Workspace: need: 4*N + 1; -C prefer: 3*N + ( N+1 )*NB. -C - CALL MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, - $ DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: l > 1 and BSN > 0. -C Initialize the column pivoting indices. -C - DO 10 I = 1, N - IPVT(I) = 0 - 10 CONTINUE -C -C Compute the QR factorization with pivoting of J. -C Pivoting is done separately on each block column of J. -C - WRKOPT = 1 - IBSN = 1 - JL = LDJ*BSN + 1 - JWORK = BSN + 1 -C - DO 30 IBSM = 1, M, BSM -C -C Compute the QR factorization with pivoting of J_k, and apply Q' -C to the corresponding part of the last block-column and of e. -C Workspace: need: 4*BSN + 1; -C prefer: 3*BSN + ( BSN+1 )*NB. -C - CALL DGEQP3( BSM, BSN, J(IBSM), LDJ, IPVT(IBSN), DWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - IF ( IBSM.GT.1 ) THEN -C -C Adjust the column pivoting indices. -C - DO 20 I = IBSN, IBSN + BSN - 1 - IPVT(I) = IPVT(I) + IBSN - 1 - 20 CONTINUE -C - END IF -C - IF ( ST.GT.0 ) THEN -C -C Workspace: need: BSN + ST; -C prefer: BSN + ST*NB. -C - CALL DORMQR( 'Left', 'Transpose', BSM, ST, BSN, J(IBSM), - $ LDJ, DWORK, J(JL), LDJ, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - END IF -C -C Workspace: need: BSN + 1; -C prefer: BSN + NB. -C - CALL DORMQR( 'Left', 'Transpose', BSM, 1, BSN, J(IBSM), LDJ, - $ DWORK, E(IBSM), BSM, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - JL = JL + BSM - IBSN = IBSN + BSN - 30 CONTINUE -C - IF ( MMN.GT.0 ) THEN -C -C Case BSM > BSN. -C Compute the original column norms for the first block column -C of Jc. -C Permute the rows of the first block column to move the zeroed -C submatrices to the bottom. In the same loops, reshape the -C first block column of R to have the leading dimension N. -C - L = IPVT(1) - JNORMS(L) = ABS( J(1) ) - IBSM = BSM + 1 - IBSN = BSN + 1 -C - DO 40 K = 1, BN - 1 - J(IBSN) = J(IBSM) - L = IPVT(IBSN) - JNORMS(L) = ABS( J(IBSN) ) - IBSM = IBSM + BSM - IBSN = IBSN + BSN - 40 CONTINUE -C - IBSN = IBSN + ST -C - DO 60 I = 2, BSN - IBSM = ( I - 1 )*LDJ + 1 - JL = I -C - DO 50 K = 1, BN -C - DO 45 L = 0, I - 1 - J(IBSN+L) = J(IBSM+L) - 45 CONTINUE -C - L = IPVT(JL) - JNORMS(L) = DNRM2( I, J(IBSN), 1 ) - IBSM = IBSM + BSM - IBSN = IBSN + BSN - JL = JL + BSN - 50 CONTINUE -C - IBSN = IBSN + ST - 60 CONTINUE -C -C Permute the rows of the second block column of Jc and of -C the vector e. -C - JL = LDJ*BSN - IF ( BSM.GE.2*BSN ) THEN -C -C A swap operation can be used. -C - DO 80 I = 1, ST - IBSN = BSN + 1 -C - DO 70 IBSM = BSM + 1, M, BSM - CALL DSWAP( MMN, J(JL+IBSM), 1, J(JL+IBSN), 1 ) - IBSN = IBSN + BSN - 70 CONTINUE -C - JL = JL + LDJ - 80 CONTINUE -C -C Permute the rows of e. -C - IBSN = BSN + 1 -C - DO 90 IBSM = BSM + 1, M, BSM - CALL DSWAP( MMN, E(IBSM), 1, E(IBSN), 1 ) - IBSN = IBSN + BSN - 90 CONTINUE -C - ELSE -C -C A swap operation cannot be used. -C Workspace: need: ( BSM-BSN )*( BN-1 ). -C - DO 110 I = 1, ST - IBSN = BSN + 1 - JLM = JL + IBSN - JWORK = 1 -C - DO 100 IBSM = BSM + 1, M, BSM - CALL DCOPY( MMN, J(JLM), 1, DWORK(JWORK), 1 ) -C - DO 105 K = JL, JL + BSN - 1 - J(IBSN+K) = J(IBSM+K) - 105 CONTINUE -C - JLM = JLM + BSM - IBSN = IBSN + BSN - JWORK = JWORK + MMN - 100 CONTINUE -C - CALL DCOPY( MMN*( BN-1 ), DWORK, 1, J(JL+IBSN), 1 ) - JL = JL + LDJ - 110 CONTINUE -C -C Permute the rows of e. -C - IBSN = BSN + 1 - JLM = IBSN - JWORK = 1 -C - DO 120 IBSM = BSM + 1, M, BSM - CALL DCOPY( MMN, E(JLM), 1, DWORK(JWORK), 1 ) -C - DO 115 K = 0, BSN - 1 - E(IBSN+K) = E(IBSM+K) - 115 CONTINUE -C - JLM = JLM + BSM - IBSN = IBSN + BSN - JWORK = JWORK + MMN - 120 CONTINUE -C - CALL DCOPY( MMN*( BN-1 ), DWORK, 1, E(IBSN), 1 ) - END IF -C - IF ( ST.GT.0 ) THEN -C -C Compute the QR factorization with pivoting of the submatrix -C L^2_1:l, and apply Q' to the corresponding part of e. -C -C Workspace: need: 4*ST + 1; -C prefer: 3*ST + ( ST+1 )*NB. -C - JL = ( LDJ + BN )*BSN + 1 - ITAU = 1 - JWORK = ITAU + ST - CALL DGEQP3( MMN*BN, ST, J(JL), LDJ, IPVT(NTHS+1), - $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Permute columns of the upper part of the second block -C column of Jc. -C - CALL DLAPMT( .TRUE., NTHS, ST, J(JL-NTHS), LDJ, - $ IPVT(NTHS+1) ) -C -C Adjust the column pivoting indices. -C - DO 130 I = NTHS + 1, N - IPVT(I) = IPVT(I) + NTHS - 130 CONTINUE -C -C Workspace: need: ST + 1; -C prefer: ST + NB. -C - CALL DORMQR( 'Left', 'Transpose', MMN*BN, 1, ST, J(JL), LDJ, - $ DWORK(ITAU), E(IBSN), LDJ, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Reshape the second block column of R to have the leading -C dimension N. -C - IBSN = N*BSN + 1 - CALL DLACPY( 'Full', N, ST, J(LDJ*BSN+1), LDJ, J(IBSN), N ) -C -C Compute the original column norms for the second block -C column. -C - DO 140 I = NTHS + 1, N - L = IPVT(I) - JNORMS(L) = DNRM2( I, J(IBSN), 1 ) - IBSN = IBSN + N - 140 CONTINUE -C - END IF -C - ELSE -C -C Case BSM = BSN. -C Compute the original column norms for the first block column -C of Jc. -C - IBSN = 1 -C - DO 160 I = 1, BSN - JL = I -C - DO 150 K = 1, BN - L = IPVT(JL) - JNORMS(L) = DNRM2( I, J(IBSN), 1 ) - IBSN = IBSN + BSN - JL = JL + BSN - 150 CONTINUE -C - IBSN = IBSN + ST - 160 CONTINUE -C - DO 170 I = NTHS + 1, N - IPVT(I) = I - 170 CONTINUE -C - END IF -C -C Compute the norm of the scaled gradient. -C - IF ( FNORM.NE.ZERO ) THEN -C - DO 190 IBSN = 1, NTHS, BSN - IBSNI = IBSN -C - DO 180 I = 1, BSN - L = IPVT(IBSN+I-1) - IF ( JNORMS(L).NE.ZERO ) THEN - SUM = DDOT( I, J(IBSNI), 1, E(IBSN), 1 )/FNORM - GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) - END IF - IBSNI = IBSNI + N - 180 CONTINUE -C - 190 CONTINUE -C - IBSNI = N*BSN + 1 -C - DO 200 I = NTHS + 1, N - L = IPVT(I) - IF ( JNORMS(L).NE.ZERO ) THEN - SUM = DDOT( I, J(IBSNI), 1, E, 1 )/FNORM - GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) - END IF - IBSNI = IBSNI + N - 200 CONTINUE -C - END IF -C - LDJ = N - DWORK(1) = WRKOPT - RETURN -C -C *** Last line of NF01BS *** - END diff --git a/slycot/src/NF01BU.f b/slycot/src/NF01BU.f deleted file mode 100644 index 502959cd..00000000 --- a/slycot/src/NF01BU.f +++ /dev/null @@ -1,398 +0,0 @@ - SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, - $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix J'*J + c*I, for the Jacobian J as received -C from SLICOT Library routine NF01BD: -C -C / dy(1)/dwb(1) | dy(1)/dtheta \ -C Jc = | : | : | . -C \ dy(L)/dwb(L) | dy(L)/dtheta / -C -C This is a compressed representation of the actual structure -C -C / J_1 0 .. 0 | L_1 \ -C | 0 J_2 .. 0 | L_2 | -C J = | : : .. : | : | . -C | : : .. : | : | -C \ 0 0 .. J_L | L_L / -C -C ARGUMENTS -C -C Mode Parameters -C -C STOR CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix J'*J + c*I, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix J'*J + c*I is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix J'*J + c*I. -C N = BN*BSN + ST >= 0. (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain ST, the number of parameters -C corresponding to the linear part. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, BN = L, -C for the parameters corresponding to the nonlinear -C part. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the -C number of rows of the matrix J, if BN <= 1. -C IPAR(4) must contain BSN, the number of columns of the -C blocks J_k, k = 1:BN. BSN >= 0. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C The leading NR-by-NC part of this array must contain -C the (compressed) representation (Jc) of the Jacobian -C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, -C if BN > 1. -C -C LDJ (input) INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NR). -C -C JTJ (output) DOUBLE PRECISION array, -C dimension (LDJTJ,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if -C STOR = 'P') part of this array contains the upper or -C lower triangle of the matrix J'*J + c*I, depending on -C UPLO = 'U', or UPLO = 'L', respectively, stored either as -C a two-dimensional, or one-dimensional array, depending -C on STOR. -C -C LDJTJ INTEGER -C The leading dimension of the array JTJ. -C LDJTJ >= MAX(1,N), if STOR = 'F'. -C LDJTJ >= 1, if STOR = 'P'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C Currently, this array is not used. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product is computed columnn-wise, exploiting the -C symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F', -C and BLAS 2 routine DGEMV is used if STOR = 'P'. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. -C -C REVISIONS -C -C V. Sima, Dec. 2001, Mar. 2002. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations, -C Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER STOR, UPLO - INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL FULL, UPPER - INTEGER BN, BSM, BSN, I1, IBSM, IBSN, II, JL, K, M, - $ NBSN, NTHS, ST - DOUBLE PRECISION C -C .. Local Arrays .. - DOUBLE PRECISION TMP(1) - INTEGER ITMP(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DSYRK, NF01BV, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 -C - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C - IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSEIF ( N.LT.0 ) THEN - INFO = -3 - ELSEIF ( LIPAR.LT.4 ) THEN - INFO = -5 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -7 - ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN - INFO = -11 - ELSEIF ( LDWORK.LT.0 ) THEN - INFO = -13 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( BN.GT.1 ) THEN - M = BN*BSM - ELSE - M = BSM - END IF - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -4 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -3 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -9 - END IF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BU', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - C = DPAR(1) -C - IF ( BN.LE.1 .OR. BSN.EQ.0 .OR. BSM.EQ.0 ) THEN -C -C Special case, l <= 1 or BSN = 0 or BSM = 0: the Jacobian is -C represented as a full matrix. -C - ITMP(1) = M - CALL NF01BV( STOR, UPLO, N, ITMP, 1, DPAR, 1, J, LDJ, JTJ, - $ LDJTJ, DWORK, LDWORK, INFO ) - RETURN - END IF -C -C General case: l > 1, BSN > 0, BSM > 0. -C - JL = BSN + 1 -C - IF ( FULL ) THEN -C - NBSN = N*BSN -C - IF ( UPPER ) THEN -C -C Compute the leading upper triangular part (full storage). -C - CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ, LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J, LDJ, ONE, - $ JTJ, LDJTJ ) - IBSN = BSN - I1 = NBSN + 1 -C - DO 10 IBSM = BSM + 1, M, BSM - II = I1 + IBSN - CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), - $ LDJTJ ) - I1 = I1 + NBSN - CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), - $ LDJ, ONE, JTJ(II), LDJTJ ) - IBSN = IBSN + BSN - 10 CONTINUE -C - IF ( ST.GT.0 ) THEN -C -C Compute the last block column. -C - DO 20 IBSM = 1, M, BSM - CALL DGEMM( 'Transpose', 'NoTranspose', BSN, ST, BSM, - $ ONE, J(IBSM,1), LDJ, J(IBSM,JL), LDJ, - $ ZERO, JTJ(I1), LDJTJ ) - I1 = I1 + BSN - 20 CONTINUE -C - CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(I1), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), - $ LDJ, ONE, JTJ(I1), LDJTJ ) - END IF -C - ELSE -C -C Compute the leading lower triangular part (full storage). -C - IBSN = NTHS - II = 1 -C - DO 30 IBSM = 1, M, BSM - I1 = II + BSN - CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), - $ LDJ, ONE, JTJ(II), LDJTJ ) - IBSN = IBSN - BSN - CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), - $ LDJTJ ) - II = I1 + NBSN - IF ( ST.GT.0 ) - $ CALL DGEMM( 'Transpose', 'NoTranspose', ST, BSN, BSM, - $ ONE, J(IBSM,JL), LDJ, J(IBSM,1), LDJ, - $ ZERO, JTJ(I1+IBSN), LDJTJ ) - 30 CONTINUE -C - IF ( ST.GT.0 ) THEN -C -C Compute the last diagonal block. -C - CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(II), LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), - $ LDJ, ONE, JTJ(II), LDJTJ ) - END IF -C - END IF -C - ELSE -C - TMP(1) = ZERO -C - IF ( UPPER ) THEN -C -C Compute the leading upper triangular part (packed storage). -C - IBSN = 0 - I1 = 1 -C - DO 50 IBSM = 1, M, BSM -C - DO 40 K = 1, BSN - II = I1 + IBSN - CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) - CALL DGEMV( 'Transpose', BSM, K, ONE, J(IBSM,1), LDJ, - $ J(IBSM,K), 1, ZERO, JTJ(II), 1 ) - I1 = II + K - JTJ(I1-1) = JTJ(I1-1) + C - 40 CONTINUE -C - IBSN = IBSN + BSN - 50 CONTINUE -C -C Compute the last block column. -C - DO 70 K = 1, ST -C - DO 60 IBSM = 1, M, BSM - CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), - $ LDJ, J(IBSM,BSN+K), 1, ZERO, JTJ(I1), 1 ) - I1 = I1 + BSN - 60 CONTINUE -C - CALL DGEMV( 'Transpose', M, K, ONE, J(1,JL), LDJ, - $ J(1,BSN+K), 1, ZERO, JTJ(I1), 1 ) - I1 = I1 + K - JTJ(I1-1) = JTJ(I1-1) + C - 70 CONTINUE -C - ELSE -C -C Compute the leading lower triangular part (packed storage). -C - IBSN = NTHS - II = 1 -C - DO 90 IBSM = 1, M, BSM - IBSN = IBSN - BSN -C - DO 80 K = 1, BSN - I1 = II + BSN - K + 1 - CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) - CALL DGEMV( 'Transpose', BSM, BSN-K+1, ONE, J(IBSM,K), - $ LDJ, J(IBSM,K), 1, ZERO, JTJ(II), 1 ) - JTJ(II) = JTJ(II) + C - I1 = I1 + IBSN - II = I1 + ST - IF ( ST.GT.0 ) - $ CALL DGEMV( 'Transpose', BSM, ST, ONE, J(IBSM,JL), - $ LDJ, J(IBSM,K), 1, ZERO, JTJ(I1), 1 ) - 80 CONTINUE -C - 90 CONTINUE -C -C Compute the last diagonal block. -C - DO 100 K = 1, ST - CALL DGEMV( 'Transpose', M, ST-K+1, ONE, J(1,BSN+K), LDJ, - $ J(1,BSN+K), 1, ZERO, JTJ(II), 1 ) - JTJ(II) = JTJ(II) + C - II = II + ST - K + 1 - 100 CONTINUE -C - END IF -C - END IF -C - RETURN -C -C *** Last line of NF01BU *** - END diff --git a/slycot/src/NF01BV.f b/slycot/src/NF01BV.f deleted file mode 100644 index d596ec50..00000000 --- a/slycot/src/NF01BV.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE NF01BV( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, - $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix J'*J + c*I, for the Jacobian J as received -C from SLICOT Library routine NF01BY, for one output variable. -C -C NOTE: this routine must have the same arguments as SLICOT Library -C routine NF01BU. -C -C ARGUMENTS -C -C Mode Parameters -C -C STOR CHARACTER*1 -C Specifies the storage scheme for the symmetric -C matrix J'*J + c*I, as follows: -C = 'F' : full storage is used; -C = 'P' : packed storage is used. -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix J'*J + c*I is stored, -C as follows: -C = 'U' : the upper triagular part is stored; -C = 'L' : the lower triagular part is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain the number of rows M of the Jacobian -C matrix J. M >= 0. -C IPAR is provided for compatibility with SLICOT Library -C routine MD03AD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 1. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ,N) -C The leading M-by-N part of this array must contain the -C Jacobian matrix J. -C -C LDJ INTEGER -C The leading dimension of the array J. LDJ >= MAX(1,M). -C -C JTJ (output) DOUBLE PRECISION array, -C dimension (LDJTJ,N), if STOR = 'F', -C dimension (N*(N+1)/2), if STOR = 'P'. -C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if -C STOR = 'P') part of this array contains the upper or -C lower triangle of the matrix J'*J + c*I, depending on -C UPLO = 'U', or UPLO = 'L', respectively, stored either as -C a two-dimensional, or one-dimensional array, depending -C on STOR. -C -C LDJTJ INTEGER -C The leading dimension of the array JTJ. -C LDJTJ >= MAX(1,N), if STOR = 'F'. -C LDJTJ >= 1, if STOR = 'P'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C Currently, this array is not used. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix product is computed columnn-wise, exploiting the -C symmetry. BLAS 3 routine DSYRK is used if STOR = 'F', and BLAS 2 -C routine DGEMV is used if STOR = 'P'. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. -C -C REVISIONS -C -C V. Sima, March 2002. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations, -C Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER STOR, UPLO - INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) -C .. Local Scalars .. - LOGICAL FULL, UPPER - INTEGER I, II, M - DOUBLE PRECISION C -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLASET, DSYRK, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - FULL = LSAME( STOR, 'F' ) - UPPER = LSAME( UPLO, 'U' ) -C - IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -2 - ELSEIF ( N.LT.0 ) THEN - INFO = -3 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -7 - ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN - INFO = -11 - ELSEIF ( LDWORK.LT.0 ) THEN - INFO = -13 - ELSE - M = IPAR(1) - IF ( M.LT.0 ) THEN - INFO = -4 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -9 - ENDIF - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BV', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - C = DPAR(1) - IF ( N.EQ.0 ) THEN - RETURN - ELSE IF ( M.EQ.0 ) THEN - IF ( FULL ) THEN - CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) - ELSE - DUM(1) = ZERO - CALL DCOPY( ( N*( N + 1 ) )/2, DUM, 0, JTJ, 1 ) - IF ( UPPER ) THEN - II = 0 -C - DO 10 I = 1, N - II = II + I - JTJ(II) = C - 10 CONTINUE -C - ELSE - II = 1 -C - DO 20 I = N, 1, -1 - JTJ(II) = C - II = II + I - 20 CONTINUE -C - ENDIF - ENDIF - RETURN - ENDIF -C -C Build a triangle of the matrix J'*J + c*I. -C - IF ( FULL ) THEN - CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) - CALL DSYRK( UPLO, 'Transpose', N, M, ONE, J, LDJ, ONE, JTJ, - $ LDJTJ ) - ELSEIF ( UPPER ) THEN - II = 0 -C - DO 30 I = 1, N - CALL DGEMV( 'Transpose', M, I, ONE, J, LDJ, J(1,I), 1, ZERO, - $ JTJ(II+1), 1 ) - II = II + I - JTJ(II) = JTJ(II) + C - 30 CONTINUE -C - ELSE - II = 1 -C - DO 40 I = N, 1, -1 - CALL DGEMV( 'Transpose', M, I, ONE, J(1,N-I+1), LDJ, - $ J(1,N-I+1), 1, ZERO, JTJ(II), 1 ) - JTJ(II) = JTJ(II) + C - II = II + I - 40 CONTINUE -C - ENDIF -C - RETURN -C -C *** Last line of NF01BV *** - END diff --git a/slycot/src/NF01BW.f b/slycot/src/NF01BW.f deleted file mode 100644 index 1fdac4fd..00000000 --- a/slycot/src/NF01BW.f +++ /dev/null @@ -1,242 +0,0 @@ - SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the -C Jacobian J as received from SLICOT Library routine NF01BD: -C -C / dy(1)/dwb(1) | dy(1)/dtheta \ -C Jc = | : | : | . -C \ dy(L)/dwb(L) | dy(L)/dtheta / -C -C This is a compressed representation of the actual structure -C -C / J_1 0 .. 0 | L_1 \ -C | 0 J_2 .. 0 | L_2 | -C J = | : : .. : | : | . -C | : : .. : | : | -C \ 0 0 .. J_L | L_L / -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the vector x. -C N = BN*BSN + ST >= 0. (See parameter description below.) -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain ST, the number of parameters -C corresponding to the linear part. ST >= 0. -C IPAR(2) must contain BN, the number of blocks, BN = L, -C for the parameters corresponding to the nonlinear -C part. BN >= 0. -C IPAR(3) must contain BSM, the number of rows of the blocks -C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the -C number of rows of the matrix J, if BN <= 1. -C IPAR(4) must contain BSN, the number of columns of the -C blocks J_k, k = 1:BN. BSN >= 0. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 4. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) -C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. -C The leading NR-by-NC part of this array must contain -C the (compressed) representation (Jc) of the Jacobian -C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, -C if BN > 1. -C -C LDJ (input) INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NR). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*INCX) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value of the -C matrix-vector product (J'*J + c*I)*x. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX >= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= NR. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The associativity of matrix multiplications is used; the result -C is obtained as: x_out = J'*( J*x ) + c*x. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Mar. 2001, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, -C Mar. 2002. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations, -C Wiener system. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) - INTEGER IPAR(*) -C .. Local Scalars .. - INTEGER BN, BSM, BSN, IBSM, IBSN, IX, JL, M, NTHS, ST, - $ XL - DOUBLE PRECISION C -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 -C - IF ( N.LT.0 ) THEN - INFO = -1 - ELSEIF ( LIPAR.LT.4 ) THEN - INFO = -3 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( INCX.LT.1 ) THEN - INFO = -9 - ELSE - ST = IPAR(1) - BN = IPAR(2) - BSM = IPAR(3) - BSN = IPAR(4) - NTHS = BN*BSN - IF ( BN.GT.1 ) THEN - M = BN*BSM - ELSE - M = BSM - END IF - IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN - INFO = -2 - ELSEIF ( N.NE.NTHS + ST ) THEN - INFO = -1 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSEIF ( LDWORK.LT.M ) THEN - INFO = -11 - END IF - END IF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BW', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - C = DPAR(1) -C - IF ( M.EQ.0 ) THEN -C -C Special case, void Jacobian: x <-- c*x. -C - CALL DSCAL( N, C, X, INCX ) - RETURN - END IF -C - IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN -C -C Special case, l <= 1 or BSN = 0: the Jacobian is represented -C as a full matrix. Adapted code from NF01BX is included in-line. -C - CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, - $ INCX ) - RETURN - END IF -C -C General case: l > 1, BSN > 0, BSM > 0. -C - JL = BSN + 1 - IX = BSN*INCX - XL = BN*IX + 1 -C - IF ( ST.GT.0 ) THEN - CALL DGEMV( 'NoTranspose', M, ST, ONE, J(1,JL), LDJ, X(XL), - $ INCX, ZERO, DWORK, 1 ) - ELSE - DWORK(1) = ZERO - CALL DCOPY( M, DWORK(1), 0, DWORK, 1 ) - END IF - IBSN = 1 -C - DO 10 IBSM = 1, M, BSM - CALL DGEMV( 'NoTranspose', BSM, BSN, ONE, J(IBSM,1), LDJ, - $ X(IBSN), INCX, ONE, DWORK(IBSM), 1 ) - CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), LDJ, - $ DWORK(IBSM), 1, C, X(IBSN), INCX ) - IBSN = IBSN + IX - 10 CONTINUE -C - IF ( ST.GT.0 ) - $ CALL DGEMV( 'Transpose', M, ST, ONE, J(1,JL), LDJ, DWORK, 1, C, - $ X(XL), INCX ) -C - RETURN -C -C *** Last line of NF01BW *** - END diff --git a/slycot/src/NF01BX.f b/slycot/src/NF01BX.f deleted file mode 100644 index 73cc30c6..00000000 --- a/slycot/src/NF01BX.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE NF01BX( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute (J'*J + c*I)*x, where J is an m-by-n real matrix, c is -C a real scalar, I is the n-by-n identity matrix, and x is a real -C n-vector. -C -C NOTE: this routine must have the same arguments as SLICOT Library -C routine NF01BW. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of columns of the Jacobian matrix J. N >= 0. -C -C IPAR (input) INTEGER array, dimension (LIPAR) -C The integer parameters describing the structure of the -C matrix J, as follows: -C IPAR(1) must contain the number of rows M of the Jacobian -C matrix J. M >= 0. -C IPAR is provided for compatibility with SLICOT Library -C routine MD03AD. -C -C LIPAR (input) INTEGER -C The length of the array IPAR. LIPAR >= 1. -C -C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) -C The real parameters needed for solving the problem. -C The entry DPAR(1) must contain the real scalar c. -C -C LDPAR (input) INTEGER -C The length of the array DPAR. LDPAR >= 1. -C -C J (input) DOUBLE PRECISION array, dimension (LDJ,N) -C The leading M-by-N part of this array must contain the -C Jacobian matrix J. -C -C LDJ INTEGER -C The leading dimension of the array J. LDJ >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension -C (1+(N-1)*abs(INCX)) -C On entry, this incremented array must contain the -C vector x. -C On exit, this incremented array contains the value of the -C matrix-vector product (J'*J + c*I)*x. -C -C INCX (input) INTEGER -C The increment for the elements of X. INCX <> 0. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= M. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The associativity of matrix multiplications is used; the result -C is obtained as: x_out = J'*( J*x ) + c*x. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Mar. 2002, Oct. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N -C .. Array Arguments .. - INTEGER IPAR(*) - DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) -C .. Local Scalars .. - INTEGER M - DOUBLE PRECISION C -C .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C - INFO = 0 - IF ( N.LT.0 ) THEN - INFO = -1 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -3 - ELSEIF ( LDPAR.LT.1 ) THEN - INFO = -5 - ELSEIF ( INCX.EQ.0 ) THEN - INFO = -9 - ELSE - M = IPAR(1) - IF ( M.LT.0 ) THEN - INFO = -2 - ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN - INFO = -7 - ELSEIF ( LDWORK.LT.M ) THEN - INFO = -11 - ENDIF - ENDIF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'NF01BX', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - C = DPAR(1) - IF ( M.EQ.0 ) THEN -C -C Special case, void J: x <-- c*x. -C - CALL DSCAL( N, C, X, INCX ) - RETURN - END IF -C - CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, INCX ) - RETURN -C -C *** Last line of NF01BX *** - END diff --git a/slycot/src/NF01BY.f b/slycot/src/NF01BY.f deleted file mode 100644 index c9c0a8e3..00000000 --- a/slycot/src/NF01BY.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, - $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Jacobian of the error function for a neural network -C of the structure -C -C - tanh(w1*z+b1) - -C / : \ -C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, -C \ : / -C - tanh(wn*z+bn) - -C -C for the single-output case. The Jacobian has the form -C -C d e(1) / d WB(1) ... d e(1) / d WB(NWB) -C J = : : , -C d e(NSMP) / d WB(1) ... d e(NSMP) / d WB(NWB) -C -C where e(z) is the error function, WB is the set of weights and -C biases of the network (for the considered output), and NWB is -C the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1 -C (see below). -C -C In the multi-output case, this routine should be called for each -C output. -C -C NOTE: this routine must have the same arguments as SLICOT Library -C routine NF01BD. -C -C ARGUMENTS -C -C Mode Parameters -C -C CJTE CHARACTER*1 -C Specifies whether the matrix-vector product J'*e should be -C computed or not, as follows: -C = 'C' : compute J'*e; -C = 'N' : do not compute J'*e. -C -C Input/Output Parameters -C -C NSMP (input) INTEGER -C The number of training samples. NSMP >= 0. -C -C NZ (input) INTEGER -C The length of each input sample. NZ >= 0. -C -C L (input) INTEGER -C The length of each output sample. -C Currently, L must be 1. -C -C IPAR (input/output) INTEGER array, dimension (LIPAR) -C The integer parameters needed. -C On entry, the first element of this array must contain -C a value related to the number of neurons, n; specifically, -C n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special -C meaning (see below). -C On exit, if IPAR(1) < 0 on entry, then no computations are -C performed, except the needed tests on input parameters, -C but the following values are returned: -C IPAR(1) contains the length of the array J, LJ; -C LDJ contains the leading dimension of array J. -C Otherwise, IPAR(1) and LDJ are unchanged on exit. -C -C LIPAR (input) INTEGER -C The length of the vector IPAR. LIPAR >= 1. -C -C WB (input) DOUBLE PRECISION array, dimension (LWB) -C The leading NWB = IPAR(1)*(NZ+2)+1 part of this array -C must contain the weights and biases of the network, -C WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ..., w(n,NZ), -C ws(1), ..., ws(n), b(1), ..., b(n+1) ), -C where w(i,j) are the weights of the hidden layer, -C ws(i) are the weights of the linear output layer and -C b(i) are the biases. -C -C LWB (input) INTEGER -C The length of array WB. LWB >= NWB. -C -C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) -C The leading NSMP-by-NZ part of this array must contain the -C set of input samples, -C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,NSMP). -C -C E (input) DOUBLE PRECISION array, dimension (NSMP) -C If CJTE = 'C', this array must contain the error vector e. -C If CJTE = 'N', this array is not referenced. -C -C J (output) DOUBLE PRECISION array, dimension (LDJ, NWB) -C The leading NSMP-by-NWB part of this array contains the -C Jacobian of the error function. -C -C LDJ INTEGER -C The leading dimension of array J. LDJ >= MAX(1,NSMP). -C Note that LDJ is an input parameter, except for -C IPAR(1) < 0 on entry, when it is an output parameter. -C -C JTE (output) DOUBLE PRECISION array, dimension (NWB) -C If CJTE = 'C', this array contains the matrix-vector -C product J'*e. -C If CJTE = 'N', this array is not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This argument is included for combatibility with SLICOT -C Library routine NF01BD. -C -C LDWORK INTEGER -C Normally, the length of the array DWORK. LDWORK >= 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Jacobian is computed analytically. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Input output description, neural network, nonlinear system, -C optimization, system response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER CJTE - INTEGER INFO, L, LDJ, LDWORK, LDZ, LIPAR, LWB, NSMP, NZ -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), WB(*), - $ Z(LDZ,*) - INTEGER IPAR(*) -C .. Local Scalars .. - LOGICAL WJTE - INTEGER BP1, DI, I, IB, K, M, NN, NWB, WS - DOUBLE PRECISION BIGNUM, SMLNUM, TMP -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, EXP, LOG, MAX, MIN -C .. -C .. Executable Statements .. -C - WJTE = LSAME( CJTE, 'C' ) - INFO = 0 - NN = IPAR(1) - NWB = NN*( NZ + 2 ) + 1 - IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( NSMP.LT.0 ) THEN - INFO = -2 - ELSEIF ( NZ.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.NE.1 ) THEN - INFO = -4 - ELSEIF ( LIPAR.LT.1 ) THEN - INFO = -6 - ELSEIF ( IPAR(1).LT.0 ) THEN - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BY', -INFO ) - ELSE - IPAR(1) = NSMP*( ABS( NN )*( NZ + 2 ) + 1 ) - LDJ = NSMP - ENDIF - RETURN - ELSEIF ( LWB.LT.NWB ) THEN - INFO = -8 - ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN - INFO = -10 - ELSEIF ( LDJ.LT.MAX( 1, NSMP ) ) THEN - INFO = -13 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'NF01BY', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MIN( NSMP, NZ ).EQ.0 ) - $ RETURN -C -C Set parameters to avoid overflows and increase accuracy for -C extreme values. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = LOG( SMLNUM ) - BIGNUM = LOG( BIGNUM ) -C - WS = NZ*NN + 1 - IB = WS + NN - BP1 = IB + NN -C - J(1, BP1) = ONE - CALL DCOPY( NSMP, J(1, BP1), 0, J(1, BP1), 1 ) -C - DO 10 I = 0, NN - 1 - CALL DCOPY( NSMP, WB(IB+I), 0, J(1, WS+I), 1 ) - 10 CONTINUE -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NSMP, NN, NZ, -TWO, Z, - $ LDZ, WB, NZ, -TWO, J(1, WS), LDJ ) - DI = 1 -C - DO 50 I = 0, NN - 1 -C - DO 20 K = 1, NSMP - TMP = J(K, WS+I) - IF ( ABS( TMP ).GE.BIGNUM ) THEN - IF ( TMP.GT.ZERO ) THEN - J(K, WS+I) = -ONE - ELSE - J(K, WS+I) = ONE - END IF - ELSE IF ( ABS( TMP ).LE.SMLNUM ) THEN - J(K, WS+I) = ZERO - ELSE - J(K, WS+I) = TWO/( ONE + EXP( TMP ) ) - ONE - END IF - J(K, IB+I) = WB(WS+I)*( ONE - J(K, WS+I)**2 ) - 20 CONTINUE -C - DO 40 K = 0, NZ - 1 -C - DO 30 M = 1, NSMP - J(M, DI+K) = J(M, IB+I)*Z(M, K+1) - 30 CONTINUE -C - 40 CONTINUE -C - DI = DI + NZ - 50 CONTINUE -C - IF ( WJTE ) THEN -C -C Compute J'e. -C - CALL DGEMV( 'Transpose', NSMP, NWB, ONE, J, LDJ, E, 1, ZERO, - $ JTE, 1 ) - END IF -C - RETURN -C -C *** Last line of NF01BY *** - END diff --git a/slycot/src/Readme.md b/slycot/src/Readme.md new file mode 100644 index 00000000..5c06279e --- /dev/null +++ b/slycot/src/Readme.md @@ -0,0 +1,11 @@ +Fortran sources +--------------- + +This directory contains the f2py wrappers and some helper functions to work +with the SLICOT Library routines. SLICOT-reference is a git submodule +referencing [SLICOT-reference](https://github.com/SLICOT/SLICOT-reference) +plus some backported improvements. + +The codes follow the Fortran 77 language conventions. SLICOT routines make +calls to the state-of-the-art packages LAPACK (Linear Algebra Package) and BLAS +(Basic Linear Algebra Subprograms). diff --git a/slycot/src/SB01BD.f b/slycot/src/SB01BD.f deleted file mode 100644 index 587581e3..00000000 --- a/slycot/src/SB01BD.f +++ /dev/null @@ -1,776 +0,0 @@ - SUBROUTINE SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, WR, WI, - $ NFP, NAP, NUP, F, LDF, Z, LDZ, TOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine the state feedback matrix F for a given system (A,B) -C such that the closed-loop state matrix A+B*F has specified -C eigenvalues. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrix B and -C the number of columns of the matrix F. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrix B and the number of rows of the matrix F. -C M >= 0. -C -C NP (input) INTEGER -C The number of given eigenvalues. At most N eigenvalues -C can be assigned. 0 <= NP. -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the maximum admissible value, either for real -C parts, if DICO = 'C', or for moduli, if DICO = 'D', -C of the eigenvalues of A which will not be modified by -C the eigenvalue assignment algorithm. -C ALPHA >= 0 if DICO = 'D'. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Z'*(A+B*F)*Z in a real Schur form. -C The leading NFP-by-NFP diagonal block of A corresponds -C to the fixed (unmodified) eigenvalues having real parts -C less than ALPHA, if DICO = 'C', or moduli less than ALPHA, -C if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A -C corresponds to the uncontrollable eigenvalues detected by -C the eigenvalue assignment algorithm. The elements under -C the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C WR,WI (input/output) DOUBLE PRECISION array, dimension (NP) -C On entry, these arrays must contain the real and imaginary -C parts, respectively, of the desired eigenvalues of the -C closed-loop system state-matrix A+B*F. The eigenvalues -C can be unordered, except that complex conjugate pairs -C must appear consecutively in these arrays. -C On exit, if INFO = 0, the leading NAP elements of these -C arrays contain the real and imaginary parts, respectively, -C of the assigned eigenvalues. The trailing NP-NAP elements -C contain the unassigned eigenvalues. -C -C NFP (output) INTEGER -C The number of eigenvalues of A having real parts less than -C ALPHA, if DICO = 'C', or moduli less than ALPHA, if -C DICO = 'D'. These eigenvalues are not modified by the -C eigenvalue assignment algorithm. -C -C NAP (output) INTEGER -C The number of assigned eigenvalues. If INFO = 0 on exit, -C then NAP = N-NFP-NUP. -C -C NUP (output) INTEGER -C The number of uncontrollable eigenvalues detected by the -C eigenvalue assignment algorithm (see METHOD). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the state -C feedback F, which assigns NAP closed-loop eigenvalues and -C keeps unaltered N-NAP open-loop eigenvalues. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the -C orthogonal matrix Z which reduces the closed-loop -C system state matrix A + B*F to upper real Schur form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of A -C or B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then the default tolerance -C TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is -C the machine precision (see LAPACK Library routine DLAMCH) -C and NORM(A) denotes the 1-norm of A. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(F) <= 100*NORM(A)/NORM(B) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal. -C = 3: the number of eigenvalues to be assigned is less -C than the number of possibly assignable eigenvalues; -C NAP eigenvalues have been properly assigned, -C but some assignable eigenvalues remain unmodified. -C = 4: an attempt is made to place a complex conjugate -C pair on the location of a real eigenvalue. This -C situation can only appear when N-NFP is odd, -C NP > N-NFP-NUP is even, and for the last real -C eigenvalue to be modified there exists no available -C real eigenvalue to be assigned. However, NAP -C eigenvalues have been already properly assigned. -C -C METHOD -C -C SB01BD is based on the factorization algorithm of [1]. -C Given the matrices A and B of dimensions N-by-N and N-by-M, -C respectively, this subroutine constructs an M-by-N matrix F such -C that A + BF has eigenvalues as follows. -C Let NFP eigenvalues of A have real parts less than ALPHA, if -C DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then: -C 1) If the pair (A,B) is controllable, then A + B*F has -C NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified -C by WR + j*WI and N-NAP unmodified eigenvalues; -C 2) If the pair (A,B) is uncontrollable, then the number of -C assigned eigenvalues NAP satifies generally the condition -C NAP <= MIN(NP,N-NFP). -C -C At the beginning of the algorithm, F = 0 and the matrix A is -C reduced to an ordered real Schur form by separating its spectrum -C in two parts. The leading NFP-by-NFP part of the Schur form of -C A corresponds to the eigenvalues which will not be modified. -C These eigenvalues have real parts less than ALPHA, if -C DICO = 'C', or moduli less than ALPHA, if DICO = 'D'. -C The performed orthogonal transformations are accumulated in Z. -C After this preliminary reduction, the algorithm proceeds -C recursively. -C -C Let F be the feedback matrix at the beginning of a typical step i. -C At each step of the algorithm one real eigenvalue or two complex -C conjugate eigenvalues are placed by a feedback Fi of rank 1 or -C rank 2, respectively. Since the feedback Fi affects only the -C last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z -C therefore remains in real Schur form. The assigned eigenvalue(s) -C is (are) then moved to another diagonal position of the real -C Schur form using reordering techniques and a new block is -C transfered in the last diagonal position. The feedback matrix F -C is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at -C each step is (are) chosen such that the norm of each Fi is -C minimized. -C -C If uncontrollable eigenvalues are encountered in the last diagonal -C position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm -C deflates them at the bottom of the real Schur form and redefines -C accordingly the position of the "last" block. -C -C Note: Not all uncontrollable eigenvalues of the pair (A,B) are -C necessarily detected by the eigenvalue assignment algorithm. -C Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or -C NP < N-NFP. -C -C REFERENCES -C -C [1] Varga A. -C A Schur method for pole assignment. -C IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. Although no proof of numerical stability is known, -C the algorithm has always been observed to yield reliable -C numerical results. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routine SB01BD. -C -C REVISIONS -C -C March 30, 1999, V. Sima, Research Institute for Informatics, -C Bucharest. -C April 4, 1999. A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen. -C May 18, 2003. A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen. -C Feb. 15, 2004, V. Sima, Research Institute for Informatics, -C Bucharest. -C May 12, 2005. A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Eigenvalues, eigenvalue assignment, feedback control, -C pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HUNDR, ONE, TWO, ZERO - PARAMETER ( HUNDR = 1.0D2, ONE = 1.0D0, TWO = 2.0D0, - $ ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDF, LDWORK, LDZ, M, N, - $ NAP, NFP, NP, NUP - DOUBLE PRECISION ALPHA, TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), - $ WI(*), WR(*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL CEIG, DISCR, SIMPLB - INTEGER I, IB, IB1, IERR, IPC, J, K, KFI, KG, KW, KWI, - $ KWR, NCUR, NCUR1, NL, NLOW, NMOVES, NPC, NPR, - $ NSUP, WRKOPT - DOUBLE PRECISION ANORM, BNORM, C, P, RMAX, S, X, Y, TOLER, TOLERB -C .. Local Arrays .. - LOGICAL BWORK(1) - DOUBLE PRECISION A2(2,2) -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DGEES, DGEMM, DLAEXC, DLASET, DROT, DSWAP, - $ MB03QD, MB03QY, SB01BX, SB01BY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( NP.LT.0 ) THEN - INFO = -4 - ELSE IF( DISCR .AND. ( ALPHA.LT.ZERO ) ) 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( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, 5*M, 5*N, 2*N + 4*M ) ) THEN - INFO = -21 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB01BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - NFP = 0 - NAP = 0 - NUP = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Compute the norms of A and B, and set default tolerances -C if necessary. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - IF( TOL.LE.ZERO ) THEN - X = DLAMCH( 'Epsilon' ) - TOLER = DBLE( N ) * MAX( ANORM, BNORM ) * X - TOLERB = DBLE( N ) * BNORM * X - ELSE - TOLER = TOL - TOLERB = TOL - END IF -C -C Allocate working storage. -C - KWR = 1 - KWI = KWR + N - KW = KWI + N -C -C Reduce A to real Schur form using an orthogonal similarity -C transformation A <- Z'*A*Z and accumulate the transformation in Z. -C -C Workspace: need 5*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'No ordering', SELECT, N, A, LDA, NCUR, - $ DWORK(KWR), DWORK(KWI), Z, LDZ, DWORK(KW), - $ LDWORK-KW+1, BWORK, INFO ) - WRKOPT = KW - 1 + INT( DWORK( KW ) ) - IF( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- Z'*A*Z and accumulate the -C transformations in Z. The separation of the spectrum of A is -C performed such that the leading NFP-by-NFP submatrix of A -C corresponds to the "good" eigenvalues which will not be -C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A -C corresponds to the "bad" eigenvalues to be modified. -C -C Workspace needed: N. -C - CALL MB03QD( DICO, 'Stable', 'Update', N, 1, N, ALPHA, - $ A, LDA, Z, LDZ, NFP, DWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C -C Set F = 0. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, F, LDF ) -C -C Return if B is negligible (uncontrollable system). -C - IF( BNORM.LE.TOLERB ) THEN - NAP = 0 - NUP = N - DWORK(1) = WRKOPT - RETURN - END IF -C -C Compute the bound for the numerical stability condition. -C - RMAX = HUNDR * ANORM / BNORM -C -C Perform eigenvalue assignment if there exist "bad" eigenvalues. -C - NAP = 0 - NUP = 0 - IF( NFP .LT. N ) THEN - KG = 1 - KFI = KG + 2*M - KW = KFI + 2*M -C -C Set the limits for the bottom diagonal block. -C - NLOW = NFP + 1 - NSUP = N -C -C Separate and count real and complex eigenvalues to be assigned. -C - NPR = 0 - DO 10 I = 1, NP - IF( WI(I) .EQ. ZERO ) THEN - NPR = NPR + 1 - K = I - NPR - IF( K .GT. 0 ) THEN - S = WR(I) - DO 5 J = NPR + K - 1, NPR, -1 - WR(J+1) = WR(J) - WI(J+1) = WI(J) - 5 CONTINUE - WR(NPR) = S - WI(NPR) = ZERO - END IF - END IF - 10 CONTINUE - NPC = NP - NPR -C -C The first NPR elements of WR and WI contain the real -C eigenvalues, the last NPC elements contain the complex -C eigenvalues. Set the pointer to complex eigenvalues. -C - IPC = NPR + 1 -C -C Main loop for assigning one or two eigenvalues. -C -C Terminate if all eigenvalues were assigned, or if there -C are no more eigenvalues to be assigned, or if a non-fatal -C error condition was set. -C -C WHILE (NLOW <= NSUP and INFO = 0) DO -C - 20 IF( NLOW.LE.NSUP .AND. INFO.EQ.0 ) THEN -C -C Determine the dimension of the last block. -C - IB = 1 - IF( NLOW.LT.NSUP ) THEN - IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 - END IF -C -C Compute G, the current last IB rows of Z'*B. -C - NL = NSUP - IB + 1 - CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, - $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) -C -C Check the controllability for a simple block. -C - IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) - $ .LE. TOLERB ) THEN -C -C Deflate the uncontrollable block and resume the -C main loop. -C - NSUP = NSUP - IB - NUP = NUP + IB - GO TO 20 - END IF -C -C Test for termination with INFO = 3. -C - IF( NAP.EQ.NP) THEN - INFO = 3 -C -C Test for compatibility. Terminate if an attempt occurs -C to place a complex conjugate pair on a 1x1 block. -C - ELSE IF( IB.EQ.1 .AND. NPR.EQ.0 .AND. NLOW.EQ.NSUP ) THEN - INFO = 4 - ELSE -C -C Set the simple block flag. -C - SIMPLB = .TRUE. -C -C Form a 2-by-2 block if necessary from two 1-by-1 blocks. -C Consider special case IB = 1, NPR = 1 and -C NPR+NPC > NSUP-NLOW+1 to avoid incompatibility. -C - IF( ( IB.EQ.1 .AND. NPR.EQ.0 ) .OR. - $ ( IB.EQ.1 .AND. NPR.EQ.1 .AND. NSUP.GT.NLOW .AND. - $ NPR+NPC.GT.NSUP-NLOW+1 ) ) THEN - IF( NSUP.GT.2 ) THEN - IF( A(NSUP-1,NSUP-2) .NE. ZERO ) THEN -C -C Interchange with the adjacent 2x2 block. -C -C Workspace needed: N. -C - CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, NSUP-2, - $ 2, 1, DWORK(KW), INFO ) - IF( INFO .NE. 0 ) THEN - INFO = 2 - RETURN - END IF - ELSE -C -C Form a non-simple block by extending the last -C block with a 1x1 block. -C - SIMPLB = .FALSE. - END IF - ELSE - SIMPLB = .FALSE. - END IF - IB = 2 - END IF - NL = NSUP - IB + 1 -C -C Compute G, the current last IB rows of Z'*B. -C - CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, - $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) -C -C Check the controllability for the current block. -C - IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) - $ .LE. TOLERB ) THEN -C -C Deflate the uncontrollable block and resume the -C main loop. -C - NSUP = NSUP - IB - NUP = NUP + IB - GO TO 20 - END IF -C - IF( NAP+IB .GT. NP ) THEN -C -C No sufficient eigenvalues to be assigned. -C - INFO = 3 - ELSE - IF( IB .EQ. 1 ) THEN -C -C A 1-by-1 block. -C -C Assign the real eigenvalue nearest to A(NSUP,NSUP). -C - X = A(NSUP,NSUP) - CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) - NPR = NPR - 1 - CEIG = .FALSE. - ELSE -C -C A 2-by-2 block. -C - IF( SIMPLB ) THEN -C -C Simple 2-by-2 block with complex eigenvalues. -C Compute the eigenvalues of the last block. -C - CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, INFO ) - IF( NPC .GT. 1 ) THEN - CALL SB01BX( .FALSE., NPC, X, Y, - $ WR(IPC), WI(IPC), S, P ) - NPC = NPC - 2 - CEIG = .TRUE. - ELSE -C -C Choose the nearest two real eigenvalues. -C - CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) - CALL SB01BX( .TRUE., NPR-1, X, X, WR, X, - $ Y, P ) - P = S * Y - S = S + Y - NPR = NPR - 2 - CEIG = .FALSE. - END IF - ELSE -C -C Non-simple 2x2 block with real eigenvalues. -C Choose the nearest pair of complex eigenvalues. -C - X = ( A(NL,NL) + A(NSUP,NSUP) )/TWO - CALL SB01BX( .FALSE., NPC, X, ZERO, WR(IPC), - $ WI(IPC), S, P ) - NPC = NPC - 2 - END IF - END IF -C -C Form the IBxIB matrix A2 from the current diagonal -C block. -C - A2(1,1) = A(NL,NL) - IF( IB .GT. 1 ) THEN - A2(1,2) = A(NL,NSUP) - A2(2,1) = A(NSUP,NL) - A2(2,2) = A(NSUP,NSUP) - END IF -C -C Determine the M-by-IB feedback matrix FI which -C assigns the chosen IB eigenvalues for the pair (A2,G). -C -C Workspace needed: 5*M. -C - CALL SB01BY( IB, M, S, P, A2, DWORK(KG), DWORK(KFI), - $ TOLER, DWORK(KW), IERR ) - IF( IERR .NE. 0 ) THEN - IF( IB.EQ.1 .OR. SIMPLB ) THEN -C -C The simple 1x1 block is uncontrollable. -C - NSUP = NSUP - IB - IF( CEIG ) THEN - NPC = NPC + IB - ELSE - NPR = NPR + IB - END IF - NUP = NUP + IB - ELSE -C -C The non-simple 2x2 block is uncontrollable. -C Eliminate its uncontrollable part by using -C the information in elements FI(1,1) and F(1,2). -C - C = DWORK(KFI) - S = DWORK(KFI+IB) -C -C Apply the transformation to A and accumulate it -C in Z. -C - CALL DROT( N-NL+1, A(NL,NL), LDA, - $ A(NSUP,NL), LDA, C, S ) - CALL DROT( N, A(1,NL), 1, A(1,NSUP), 1, C, S ) - CALL DROT( N, Z(1,NL), 1, Z(1,NSUP), 1, C, S ) -C -C Annihilate the subdiagonal element of the last -C block, redefine the upper limit for the bottom -C block and resume the main loop. -C - A(NSUP,NL) = ZERO - NSUP = NL - NUP = NUP + 1 - NPC = NPC + 2 - END IF - ELSE -C -C Successful assignment of IB eigenvalues. -C -C Update the feedback matrix F <-- F + [0 FI]*Z'. -C - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, - $ IB, ONE, DWORK(KFI), M, Z(1,NL), - $ LDZ, ONE, F, LDF ) -C -C Check for possible numerical instability. -C - IF( DLANGE( '1', M, IB, DWORK(KFI), M, DWORK(KW) ) - $ .GT. RMAX ) IWARN = IWARN + 1 -C -C Update the state matrix A <-- A + Z'*B*[0 FI]. -C Workspace needed: 2*N+4*M. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, IB, - $ M, ONE, B, LDB, DWORK(KFI), M, ZERO, - $ DWORK(KW), N ) - CALL DGEMM( 'Transpose', 'NoTranspose', NSUP, - $ IB, N, ONE, Z, LDZ, DWORK(KW), N, - $ ONE, A(1,NL), LDA ) -C -C Try to split the 2x2 block. -C - IF( IB .EQ. 2 ) - $ CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, - $ INFO ) - NAP = NAP + IB - IF( NLOW+IB.LE.NSUP ) THEN -C -C Move the last block(s) to the leading -C position(s) of the bottom block. -C - NCUR1 = NSUP - IB - NMOVES = 1 - IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN - IB = 1 - NMOVES = 2 - END IF -C -C WHILE (NMOVES > 0) DO - 30 IF( NMOVES .GT. 0 ) THEN - NCUR = NCUR1 -C -C WHILE (NCUR >= NLOW) DO - 40 IF( NCUR .GE. NLOW ) THEN -C -C Loop for the last block positioning. -C - IB1 = 1 - IF( NCUR.GT.NLOW ) THEN - IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 - END IF - CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, - $ NCUR-IB1+1, IB1, IB, - $ DWORK(KW), INFO ) - IF( INFO .NE. 0 ) THEN - INFO = 2 - RETURN - END IF - NCUR = NCUR - IB1 - GO TO 40 - END IF -C -C END WHILE 40 -C - NMOVES = NMOVES - 1 - NCUR1 = NCUR1 + 1 - NLOW = NLOW + IB - GO TO 30 - END IF -C -C END WHILE 30 -C - ELSE - NLOW = NLOW + IB - END IF - END IF - END IF - END IF - IF( INFO.EQ.0 ) GO TO 20 -C -C END WHILE 20 -C - END IF -C - WRKOPT = MAX( WRKOPT, 5*M, 2*N + 4*M ) - END IF -C -C Annihilate the elements below the first subdiagonal of A. -C - IF( N .GT. 2) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF( NAP .GT. 0 ) THEN -C -C Move the assigned eigenvalues in the first NAP positions of -C WR and WI. -C - K = IPC - NPR - 1 - IF( K .GT. 0 ) CALL DSWAP( K, WR(NPR+1), 1, WR, 1 ) - J = NAP - K - IF( J .GT. 0 ) THEN - CALL DSWAP( J, WR(IPC+NPC), 1, WR(K+1), 1 ) - CALL DSWAP( J, WI(IPC+NPC), 1, WI(K+1), 1 ) - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB01BD *** - END diff --git a/slycot/src/SB01BX.f b/slycot/src/SB01BX.f deleted file mode 100644 index 86812da0..00000000 --- a/slycot/src/SB01BX.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To choose a real eigenvalue or a pair of complex conjugate -C eigenvalues at "minimal" distance to a given real or complex -C value. -C -C ARGUMENTS -C -C Mode Parameters -C -C REIG LOGICAL -C Specifies the type of eigenvalues as follows: -C = .TRUE., a real eigenvalue is to be selected; -C = .FALSE., a pair of complex eigenvalues is to be -C selected. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of eigenvalues contained in the arrays WR -C and WI. N >= 1. -C -C XR,XI (input) DOUBLE PRECISION -C If REIG = .TRUE., XR must contain the real value and XI -C is assumed zero and therefore not referenced. -C If REIG = .FALSE., XR must contain the real part and XI -C the imaginary part, respectively, of the complex value. -C -C WR,WI (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, if REIG = .TRUE., WR must contain the real -C eigenvalues from which an eigenvalue at minimal distance -C to XR is to be selected. In this case, WI is considered -C zero and therefore not referenced. -C On entry, if REIG = .FALSE., WR and WI must contain the -C real and imaginary parts, respectively, of the eigenvalues -C from which a pair of complex conjugate eigenvalues at -C minimal "distance" to XR + jXI is to be selected. -C The eigenvalues of each pair of complex conjugate -C eigenvalues must appear consecutively. -C On exit, the elements of these arrays are reordered such -C that the selected eigenvalue(s) is (are) found in the -C last element(s) of these arrays. -C -C S,P (output) DOUBLE PRECISION -C If REIG = .TRUE., S (and also P) contains the value of -C the selected real eigenvalue. -C If REIG = .FALSE., S and P contain the sum and product, -C respectively, of the selected complex conjugate pair of -C eigenvalues. -C -C FURTHER COMMENTS -C -C For efficiency reasons, |x| + |y| is used for a complex number -C x + jy, instead of its modulus. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C February 1999. Based on the RASP routine PMDIST. -C -C REVISIONS -C -C March 30, 1999, V. Sima, Research Institute for Informatics, -C Bucharest. -C Feb. 15, 2004, V. Sima, Research Institute for Informatics, -C Bucharest. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - LOGICAL REIG - INTEGER N - DOUBLE PRECISION P, S, XI ,XR -C .. Array Arguments .. - DOUBLE PRECISION WI(*), WR(*) -C .. Local Scalars .. - INTEGER I, J, K - DOUBLE PRECISION X, Y -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - J = 1 - IF( REIG ) THEN - Y = ABS( WR(1)-XR ) - DO 10 I = 2, N - X = ABS( WR(I)-XR ) - IF( X .LT. Y ) THEN - Y = X - J = I - END IF - 10 CONTINUE - S = WR(J) - K = N - J - IF( K .GT. 0 ) THEN - DO 20 I = J, J + K - 1 - WR(I) = WR(I+1) - 20 CONTINUE - WR(N) = S - END IF - P = S - ELSE - Y = ABS( WR(1)-XR ) + ABS( WI(1)-XI ) - DO 30 I = 3, N, 2 - X = ABS( WR(I)-XR ) + ABS( WI(I)-XI ) - IF( X .LT. Y ) THEN - Y = X - J = I - END IF - 30 CONTINUE - X = WR(J) - Y = WI(J) - K = N - J - 1 - IF( K .GT. 0 ) THEN - DO 40 I = J, J + K - 1 - WR(I) = WR(I+2) - WI(I) = WI(I+2) - 40 CONTINUE - WR(N-1) = X - WI(N-1) = Y - WR(N) = X - WI(N) = -Y - END IF - S = X + X - P = X * X + Y * Y - END IF -C - RETURN -C *** End of SB01BX *** - END diff --git a/slycot/src/SB01BY.f b/slycot/src/SB01BY.f deleted file mode 100644 index 592161f2..00000000 --- a/slycot/src/SB01BY.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve an N-by-N pole placement problem for the simple cases -C N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B, -C construct an M-by-N matrix F such that A + B*F has prescribed -C eigenvalues. These eigenvalues are specified by their sum S and -C product P (if N = 2). The resulting F has minimum Frobenius norm. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and also the number of rows of -C the matrix B and the number of columns of the matrix F. -C N is either 1, if a single real eigenvalue is prescribed -C or 2, if a complex conjugate pair or a set of two real -C eigenvalues are prescribed. -C -C M (input) INTEGER -C The number of columns of the matrix B and also the number -C of rows of the matrix F. M >= 1. -C -C S (input) DOUBLE PRECISION -C The sum of the prescribed eigenvalues if N = 2 or the -C value of prescribed eigenvalue if N = 1. -C -C P (input) DOUBLE PRECISION -C The product of the prescribed eigenvalues if N = 2. -C Not referenced if N = 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (N,N) -C On entry, this array must contain the N-by-N state -C dynamics matrix whose eigenvalues have to be moved to -C prescribed locations. -C On exit, this array contains no useful information. -C -C B (input/output) DOUBLE PRECISION array, dimension (N,M) -C On entry, this array must contain the N-by-M input/state -C matrix B. -C On exit, this array contains no useful information. -C -C F (output) DOUBLE PRECISION array, dimension (M,N) -C The state feedback matrix F which assigns one pole or two -C poles of the closed-loop matrix A + B*F. -C If N = 2 and the pair (A,B) is not controllable -C (INFO = 1), then F(1,1) and F(1,2) contain the elements of -C an orthogonal rotation which can be used to remove the -C uncontrollable part of the pair (A,B). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of A -C and B are considered zero (used for controllability test). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if uncontrollability of the pair (A,B) is detected. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine SB01BY. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C May 2003, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Eigenvalue, eigenvalue assignment, feedback control, pole -C placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION FOUR, ONE, THREE, TWO, ZERO - PARAMETER ( FOUR = 4.0D0, ONE = 1.0D0, THREE = 3.0D0, - $ TWO = 2.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M, N - DOUBLE PRECISION P, S, TOL -C .. Array Arguments .. - DOUBLE PRECISION A(N,*), B(N,*), DWORK(*), F(M,*) -C .. Local Scalars .. - INTEGER IR, J - DOUBLE PRECISION ABSR, B1, B2, B21, C, C0, C1, C11, C12, C21, - $ C22, C3, C4, CS, CU, CV, DC0, DC2, DC3, DIFFR, - $ R, RN, S12, S21, SIG, SN, SU, SV, TAU1, TAU2, - $ WI, WI1, WR, WR1, X, Y, Z -C .. External Functions .. - DOUBLE PRECISION DLAMC3, DLAMCH - EXTERNAL DLAMC3, DLAMCH -C .. External Subroutines .. - EXTERNAL DLANV2, DLARFG, DLASET, DLASV2, SLCT_DLATZM, DROT -C .. Intrinsic Functions .. - INTRINSIC ABS, MIN -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - INFO = 0 - IF( N.EQ.1 ) THEN -C -C The case N = 1. -C - IF( M.GT.1 ) - $ CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) - B1 = B(1,1) - IF( ABS( B1 ).LE.TOL ) THEN -C -C The pair (A,B) is uncontrollable. -C - INFO = 1 - RETURN - END IF -C - F(1,1) = ( S - A(1,1) )/B1 - IF( M.GT.1 ) THEN - CALL DLASET( 'Full', M-1, 1, ZERO, ZERO, F(2,1), M ) - CALL SLCT_DLATZM( 'Left', M, N, B(1,2), N, TAU1, - $ F(1,1), F(2,1), - $ M, DWORK ) - END IF - RETURN - END IF -C -C In the sequel N = 2. -C -C Compute the singular value decomposition of B in the form -C -C ( V 0 ) ( B1 0 ) -C B = U*( G1 0 )*( )*H2*H1 , G1 = ( ), -C ( 0 I ) ( 0 B2 ) -C -C ( CU SU ) ( CV SV ) -C where U = ( ) and V = ( ) are orthogonal -C (-SU CU ) (-SV CV ) -C -C rotations and H1 and H2 are elementary Householder reflectors. -C ABS(B1) and ABS(B2) are the singular values of matrix B, -C with ABS(B1) >= ABS(B2). -C -C Reduce first B to the lower bidiagonal form ( B1 0 ... 0 ). -C ( B21 B2 ... 0 ) - IF( M.EQ.1 ) THEN -C -C Initialization for the case M = 1; no reduction required. -C - B1 = B(1,1) - B21 = B(2,1) - B2 = ZERO - ELSE -C -C Postmultiply B with elementary Householder reflectors H1 -C and H2. -C - CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) - CALL SLCT_DLATZM( 'Right', N-1, M, B(1,2), N, TAU1, - $ B(2,1), B(2,2), - $ N, DWORK ) - B1 = B(1,1) - B21 = B(2,1) - IF( M.GT.2 ) - $ CALL DLARFG( M-1, B(2,2), B(2,3), N, TAU2 ) - B2 = B(2,2) - END IF -C -C Reduce B to a diagonal form by premultiplying and postmultiplying -C it with orthogonal rotations U and V, respectively, and order the -C diagonal elements to have decreasing magnitudes. -C Note: B2 has been set to zero if M = 1. Thus in the following -C computations the case M = 1 need not to be distinguished. -C Note also that LAPACK routine DLASV2 assumes an upper triangular -C matrix, so the results should be adapted. -C - CALL DLASV2( B1, B21, B2, X, Y, SU, CU, SV, CV ) - SU = -SU - B1 = Y - B2 = X -C -C Compute A1 = U'*A*U. -C - CALL DROT( 2, A(2,1), 2, A(1,1), 2, CU, SU ) - CALL DROT( 2, A(1,2), 1, A(1,1), 1, CU, SU ) -C -C Compute the rank of B and check the controllability of the -C pair (A,B). -C - IR = 0 - IF( ABS( B2 ).GT.TOL ) IR = IR + 1 - IF( ABS( B1 ).GT.TOL ) IR = IR + 1 - IF( IR.EQ.0 .OR. ( IR.EQ.1 .AND. ABS( A(2,1) ).LE.TOL ) ) THEN - F(1,1) = CU - F(1,2) = -SU -C -C The pair (A,B) is uncontrollable. -C - INFO = 1 - RETURN - END IF -C -C Compute F1 which assigns N poles for the reduced pair (A1,G1). -C - X = DLAMC3( B1, B2 ) - IF( X.EQ.B1 ) THEN -C -C Rank one G1. -C - F(1,1) = ( S - ( A(1,1) + A(2,2) ) )/B1 - F(1,2) = -( A(2,2)*( A(2,2) - S ) + A(2,1)*A(1,2) + P )/ - $ A(2,1)/B1 - IF( M.GT.1 ) THEN - F(2,1) = ZERO - F(2,2) = ZERO - END IF - ELSE -C -C Rank two G1. -C - Z = ( S - ( A(1,1) + A(2,2) ) )/( B1*B1 + B2*B2 ) - F(1,1) = B1*Z - F(2,2) = B2*Z -C -C Compute an approximation for the minimum norm parameter -C selection. -C - X = A(1,1) + B1*F(1,1) - C = X*( S - X ) - P - IF( C.GE.ZERO ) THEN - SIG = ONE - ELSE - SIG = -ONE - END IF - S12 = B1/B2 - S21 = B2/B1 - C11 = ZERO - C12 = ONE - C21 = SIG*S12*C - C22 = A(1,2) - SIG*S12*A(2,1) - CALL DLANV2( C11, C12, C21, C22, WR, WI, WR1, WI1, CS, SN ) - IF( ABS( WR - A(1,2) ).GT.ABS( WR1 - A(1,2) ) ) THEN - R = WR1 - ELSE - R = WR - END IF -C -C Perform Newton iteration to solve the equation for minimum. -C - C0 = -C*C - C1 = C*A(2,1) - C4 = S21*S21 - C3 = -C4*A(1,2) - DC0 = C1 - DC2 = THREE*C3 - DC3 = FOUR*C4 -C - DO 10 J = 1, 10 - X = C0 + R*( C1 + R*R*( C3 + R*C4 ) ) - Y = DC0 + R*R*( DC2 + R*DC3 ) - IF( Y.EQ.ZERO ) GO TO 20 - RN = R - X/Y - ABSR = ABS( R ) - DIFFR = ABS( R - RN ) - Z = DLAMC3( ABSR, DIFFR ) - IF( Z.EQ.ABSR ) - $ GO TO 20 - R = RN - 10 CONTINUE -C - 20 CONTINUE - IF( R.EQ.ZERO ) R = DLAMCH( 'Epsilon' ) - F(1,2) = ( R - A(1,2) )/B1 - F(2,1) = ( C/R - A(2,1) )/B2 - END IF -C -C Back-transform F1. Compute first F1*U'. -C - CALL DROT( MIN( M, 2 ), F(1,1), 1, F(1,2), 1, CU, SU ) - IF( M.EQ.1 ) - $ RETURN -C -C Compute V'*F1. -C - CALL DROT( 2, F(2,1), M, F(1,1), M, CV, SV ) -C -C ( F1 ) -C Form F = ( ) . -C ( 0 ) -C - IF( M.GT.N ) - $ CALL DLASET( 'Full', M-N, N, ZERO, ZERO, F(N+1,1), M ) -C -C Compute H1*H2*F. -C - IF( M.GT.2 ) - $ CALL SLCT_DLATZM( 'Left', M-1, N, B(2,3), N, TAU2, - $ F(2,1), F(3,1), M, DWORK ) - CALL SLCT_DLATZM( 'Left', M, N, B(1,2), N, TAU1, - $ F(1,1), F(2,1), M, DWORK ) -C - RETURN -C *** Last line of SB01BY *** - END diff --git a/slycot/src/SB01DD.f b/slycot/src/SB01DD.f deleted file mode 100644 index 15ab1b8e..00000000 --- a/slycot/src/SB01DD.f +++ /dev/null @@ -1,643 +0,0 @@ - SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, - $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for a controllable matrix pair ( A, B ) a matrix G -C such that the matrix A - B*G has the desired eigenstructure, -C specified by desired eigenvalues and free eigenvector elements. -C -C The pair ( A, B ) should be given in orthogonal canonical form -C as returned by the SLICOT Library routine AB01ND. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and the number of rows of the -C matrix B. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix B. M >= 0. -C -C INDCON (input) INTEGER -C The controllability index of the pair ( A, B ). -C 0 <= INDCON <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N matrix A in orthogonal canonical form, -C as returned by SLICOT Library routine AB01ND. -C On exit, the leading N-by-N part of this array contains -C the real Schur form of the matrix A - B*G. -C The elements below the real Schur form of A are set to -C zero. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the N-by-M matrix B in orthogonal canonical form, -C as returned by SLICOT Library routine AB01ND. -C On exit, the leading N-by-M part of this array contains -C the transformed matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C NBLK (input) INTEGER array, dimension (N) -C The leading INDCON elements of this array must contain the -C orders of the diagonal blocks in the orthogonal canonical -C form of A, as returned by SLICOT Library routine AB01ND. -C The values of these elements must satisfy the following -C conditions: -C NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON), -C NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N. -C -C WR (input) DOUBLE PRECISION array, dimension (N) -C WI (input) DOUBLE PRECISION array, dimension (N) -C These arrays must contain the real and imaginary parts, -C respectively, of the desired poles of the closed-loop -C system, i.e., the eigenvalues of A - B*G. The poles can be -C unordered, except that complex conjugate pairs of poles -C must appear consecutively. -C The elements of WI for complex eigenvalues are modified -C internally, but restored on exit. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, the leading N-by-N part of this array must -C contain the orthogonal matrix Z generated by SLICOT -C Library routine AB01ND in the reduction of ( A, B ) to -C orthogonal canonical form. -C On exit, the leading N-by-N part of this array contains -C the orthogonal transformation matrix which reduces A - B*G -C to real Schur form. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= max(1,N). -C -C Y (input) DOUBLE PRECISION array, dimension (M*N) -C Y contains elements which are used as free parameters -C in the eigenstructure design. The values of these -C parameters are often set by an external optimization -C procedure. -C -C COUNT (output) INTEGER -C The actual number of elements in Y used as free -C eigenvector and feedback matrix elements in the -C eigenstructure design. -C -C G (output) DOUBLE PRECISION array, dimension (LDG,N) -C The leading M-by-N part of this array contains the -C feedback matrix which assigns the desired eigenstructure -C of A - B*G. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,M). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(M*N,M*M+2*N+4*M+1). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the pair ( A, B ) is not controllable or the free -C parameters are not set appropriately. -C -C METHOD -C -C The routine implements the method proposed in [1], [2]. -C -C REFERENCES -C -C [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and -C Postlethwaite, I. -C Optimal pole assignment design of linear multi-input systems. -C Report 96-11, Department of Engineering, Leicester University, -C 1996. -C -C [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M. -C A computational algorithm for pole assignment of linear multi -C input systems. IEEE Trans. Automatic Control, vol. AC-31, -C pp. 1044-1047, 1986. -C -C NUMERICAL ASPECTS -C -C The method implemented is backward stable. -C -C FURTHER COMMENTS -C -C The eigenvalues of the real Schur form matrix As, returned in the -C array A, are very close to the desired eigenvalues WR+WI*i. -C However, the eigenvalues of the closed-loop matrix A - B*G, -C computed by the QR algorithm using the matrices A and B, given on -C entry, may be far from WR+WI*i, although the relative error -C norm( Z'*(A - B*G)*Z - As )/norm( As ) -C is close to machine accuracy. This may happen when the eigenvalue -C problem for the matrix A - B*G is ill-conditioned. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, Technical University of Sofia, Oct. 1998. -C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library -C version. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. -C -C KEYWORDS -C -C Closed loop spectrum, closed loop systems, eigenvalue assignment, -C orthogonal canonical form, orthogonal transformation, pole -C placement, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C -C .. Scalar Arguments .. - INTEGER COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK, - $ LDZ, M, N - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ), NBLK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), - $ G( LDG, * ), WI( * ), WR( * ), Y( * ), - $ Z( LDZ, * ) -C .. -C .. Local Scalars .. - LOGICAL COMPLX - INTEGER I, IA, INDCN1, INDCN2, INDCRT, IP, IRMX, IWRK, - $ K, KK, KMR, L, LP1, M1, MAXWRK, MI, MP1, MR, - $ MR1, NBLKCR, NC, NI, NJ, NP1, NR, NR1, RANK - DOUBLE PRECISION P, Q, R, S, SVLMAX, TOLDEF -C .. -C .. Local Arrays .. - DOUBLE PRECISION SVAL( 3 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLAPY2 - EXTERNAL DASUM, DLAMCH, DLANGE, DLAPY2 -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLARF, - $ DLARFG, DLARTG, DLASET, DROT, DSCAL, MB02QD, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input arguments. -C - INFO = 0 - NR = 0 - IWRK = MAX( M*N, M*M + 2*N + 4*M + 1 ) - DO 10 I = 1, MIN( INDCON, N ) - NR = NR + NBLK( I ) - IF( I.GT.1 ) THEN - IF( NBLK( I-1 ).LT.NBLK( I ) ) - $ INFO = -8 - END IF - 10 CONTINUE - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( INDCON.LT.0 .OR. INDCON.GT.N ) 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( NR.NE.N ) THEN - INFO = -8 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDWORK.LT.IWRK ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB01DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( M, N, INDCON ).EQ.0 ) THEN - COUNT = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C - MAXWRK = IWRK - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance, based on machine precision. -C - TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) - END IF -C - IRMX = 2*N + 1 - IWRK = IRMX + M*M - M1 = NBLK( 1 ) - COUNT = 1 - INDCRT = INDCON - NBLKCR = NBLK( INDCRT ) -C -C Compute the Frobenius norm of [ B A ] (used for rank estimation), -C taking into account the structure. -C - NR = M1 - NC = 1 - SVLMAX = DLANGE( 'Frobenius', M1, M, B, LDB, DWORK ) -C - DO 20 I = 1, INDCRT - 1 - NR = NR + NBLK( I+1 ) - SVLMAX = DLAPY2( SVLMAX, - $ DLANGE( 'Frobenius', NR, NBLK( I ), - $ A( 1, NC ), LDA, DWORK ) ) - NC = NC + NBLK( I ) - 20 CONTINUE -C - SVLMAX = DLAPY2( SVLMAX, - $ DLANGE( 'Frobenius', N, NBLKCR, A( 1, NC ), LDA, - $ DWORK ) ) - L = 1 - MR = NBLKCR - NR = N - MR + 1 - 30 CONTINUE -C WHILE( INDCRT.GT.1 )LOOP - IF( INDCRT.GT.1 ) THEN -C -C Assign next eigenvalue/eigenvector. -C - LP1 = L + M1 - INDCN1 = INDCRT - 1 - MR1 = NBLK( INDCN1 ) - NR1 = NR - MR1 - COMPLX = WI(L).NE.ZERO - CALL DCOPY( MR, Y( COUNT ), 1, DWORK( NR ), 1 ) - COUNT = COUNT + MR - NC = 1 - IF( COMPLX ) THEN - CALL DCOPY( MR, Y( COUNT ), 1, DWORK( N+NR ), 1 ) - COUNT = COUNT + MR - WI( L+1 ) = WI( L )*WI( L+1 ) - NC = 2 - END IF -C -C Compute and transform eiegenvector. -C - DO 50 IP = 1, INDCRT - IF( IP.NE.INDCRT ) THEN - CALL DLACPY( 'Full', MR, MR1, A( NR, NR1 ), LDA, - $ DWORK( IRMX ), M ) - IF( IP.EQ.1 ) THEN - MP1 = MR - NP1 = NR + MP1 - ELSE - MP1 = MR + 1 - NP1 = NR + MP1 - S = DASUM( MP1, DWORK( NR ), 1 ) - IF( COMPLX ) S = S + DASUM( MP1, DWORK( N+NR ), 1 ) - IF( S.NE.ZERO ) THEN -C -C Scale eigenvector elements. -C - CALL DSCAL( MP1, ONE/S, DWORK( NR ), 1 ) - IF( COMPLX ) THEN - CALL DSCAL( MP1, ONE/S, DWORK( N+NR ), 1 ) - IF( NP1.LE.N ) - $ DWORK( N+NP1 ) = DWORK( N+NP1 ) / S - END IF - END IF - END IF -C -C Compute the right-hand side of the eigenvector equations. -C - CALL DCOPY( MR, DWORK( NR ), 1, DWORK( NR1 ), 1 ) - CALL DSCAL( MR, WR( L ), DWORK( NR1 ), 1 ) - CALL DGEMV( 'No transpose', MR, MP1, -ONE, A( NR, NR ), - $ LDA, DWORK( NR ), 1, ONE, DWORK( NR1 ), 1 ) - IF( COMPLX ) THEN - CALL DAXPY( MR, WI( L+1 ), DWORK( N+NR ), 1, - $ DWORK( NR1 ), 1 ) - CALL DCOPY( MR, DWORK( NR ), 1, DWORK( N+NR1 ), 1 ) - CALL DAXPY( MR, WR( L+1 ), DWORK( N+NR ), 1, - $ DWORK( N+NR1 ), 1 ) - CALL DGEMV( 'No transpose', MR, MP1, -ONE, - $ A( NR, NR ), LDA, DWORK( N+NR ), 1, ONE, - $ DWORK( N+NR1 ), 1 ) - IF( NP1.LE.N ) - $ CALL DAXPY( MR, -DWORK( N+NP1 ), A( NR, NP1 ), 1, - $ DWORK( N+NR1 ), 1 ) - END IF -C -C Solve linear equations for eigenvector elements. -C - CALL MB02QD( 'FreeElements', 'NoPermuting', MR, MR1, NC, - $ TOLDEF, SVLMAX, DWORK( IRMX ), M, - $ DWORK( NR1 ), N, Y( COUNT ), IWORK, RANK, - $ SVAL, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) - IF( RANK.LT.MR ) GO TO 80 -C - COUNT = COUNT + ( MR1 - MR )*NC - NJ = NR1 - ELSE - NJ = NR - END IF - NI = NR + MR - 1 - IF( IP.EQ.1 ) THEN - KMR = MR - 1 - ELSE - KMR = MR - IF( IP.EQ.2 ) THEN - NI = NI + NBLKCR - ELSE - NI = NI + NBLK( INDCRT-IP+2 ) + 1 - IF( COMPLX ) NI = MIN( NI+1, N ) - END IF - END IF -C - DO 40 KK = 1, KMR - K = NR + MR - KK - IF( IP.EQ.1 ) K = N - KK - CALL DLARTG( DWORK( K ), DWORK( K+1 ), P, Q, R ) - DWORK( K ) = R - DWORK( K+1 ) = ZERO -C -C Transform A. -C - CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), LDA, - $ P, Q ) - CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) -C - IF( K.LT.LP1 ) THEN -C -C Transform B. -C - CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, P, Q ) - END IF -C -C Accumulate transformations. -C - CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) -C - IF( COMPLX ) THEN - CALL DROT( 1, DWORK( N+K ), 1, DWORK( N+K+1 ), 1, P, - $ Q ) - K = K + 1 - IF( K.LT.N ) THEN - CALL DLARTG( DWORK( N+K ), DWORK( N+K+1 ), P, Q, - $ R ) - DWORK( N+K ) = R - DWORK( N+K+1 ) = ZERO -C -C Transform A. -C - CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), - $ LDA, P, Q ) - CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) -C - IF( K.LE.LP1 ) THEN -C -C Transform B. -C - CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, - $ P, Q ) - END IF -C -C Accumulate transformations. -C - CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) -C - END IF - END IF - 40 CONTINUE -C - IF( IP.NE.INDCRT ) THEN - MR = MR1 - NR = NR1 - IF( IP.NE.INDCN1 ) THEN - INDCN2 = INDCRT - IP - 1 - MR1 = NBLK( INDCN2 ) - NR1 = NR1 - MR1 - END IF - END IF - 50 CONTINUE -C - IF( .NOT.COMPLX ) THEN -C -C Find one column of G. -C - CALL DLACPY( 'Full', M1, M, B( L+1, 1 ), LDB, DWORK( IRMX ), - $ M ) - CALL DCOPY( M1, A( L+1, L ), 1, G( 1, L ), 1 ) - ELSE -C -C Find two columns of G. -C - IF( LP1.LT.N ) THEN - LP1 = LP1 + 1 - K = L + 2 - ELSE - K = L + 1 - END IF - CALL DLACPY( 'Full', M1, M, B( K, 1 ), LDB, DWORK( IRMX ), - $ M ) - CALL DLACPY( 'Full', M1, 2, A( K, L ), LDA, G( 1, L ), LDG ) - IF( K.EQ.L+1 ) THEN - G( 1, L ) = G( 1, L ) - - $ ( DWORK( N+L+1 ) / DWORK( L ) )*WI( L+1 ) - G( 1, L+1 ) = G( 1, L+1 ) - WR(L+1) + - $ ( DWORK( N+L ) / DWORK( L ) )*WI( L+1 ) - END IF - END IF -C - CALL MB02QD( 'FreeElements', 'NoPermuting', M1, M, NC, TOLDEF, - $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, - $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) - IF( RANK.LT.M1 ) GO TO 80 -C - COUNT = COUNT + ( M - M1 )*NC - CALL DGEMM( 'No transpose', 'No transpose', LP1, NC, M, -ONE, - $ B, LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) - L = L + 1 - NBLKCR = NBLKCR - 1 - IF( NBLKCR.EQ.0 ) THEN - INDCRT = INDCRT - 1 - NBLKCR = NBLK( INDCRT ) - END IF - IF( COMPLX ) THEN - WI( L ) = -WI( L-1 ) - L = L + 1 - NBLKCR = NBLKCR - 1 - IF( NBLKCR.EQ.0 ) THEN - INDCRT = INDCRT - 1 - IF( INDCRT.GT.0 ) NBLKCR = NBLK( INDCRT ) - END IF - END IF - MR = NBLKCR - NR = N - MR + 1 - GO TO 30 - END IF -C END WHILE 30 -C - IF( L.LE.N ) THEN -C -C Find the remaining columns of G. -C -C QR decomposition of the free eigenvectors. -C - DO 60 I = 1, MR - 1 - IA = L + I - 1 - MI = MR - I + 1 - CALL DCOPY( MI, Y( COUNT ), 1, DWORK( 1 ), 1 ) - COUNT = COUNT + MI - CALL DLARFG( MI, DWORK( 1 ), DWORK( 2 ), 1, R ) - DWORK( 1 ) = ONE -C -C Transform A. -C - CALL DLARF( 'Left', MI, MR, DWORK( 1 ), 1, R, A( IA, L ), - $ LDA, DWORK( N+1 ) ) - CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, A( 1, IA ), - $ LDA, DWORK( N+1 ) ) -C -C Transform B. -C - CALL DLARF( 'Left', MI, M, DWORK( 1 ), 1, R, B( IA, 1 ), - $ LDB, DWORK( N+1 ) ) -C -C Accumulate transformations. -C - CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, Z( 1, IA ), - $ LDZ, DWORK( N+1 ) ) - 60 CONTINUE -C - I = 0 -C REPEAT - 70 CONTINUE - I = I + 1 - IA = L + I - 1 - IF( WI( IA ).EQ.ZERO ) THEN - CALL DCOPY( MR, A( IA, L ), LDA, G( I, L ), LDG ) - CALL DAXPY( MR-I, -ONE, Y( COUNT ), 1, G( I, L+I ), LDG ) - COUNT = COUNT + MR - I - G( I, IA ) = G( I, IA ) - WR( IA ) - ELSE - CALL DLACPY( 'Full', 2, MR, A( IA, L ), LDA, G( I, L ), - $ LDG ) - CALL DAXPY( MR-I-1, -ONE, Y( COUNT ), 2, G( I, L+I+1 ), - $ LDG ) - CALL DAXPY( MR-I-1, -ONE, Y( COUNT+1 ), 2, - $ G( I+1, L+I+1 ), LDG ) - COUNT = COUNT + 2*( MR - I - 1 ) - G( I, IA ) = G(I, IA ) - WR( IA ) - G( I, IA+1 ) = G(I, IA+1 ) - WI( IA ) - G( I+1, IA ) = G(I+1, IA ) - WI( IA+1 ) - G( I+1, IA+1 ) = G(I+1, IA+1 ) - WR( IA+1 ) - I = I + 1 - END IF - IF( I.LT.MR ) GO TO 70 -C UNTIL I.GE.MR -C - CALL DLACPY( 'Full', MR, M, B( L, 1 ), LDB, DWORK( IRMX ), M ) - CALL MB02QD( 'FreeElements', 'NoPermuting', MR, M, MR, TOLDEF, - $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, - $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO ) - MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) - IF( RANK.LT.MR ) GO TO 80 -C - COUNT = COUNT + ( M - MR )*MR - CALL DGEMM( 'No transpose', 'No transpose', N, MR, M, -ONE, B, - $ LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) - END IF -C -C Transform G: -C G := G * Z'. -C - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, G, LDG, - $ Z, LDZ, ZERO, DWORK( 1 ), M ) - CALL DLACPY( 'Full', M, N, DWORK( 1 ), M, G, LDG ) - COUNT = COUNT - 1 -C - IF( N.GT.2) THEN -C -C Set the elements of A below the Hessenberg part to zero. -C - CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) - END IF - DWORK( 1 ) = MAXWRK - RETURN -C -C Exit with INFO = 1 if the pair ( A, B ) is not controllable or -C the free parameters are not set appropriately. -C - 80 INFO = 1 - RETURN -C *** Last line of SB01DD *** - END diff --git a/slycot/src/SB01FY.f b/slycot/src/SB01FY.f deleted file mode 100644 index 5cbb1ac6..00000000 --- a/slycot/src/SB01FY.f +++ /dev/null @@ -1,315 +0,0 @@ - SUBROUTINE SB01FY( DISCR, N, M, A, LDA, B, LDB, F, LDF, V, LDV, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the inner denominator of a right-coprime factorization -C of a system of order N, where N is either 1 or 2. Specifically, -C given the N-by-N unstable system state matrix A and the N-by-M -C system input matrix B, an M-by-N state-feedback matrix F and -C an M-by-M matrix V are constructed, such that the system -C (A + B*F, B*V, F, V) is inner. -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the type of system as follows: -C = .FALSE.: continuous-time system; -C = .TRUE. : discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and also the number of rows of -C the matrix B and the number of columns of the matrix F. -C N is either 1 or 2. -C -C M (input) INTEGER -C The number of columns of the matrices B and V, and also -C the number of rows of the matrix F. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A whose eigenvalues must have positive -C real parts if DISCR = .FALSE. or moduli greater than unity -C if DISCR = .TRUE.. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= N. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= N. -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the state- -C feedback matrix F which assigns one eigenvalue (if N = 1) -C or two eigenvalues (if N = 2) of the matrix A + B*F in -C symmetric positions with respect to the imaginary axis -C (if DISCR = .FALSE.) or the unit circle (if -C DISCR = .TRUE.). -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C V (output) DOUBLE PRECISION array, dimension (LDV,M) -C The leading M-by-M upper triangular part of this array -C contains the input/output matrix V of the resulting inner -C system in upper triangular form. -C If DISCR = .FALSE., the resulting V is an identity matrix. -C -C LDV INTEGER -C The leading dimension of array V. LDF >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if uncontrollability of the pair (A,B) is detected; -C = 2: if A is stable or at the stability limit; -C = 3: if N = 2 and A has a pair of real eigenvalues. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFID2. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Feb. 1999, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR - INTEGER INFO, LDA, LDB, LDF, LDV, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), F(LDF,*), V(LDV,*) -C .. Local Scalars .. - INTEGER I - DOUBLE PRECISION CS, R11, R12, R22, SCALE, SN, TEMP -C .. Local Arrays .. - DOUBLE PRECISION AT(2,2), DUMMY(2,2), U(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAPY2, DLAPY3 - EXTERNAL DLAPY2, DLAPY3 -C .. External Subroutines .. - EXTERNAL DLARFG, DLASET, SLCT_DLATZM, DROTG, DTRTRI, - $ MA02AD, MB04OX, SB03OY -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked. -C - INFO = 0 -C -C Compute an N-by-N upper triangular R such that R'*R = B*B' and -C find an upper triangular matrix U in the equation -C -C A'*U'*U + U'*U*A = R'*R if DISCR = .FALSE. or -C A'*U'*U*A - U'*U = R'*R if DISCR = .TRUE. . -C - CALL MA02AD( 'Full', N, M, B, LDB, F, LDF ) -C - IF( N.EQ.1 ) THEN -C -C The N = 1 case. -C - IF( M.GT.1 ) - $ CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) - R11 = ABS( F(1,1) ) -C -C Make sure A is unstable or divergent and find U. -C - IF( DISCR ) THEN - TEMP = ABS( A(1,1) ) - IF( TEMP.LE.ONE ) THEN - INFO = 2 - RETURN - ELSE - TEMP = R11 / SQRT( ( TEMP - ONE )*( TEMP + ONE ) ) - END IF - ELSE - IF( A(1,1).LE.ZERO ) THEN - INFO = 2 - RETURN - ELSE - TEMP = R11 / SQRT( ABS( TWO*A(1,1) ) ) - END IF - END IF - U(1,1) = TEMP - SCALE = ONE - ELSE -C -C The N = 2 case. -C - IF( M.GT.1 ) THEN - CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) - CALL SLCT_DLATZM( 'Left', M, N-1, F(2,1), 1, TEMP, F(1,2), - $ F(2,2), LDF, V ) - END IF - R11 = F(1,1) - R12 = F(1,2) - IF( M.GT.2 ) - $ CALL DLARFG( M-1, F(2,2), F(3,2), 1, TEMP ) - IF( M.EQ.1 ) THEN - R22 = ZERO - ELSE - R22 = F(2,2) - END IF - AT(1,1) = A(1,1) - AT(1,2) = A(2,1) - AT(2,1) = A(1,2) - AT(2,2) = A(2,2) - U(1,1) = R11 - U(1,2) = R12 - U(2,2) = R22 - CALL SB03OY( DISCR, .FALSE., -1, AT, 2, U, 2, DUMMY, 2, - $ SCALE, INFO ) - IF( INFO.NE.0 ) THEN - IF( INFO.NE.4 ) THEN - INFO = 2 - ELSE - INFO = 3 - END IF - RETURN - END IF - END IF -C -C Check the controllability of the pair (A,B). -C -C Warning. Only an exact controllability check is performed. -C If the pair (A,B) is nearly uncontrollable, then -C the computed results may be inaccurate. -C - DO 10 I = 1, N - IF( U(I,I).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF - 10 CONTINUE -C -C Set V = I. -C - CALL DLASET( 'Upper', M, M, ZERO, ONE, V, LDV ) -C - IF( DISCR ) THEN -C -C Compute an upper triangular matrix V such that -C -1 -C V*V' = (I+B'*inv(U'*U)*B) . -C -C First compute F = B'*inv(U) and the Cholesky factorization -C of I + F*F'. -C - DO 20 I = 1, M - F(I,1) = B(1,I)/U(1,1)*SCALE - 20 CONTINUE - IF( N.EQ.2 ) THEN - DO 30 I = 1, M - F(I,2) = ( B(2,I) - F(I,1)*U(1,2) )/U(2,2)*SCALE - 30 CONTINUE - CALL MB04OX( M, V, LDV, F(1,2), 1 ) - END IF - CALL MB04OX( M, V, LDV, F(1,1), 1 ) - CALL DTRTRI( 'Upper', 'NonUnit', M, V, LDV, INFO ) - END IF -C -C Compute the feedback matrix F as: -C -C 1) If DISCR = .FALSE. -C -C F = -B'*inv(U'*U); -C -C 2) If DISCR = .TRUE. -C -1 -C F = -B'*(U'*U+B*B') *A. -C - IF( N.EQ.1 ) THEN - IF( DISCR ) THEN - TEMP = -A(1,1) - R11 = DLAPY2( U(1,1), R11 ) - DO 40 I = 1, M - F(I,1) = ( ( B(1,I)/R11 )/R11 )*TEMP - 40 CONTINUE - ELSE - R11 = U(1,1) - DO 50 I = 1, M - F(I,1) = -( ( B(1,I)/R11 )/R11 ) - 50 CONTINUE - END IF - ELSE -C -C Set R = U if DISCR = .FALSE. or compute the Cholesky -C factorization of R'*R = U'*U+B*B' if DISCR = .TRUE.. -C - IF( DISCR ) THEN - TEMP = U(1,1) - CALL DROTG( R11, TEMP, CS, SN ) - TEMP = -SN*R12 + CS*U(1,2) - R12 = CS*R12 + SN*U(1,2) - R22 = DLAPY3( R22, TEMP, U(2,2) ) - ELSE - R11 = U(1,1) - R12 = U(1,2) - R22 = U(2,2) - END IF -C -C Compute F = -B'*inv(R'*R). -C - DO 60 I = 1, M - F(I,1) = -B(1,I)/R11 - F(I,2) = -( B(2,I) + F(I,1)*R12 )/R22 - F(I,2) = F(I,2)/R22 - F(I,1) = ( F(I,1) - F(I,2)*R12 )/R11 - 60 CONTINUE - IF( DISCR ) THEN -C -C Compute F <-- F*A. -C - DO 70 I = 1, M - TEMP = F(I,1)*A(1,1) + F(I,2)*A(2,1) - F(I,2) = F(I,1)*A(1,2) + F(I,2)*A(2,2) - F(I,1) = TEMP - 70 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of SB01FY *** - END diff --git a/slycot/src/SB01MD.f b/slycot/src/SB01MD.f deleted file mode 100644 index cc6abc4d..00000000 --- a/slycot/src/SB01MD.f +++ /dev/null @@ -1,397 +0,0 @@ - SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To determine the one-dimensional state feedback matrix G of the -C linear time-invariant single-input system -C -C dX/dt = A * X + B * U, -C -C where A is an NCONT-by-NCONT matrix and B is an NCONT element -C vector such that the closed-loop system -C -C dX/dt = (A - B * G) * X -C -C has desired poles. The system must be preliminarily reduced -C to orthogonal canonical form using the SLICOT Library routine -C AB01MD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NCONT (input) INTEGER -C The order of the matrix A as produced by SLICOT Library -C routine AB01MD. NCONT >= 0. -C -C N (input) INTEGER -C The order of the matrix Z. N >= NCONT. -C -C A (input/output) DOUBLE PRECISION array, dimension -C (LDA,NCONT) -C On entry, the leading NCONT-by-NCONT part of this array -C must contain the canonical form of the state dynamics -C matrix A as produced by SLICOT Library routine AB01MD. -C On exit, the leading NCONT-by-NCONT part of this array -C contains the upper quasi-triangular form S of the closed- -C loop system matrix (A - B * G), that is triangular except -C for possible 2-by-2 diagonal blocks. -C (To reconstruct the closed-loop system matrix see -C FURTHER COMMENTS below.) -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NCONT). -C -C B (input/output) DOUBLE PRECISION array, dimension (NCONT) -C On entry, this array must contain the canonical form of -C the input/state vector B as produced by SLICOT Library -C routine AB01MD. -C On exit, this array contains the transformed vector Z * B -C of the closed-loop system. -C -C WR (input) DOUBLE PRECISION array, dimension (NCONT) -C WI (input) DOUBLE PRECISION array, dimension (NCONT) -C These arrays must contain the real and imaginary parts, -C respectively, of the desired poles of the closed-loop -C system. The poles can be unordered, except that complex -C conjugate pairs of poles must appear consecutively. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, the leading N-by-N part of this array must -C contain the orthogonal transformation matrix as produced -C by SLICOT Library routine AB01MD, which reduces the system -C to canonical form. -C On exit, the leading NCONT-by-NCONT part of this array -C contains the orthogonal matrix Z which reduces the closed- -C loop system matrix (A - B * G) to upper quasi-triangular -C form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,N). -C -C G (output) DOUBLE PRECISION array, dimension (NCONT) -C This array contains the one-dimensional state feedback -C matrix G of the original system. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*NCONT) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The method is based on the orthogonal reduction of the closed-loop -C system matrix (A - B * G) to upper quasi-triangular form S whose -C 1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles. -C That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix. -C -C REFERENCES -C -C [1] Petkov, P. Hr. -C A Computational Algorithm for Pole Assignment of Linear -C Single Input Systems. -C Internal Report 81/2, Control Systems Research Group, School -C of Electronic Engineering and Computer Science, Kingston -C Polytechnic, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(NCONT ) operations and is backward -C stable. -C -C FURTHER COMMENTS -C -C If required, the closed-loop system matrix (A - B * G) can be -C formed from the matrix product Z * S * Z' (where S and Z are the -C matrices output in arrays A and Z respectively). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB01AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, May 1981. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Closed loop spectrum, closed loop systems, eigenvalue assignment, -C orthogonal canonical form, orthogonal transformation, pole -C placement, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDZ, N, NCONT -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*), - $ Z(LDZ,*) -C .. Local Scalars .. - LOGICAL COMPL - INTEGER I, IM1, K, L, LL, LP1, NCONT2, NI, NJ, NL - DOUBLE PRECISION B1, P, Q, R, S, T -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT, - $ DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NCONT.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.NCONT ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN - INFO = -4 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'SB01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( NCONT.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C -C Return if the system is not complete controllable. -C - IF ( B(1).EQ.ZERO ) - $ RETURN -C - IF ( NCONT.EQ.1 ) THEN -C -C 1-by-1 case. -C - P = A(1,1) - WR(1) - A(1,1) = WR(1) - G(1) = P/B(1) - Z(1,1) = ONE - RETURN - END IF -C -C General case. Save the contents of WI in DWORK. -C - NCONT2 = 2*NCONT - CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 ) -C - B1 = B(1) - B(1) = ONE - L = 0 - LL = 0 - 20 CONTINUE - L = L + 1 - LL = LL + 1 - COMPL = DWORK(NCONT2+L).NE.ZERO - IF ( L.NE.NCONT ) THEN - LP1 = L + 1 - NL = NCONT - L - IF ( LL.NE.2 ) THEN - IF ( COMPL ) THEN -C -C Compute complex eigenvector. -C - DWORK(NCONT) = ONE - DWORK(NCONT2) = ONE - P = WR(L) - T = DWORK(NCONT2+L) - Q = T*DWORK(NCONT2+LP1) - DWORK(NCONT2+L) = ONE - DWORK(NCONT2+LP1) = Q -C - DO 40 I = NCONT, LP1, -1 - IM1 = I - 1 - DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) - - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) - $ /A(I,IM1) - DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) - - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) ) - $ /A(I,IM1) - 40 CONTINUE -C - ELSE -C -C Compute real eigenvector. -C - DWORK(NCONT) = ONE - P = WR(L) -C - DO 60 I = NCONT, LP1, -1 - IM1 = I - 1 - DWORK(IM1) = ( P*DWORK(I) - - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) - $ /A(I,IM1) - 60 CONTINUE -C - END IF - END IF -C -C Transform eigenvector. -C - DO 80 K = NCONT - 1, L, -1 - IF ( LL.NE.2 ) THEN - R = DWORK(K) - S = DWORK(K+1) - ELSE - R = DWORK(NCONT+K) - S = DWORK(NCONT+K+1) - END IF - CALL DLARTG( R, S, P, Q, T ) - DWORK(K) = T - IF ( LL.NE.2 ) THEN - NJ = MAX( K-1, L ) - ELSE - DWORK(NCONT+K) = T - NJ = L - 1 - END IF -C -C Transform A. -C - CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q ) -C - IF ( COMPL .AND. LL.EQ.1 ) THEN - NI = NCONT - ELSE - NI = MIN( K+2, NCONT ) - END IF - CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q ) -C - IF ( K.EQ.L ) THEN -C -C Transform B. -C - T = B(K) - B(K) = P*T - B(K+1) = -Q*T - END IF -C -C Accumulate transformations. -C - CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q ) -C - IF ( COMPL .AND. LL.NE.2 ) THEN - T = DWORK(NCONT+K) - DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1) - DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T - END IF - 80 CONTINUE -C - END IF -C - IF ( .NOT.COMPL ) THEN -C -C Find one element of G. -C - K = L - R = B(L) - IF ( L.NE.NCONT ) THEN - IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN - K = LP1 - R = B(LP1) - END IF - END IF - P = A(K,L) - IF ( K.EQ.L ) P = P - WR(L) - P = P/R -C - CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 ) -C - G(L) = P/B1 - IF ( L.NE.NCONT ) THEN - LL = 0 - GO TO 20 - END IF - ELSE IF ( LL.EQ.1 ) THEN - GO TO 20 - ELSE -C -C Find two elements of G. -C - K = L - R = B(L) - IF ( L.NE.NCONT ) THEN - IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN - K = LP1 - R = B(LP1) - END IF - END IF - P = A(K,L-1) - Q = A(K,L) - IF ( K.EQ.L ) THEN - P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L) - Q = Q - WR(L) + - $ ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L) - END IF - P = P/R - Q = Q/R -C - CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 ) - CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 ) -C - G(L-1) = P/B1 - G(L) = Q/B1 - IF ( L.NE.NCONT ) THEN - LL = 0 - GO TO 20 - END IF - END IF -C -C Transform G. -C - CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1, - $ ZERO, DWORK, 1 ) - CALL DCOPY( NCONT, DWORK, 1, G, 1 ) - CALL DSCAL( NCONT, B1, B, 1 ) -C -C Annihilate A after the first subdiagonal. -C - IF ( NCONT.GT.2 ) - $ CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1), - $ LDA ) -C - RETURN -C *** Last line of SB01MD *** - END diff --git a/slycot/src/SB02CX.f b/slycot/src/SB02CX.f deleted file mode 100644 index d84f7217..00000000 --- a/slycot/src/SB02CX.f +++ /dev/null @@ -1,94 +0,0 @@ - LOGICAL FUNCTION SB02CX( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the purely imaginary eigenvalues in computing the -C H-infinity norm of a system. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02CX is set to .TRUE. for a purely imaginary -C eigenvalue and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C P. Hr. Petkov, Technical University of Sofia, May, 1999. -C -C REVISIONS -C -C P. Hr. Petkov, Technical University of Sofia, Oct. 2000. -C -C KEYWORDS -C -C H-infinity norm, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HUNDRD - PARAMETER ( HUNDRD = 100.0D+0 ) -C .. -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. -C .. Local Scalars .. - DOUBLE PRECISION EPS, TOL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. -C .. Executable Statements .. -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Set the tolerance in the determination of the purely -C imaginary eigenvalues. -C - TOL = HUNDRD*EPS - SB02CX = ABS( REIG ).LT.TOL -C - RETURN -C *** Last line of SB02CX *** - END diff --git a/slycot/src/SB02MD.f b/slycot/src/SB02MD.f deleted file mode 100644 index 4e517d34..00000000 --- a/slycot/src/SB02MD.f +++ /dev/null @@ -1,559 +0,0 @@ - SUBROUTINE SB02MD( DICO, HINV, UPLO, SCAL, SORT, N, A, LDA, G, - $ LDG, Q, LDQ, RCOND, WR, WI, S, LDS, U, LDU, - $ IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + A'*X + X*A - X*B*R B'*X = 0 (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C X = A'*X*A - A'*X*B*(R + B'*X*B) B'*X*A + Q (2) -C -C where A, B, Q and R are N-by-N, N-by-M, N-by-N and M-by-M matrices -C respectively, with Q symmetric and R symmetric nonsingular; X is -C an N-by-N symmetric matrix. -C -1 -C The matrix G = B*R B' must be provided on input, instead of B and -C R, that is, for instance, the continuous-time equation -C -C Q + A'*X + X*A - X*G*X = 0 (3) -C -C is solved, where G is an N-by-N symmetric matrix. SLICOT Library -C routine SB02MT should be used to compute G, given B and R. SB02MT -C also enables to solve Riccati equations corresponding to optimal -C problems with coupling terms. -C -C The routine also returns the computed values of the closed-loop -C spectrum of the optimal system, i.e., the stable eigenvalues -C lambda(1),...,lambda(N) of the corresponding Hamiltonian or -C symplectic matrix associated to the optimal problem. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved as -C follows: -C = 'C': Equation (3), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C HINV CHARACTER*1 -C If DICO = 'D', specifies which symplectic matrix is to be -C constructed, as follows: -C = 'D': The matrix H in (5) (see METHOD) is constructed; -C = 'I': The inverse of the matrix H in (5) is constructed. -C HINV is not used if DICO = 'C'. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C SCAL CHARACTER*1 -C Specifies whether or not a scaling strategy should be -C used, as follows: -C = 'G': General scaling should be used; -C = 'N': No scaling should be used. -C -C SORT CHARACTER*1 -C Specifies which eigenvalues should be obtained in the top -C of the Schur form, as follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, G and X. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A of the equation. -C On exit, if DICO = 'D', and INFO = 0 or INFO > 1, the -C -1 -C leading N-by-N part of this array contains the matrix A . -C Otherwise, the array A is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C The leading N-by-N upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C must contain the upper triangular part or lower triangular -C part, respectively, of the symmetric matrix G. The stricly -C lower triangular part (if UPLO = 'U') or stricly upper -C triangular part (if UPLO = 'L') is not referenced. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix Q. -C The stricly lower triangular part (if UPLO = 'U') or -C stricly upper triangular part (if UPLO = 'L') is not used. -C On exit, if INFO = 0, the leading N-by-N part of this -C array contains the solution matrix X of the problem. -C -C LDQ INTEGER -C The leading dimension of array N. LDQ >= MAX(1,N). -C -C RCOND (output) DOUBLE PRECISION -C An estimate of the reciprocal of the condition number (in -C the 1-norm) of the N-th order system of algebraic -C equations from which the solution matrix X is obtained. -C -C WR (output) DOUBLE PRECISION array, dimension (2*N) -C WI (output) DOUBLE PRECISION array, dimension (2*N) -C If INFO = 0 or INFO = 5, these arrays contain the real and -C imaginary parts, respectively, of the eigenvalues of the -C 2N-by-2N matrix S, ordered as specified by SORT (except -C for the case HINV = 'D', when the order is opposite to -C that specified by SORT). The leading N elements of these -C arrays contain the closed-loop spectrum of the system -C -1 -C matrix A - B*R *B'*X, if DICO = 'C', or of the matrix -C -1 -C A - B*(R + B'*X*B) B'*X*A, if DICO = 'D'. Specifically, -C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this -C array contains the ordered real Schur form S of the -C Hamiltonian or symplectic matrix H. That is, -C -C (S S ) -C ( 11 12) -C S = ( ), -C (0 S ) -C ( 22) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,2*N). -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) -C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this -C array contains the transformation matrix U which reduces -C the Hamiltonian or symplectic matrix H to the ordered real -C Schur form S. That is, -C -C (U U ) -C ( 11 12) -C U = ( ), -C (U U ) -C ( 21 22) -C -C where U , U , U and U are N-by-N matrices. -C 11 12 21 22 -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,2*N). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) returns the scaling factor used -C (set to 1 if SCAL = 'N'), also set if INFO = 5; -C if DICO = 'D', DWORK(3) returns the reciprocal condition -C number of the given matrix A. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(2,6*N) if DICO = 'C'; -C LDWORK >= MAX(3,6*N) if DICO = 'D'. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if matrix A is (numerically) singular in discrete- -C time case; -C = 2: if the Hamiltonian or symplectic matrix H cannot be -C reduced to real Schur form; -C = 3: if the real Schur form of the Hamiltonian or -C symplectic matrix H cannot be appropriately ordered; -C = 4: if the Hamiltonian or symplectic matrix H has less -C than N stable eigenvalues; -C = 5: if the N-th order system of linear algebraic -C equations, from which the solution matrix X would -C be obtained, is singular to working precision. -C -C METHOD -C -C The method used is the Schur vector approach proposed by Laub. -C It is assumed that [A,B] is a stabilizable pair (where for (3) B -C is any matrix such that B*B' = G with rank(B) = rank(G)), and -C [E,A] is a detectable pair, where E is any matrix such that -C E*E' = Q with rank(E) = rank(Q). Under these assumptions, any of -C the algebraic Riccati equations (1)-(3) is known to have a unique -C non-negative definite solution. See [2]. -C Now consider the 2N-by-2N Hamiltonian or symplectic matrix -C -C ( A -G ) -C H = ( ), (4) -C (-Q -A'), -C -C for continuous-time equation, and -C -1 -1 -C ( A A *G ) -C H = ( -1 -1 ), (5) -C (Q*A A' + Q*A *G) -C -1 -C for discrete-time equation, respectively, where G = B*R *B'. -C The assumptions guarantee that H in (4) has no pure imaginary -C eigenvalues, and H in (5) has no eigenvalues on the unit circle. -C If Y is an N-by-N matrix then there exists an orthogonal matrix U -C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U -C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks -C (corresponding to the complex conjugate eigenvalues and real -C eigenvalues respectively) appear in any desired order. This is the -C ordered real Schur form. Thus, we can find an orthogonal -C similarity transformation U which puts (4) or (5) in ordered real -C Schur form -C -C U'*H*U = S = (S(1,1) S(1,2)) -C ( 0 S(2,2)) -C -C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) -C have negative real parts in case of (4), or moduli greater than -C one in case of (5). If U is conformably partitioned into four -C N-by-N blocks -C -C U = (U(1,1) U(1,2)) -C (U(2,1) U(2,2)) -C -C with respect to the assumptions we then have -C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), -C (2), or (3) with X = X' and non-negative definite; -C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if -C DICO = 'D') are equal to the eigenvalues of optimal system -C (the 'closed-loop' spectrum). -C -C [A,B] is stabilizable if there exists a matrix F such that (A-BF) -C is stable. [E,A] is detectable if [A',E'] is stabilizable. -C -C REFERENCES -C -C [1] Laub, A.J. -C A Schur Method for Solving Algebraic Riccati equations. -C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. -C -C [2] Wonham, W.M. -C On a matrix Riccati equation of stochastic control. -C SIAM J. Contr., 6, pp. 681-697, 1968. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set -C SORT = 'S', if HINV = 'I'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying -C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or -C SORT = 'S' if DICO = 'D' and HINV = 'D'. -C -C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' -C and SORT = 'U', will be faster then the other combinations [3]. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB02AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HINV, SCAL, SORT, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDU, LDWORK, N - DOUBLE PRECISION RCOND -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*), U(LDU,*), WR(*), WI(*) -C .. Local Scalars .. - LOGICAL DISCR, LHINV, LSCAL, LSORT, LUPLO - INTEGER I, IERR, ISCL, N2, NP1, NROT - DOUBLE PRECISION GNORM, QNORM, RCONDA, UNORM, WRKOPT -C .. External Functions .. - LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, - $ SB02MV, SB02MW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, - $ DLACPY, DLASCL, DLASET, DSCAL, DSWAP, SB02MU, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - N2 = N + N - NP1 = N + 1 - DISCR = LSAME( DICO, 'D' ) - LSCAL = LSAME( SCAL, 'G' ) - LSORT = LSAME( SORT, 'S' ) - LUPLO = LSAME( UPLO, 'U' ) - IF ( DISCR ) LHINV = LSAME( HINV, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( DISCR ) THEN - IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) - $ INFO = -2 - END IF - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSCAL .AND. .NOT.LSAME( SCAL, 'N' ) ) THEN - INFO = -4 - ELSE IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN - INFO = -17 - ELSE IF( LDU.LT.MAX( 1, N2 ) ) THEN - INFO = -19 - ELSE IF( ( .NOT.DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) .OR. - $ ( DISCR .AND. LDWORK.LT.MAX( 3, 6*N ) ) ) THEN - INFO = -22 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - RCOND = ONE - DWORK(1) = ONE - DWORK(2) = ONE - IF ( DISCR ) DWORK(3) = ONE - RETURN - END IF -C - IF ( LSCAL ) THEN -C -C Compute the norms of the matrices Q and G. -C - QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) - END IF -C -C Initialise the Hamiltonian or symplectic matrix associated with -C the problem. -C Workspace: need 1 if DICO = 'C'; -C max(2,4*N) if DICO = 'D'; -C prefer larger if DICO = 'D'. -C - CALL SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, LDS, - $ IWORK, DWORK, LDWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF -C - WRKOPT = DWORK(1) - IF ( DISCR ) RCONDA = DWORK(2) -C - ISCL = 0 - IF ( LSCAL ) THEN -C -C Scale the Hamiltonian or symplectic matrix. -C - IF( QNORM.GT.GNORM .AND. GNORM.GT.ZERO ) THEN - CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), N2, - $ IERR ) - CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), N2, - $ IERR ) - ISCL = 1 - END IF - END IF -C -C Find the ordered Schur factorization of S, S = U*H*U'. -C Workspace: need 6*N; -C prefer larger. -C - IF ( .NOT.DISCR ) THEN - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, NROT, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - END IF - IF ( LHINV ) THEN - CALL DSWAP( N, WR, 1, WR(NP1), 1 ) - CALL DSWAP( N, WI, 1, WI(NP1), 1 ) - END IF - END IF - IF ( INFO.GT.N2 ) THEN - INFO = 3 - ELSE IF ( INFO.GT.0 ) THEN - INFO = 2 - ELSE IF ( NROT.NE.N ) THEN - INFO = 4 - END IF - IF ( INFO.NE.0 ) - $ RETURN -C - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C -C Check if U(1,1) is singular. Use the (2,1) block of S as a -C workspace for factoring U(1,1). -C - UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) -C - CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) - CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO ) -C - IF ( INFO.GT.0 ) THEN -C -C Singular matrix. Set INFO and RCOND for error return. -C - INFO = 5 - RCOND = ZERO - GO TO 100 - END IF -C -C Estimate the reciprocal condition of U(1,1). -C Workspace: 6*N. -C - CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, - $ DWORK, IWORK(NP1), INFO ) -C - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN -C -C Nearly singular matrix. Set INFO for error return. -C - INFO = 5 - RETURN - END IF -C -C Transpose U(2,1) in Q and compute the solution. -C - DO 60 I = 1, N - CALL DCOPY( N, U(NP1,I), 1, Q(I,1), LDQ ) - 60 CONTINUE -C - CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, Q, LDQ, - $ INFO ) -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) -C -C Make sure the solution matrix X is symmetric. -C - DO 80 I = 1, N - 1 - CALL DAXPY( N-I, ONE, Q(I,I+1), LDQ, Q(I+1,I), 1 ) - CALL DSCAL( N-I, HALF, Q(I+1,I), 1 ) - CALL DCOPY( N-I, Q(I+1,I), 1, Q(I,I+1), LDQ ) - 80 CONTINUE -C - IF( LSCAL ) THEN -C -C Undo scaling for the solution matrix. -C - IF( ISCL.EQ.1 ) - $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, Q, LDQ, IERR ) - END IF -C -C Set the optimal workspace, the scaling factor, and reciprocal -C condition number (if any). -C - DWORK(1) = WRKOPT - 100 CONTINUE - IF( ISCL.EQ.1 ) THEN - DWORK(2) = QNORM / GNORM - ELSE - DWORK(2) = ONE - END IF - IF ( DISCR ) DWORK(3) = RCONDA -C - RETURN -C *** Last line of SB02MD *** - END diff --git a/slycot/src/SB02MR.f b/slycot/src/SB02MR.f deleted file mode 100644 index f306a1b9..00000000 --- a/slycot/src/SB02MR.f +++ /dev/null @@ -1,75 +0,0 @@ - LOGICAL FUNCTION SB02MR( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable eigenvalues for solving the continuous-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MR is set to .TRUE. for an unstable -C eigenvalue and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. Executable Statements .. -C - SB02MR = REIG.GE.ZERO -C - RETURN -C *** Last line of SB02MR *** - END diff --git a/slycot/src/SB02MS.f b/slycot/src/SB02MS.f deleted file mode 100644 index 1e8481eb..00000000 --- a/slycot/src/SB02MS.f +++ /dev/null @@ -1,79 +0,0 @@ - LOGICAL FUNCTION SB02MS( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable eigenvalues for solving the discrete-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MS is set to .TRUE. for an unstable -C eigenvalue (i.e., with modulus greater than or equal to one) and -C to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, discrete-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Executable Statements .. -C - SB02MS = DLAPY2( REIG, IEIG ).GE.ONE -C - RETURN -C *** Last line of SB02MS *** - END diff --git a/slycot/src/SB02MT.f b/slycot/src/SB02MT.f deleted file mode 100644 index 7106bd97..00000000 --- a/slycot/src/SB02MT.f +++ /dev/null @@ -1,581 +0,0 @@ - SUBROUTINE SB02MT( JOBG, JOBL, FACT, UPLO, N, M, A, LDA, B, LDB, - $ Q, LDQ, R, LDR, L, LDL, IPIV, OUFACT, G, LDG, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the following matrices -C -C -1 -C G = B*R *B', -C -C - -1 -C A = A - B*R *L', -C -C - -1 -C Q = Q - L*R *L', -C -C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, -C N-by-M, and N-by-N matrices, respectively, with Q, R and G -C symmetric matrices. -C -C When R is well-conditioned with respect to inversion, standard -C algorithms for solving linear-quadratic optimization problems will -C then also solve optimization problems with coupling weighting -C matrix L. Moreover, a gain in efficiency is possible using matrix -C G in the deflating subspace algorithms (see SLICOT Library routine -C SB02OD). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBG CHARACTER*1 -C Specifies whether or not the matrix G is to be computed, -C as follows: -C = 'G': Compute G; -C = 'N': Do not compute G. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C -C FACT CHARACTER*1 -C Specifies how the matrix R is given (factored or not), as -C follows: -C = 'N': Array R contains the matrix R; -C = 'C': Array R contains the Cholesky factor of R; -C = 'U': Array R contains the symmetric indefinite UdU' or -C LdL' factorization of R. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices R and Q (if -C JOBL = 'N') is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, and G, and the number of -C rows of the matrices B and L. N >= 0. -C -C M (input) INTEGER -C The order of the matrix R, and the number of columns of -C the matrices B and L. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if JOBL = 'N', the leading N-by-N part of this -C array must contain the matrix A. -C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N -C - -1 -C part of this array contains the matrix A = A - B*R L'. -C If JOBL = 'Z', this array is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,N) if JOBL = 'N'; -C LDA >= 1 if JOBL = 'Z'. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the matrix B. -C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M -C -1 -C part of this array contains the matrix B*chol(R) . -C On exit, B is unchanged if OUFACT = 2 (hence also when -C FACT = 'U'). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if JOBL = 'N', the leading N-by-N upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the upper -C triangular part or lower triangular part, respectively, of -C the symmetric matrix Q. The stricly lower triangular part -C (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N -C upper triangular part (if UPLO = 'U') or lower triangular -C part (if UPLO = 'L') of this array contains the upper -C triangular part or lower triangular part, respectively, of -C - -1 -C the symmetric matrix Q = Q - L*R *L'. -C If JOBL = 'Z', this array is not referenced. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if JOBL = 'N'; -C LDQ >= 1 if JOBL = 'Z'. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry, if FACT = 'N', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the upper -C triangular part or lower triangular part, respectively, -C of the symmetric input weighting matrix R. -C On entry, if FACT = 'C', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the Cholesky -C factor of the positive definite input weighting matrix R -C (as produced by LAPACK routine DPOTRF). -C On entry, if FACT = 'U', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the factors of -C the UdU' or LdL' factorization, respectively, of the -C symmetric indefinite input weighting matrix R (as produced -C by LAPACK routine DSYTRF). -C If FACT = 'N', the stricly lower triangular part (if UPLO -C = 'U') or stricly upper triangular part (if UPLO = 'L') of -C this array is used as workspace. -C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the Cholesky factor of the given input weighting -C matrix. -C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the factors of the UdU' or LdL' factorization, -C respectively, of the given input weighting matrix. -C On exit R is unchanged if FACT = 'C' or 'U'. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) -C On entry, if JOBL = 'N', the leading N-by-M part of this -C array must contain the matrix L. -C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the -C leading N-by-M part of this array contains the matrix -C -1 -C L*chol(R) . -C On exit, L is unchanged if OUFACT = 2 (hence also when -C FACT = 'U'). -C L is not referenced if JOBL = 'Z'. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N'; -C LDL >= 1 if JOBL = 'Z'. -C -C IPIV (input/output) INTEGER array, dimension (M) -C On entry, if FACT = 'U', this array must contain details -C of the interchanges performed and the block structure of -C the d factor in the UdU' or LdL' factorization of matrix R -C (as produced by LAPACK routine DSYTRF). -C On exit, if OUFACT = 2, this array contains details of -C the interchanges performed and the block structure of the -C d factor in the UdU' or LdL' factorization of matrix R, -C as produced by LAPACK routine DSYTRF. -C This array is not referenced if FACT = 'C'. -C -C OUFACT (output) INTEGER -C Information about the factorization finally used. -C OUFACT = 1: Cholesky factorization of R has been used; -C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') -C factorization of R has been used. -C -C G (output) DOUBLE PRECISION array, dimension (LDG,N) -C If JOBG = 'G', and INFO = 0, the leading N-by-N upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array contains the upper -C triangular part (if UPLO = 'U') or lower triangular part -C -1 -C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. -C If JOBG = 'N', this array is not referenced. -C -C LDG INTEGER -C The leading dimension of array G. -C LDG >= MAX(1,N) if JOBG = 'G', -C LDG >= 1 if JOBG = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal -C condition number of the given matrix R. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 if FACT = 'C'; -C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N'; -C LDWORK >= MAX(1,N*M) if FACT = 'U'. -C For optimum performance LDWORK should be larger than 3*M, -C if FACT = 'N'. -C The N*M workspace is not needed for FACT = 'N', if matrix -C R is positive definite. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the i-th element (1 <= i <= M) of the d factor is -C exactly zero; the UdU' (or LdL') factorization has -C been completed, but the block diagonal matrix d is -C exactly singular; -C = M+1: if the matrix R is numerically singular. -C -C METHOD -C - - -C The matrices G, and/or A and Q are evaluated using the given or -C computed symmetric factorization of R. -C -C NUMERICAL ASPECTS -C -C The routine should not be used when R is ill-conditioned. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER FACT, JOBG, JOBL, UPLO - INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, - $ N, OUFACT -C .. Array Arguments .. - INTEGER IPIV(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), - $ L(LDL,*), Q(LDQ,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LFACTA, LFACTC, LFACTU, LJOBG, LJOBL, LUPLOU - CHARACTER TRANS - INTEGER I, J, WRKOPT - DOUBLE PRECISION EPS, RCOND, RNORM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DPOCON, DPOTRF, DSYCON, - $ DSYRK, DSYTRF, DSYTRS, DTRSM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBG = LSAME( JOBG, 'G' ) - LJOBL = LSAME( JOBL, 'N' ) - LFACTC = LSAME( FACT, 'C' ) - LFACTU = LSAME( FACT, 'U' ) - LUPLOU = LSAME( UPLO, 'U' ) - LFACTA = LFACTC.OR.LFACTU -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( ( LDA.LT.1 ) .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( ( LDQ.LT.1 ) .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -14 - ELSE IF( ( LDL.LT.1 ) .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN - INFO = -16 - ELSE IF( ( LDG.LT.1 ) .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN - INFO = -20 - ELSE IF( ( LFACTC .AND. LDWORK.LT.1 ) .OR. - $ ( LFACTU .AND. LDWORK.LT.MAX( 1, N*M ) ) .OR. - $ ( .NOT.LFACTA .AND. LDWORK.LT.MAX( 2, N*M, 3*M ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02MT', -INFO ) - RETURN - END IF -C - IF ( LFACTC ) THEN - OUFACT = 1 - ELSE IF ( LFACTU ) THEN - OUFACT = 2 - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 .OR. .NOT.( LJOBL.OR.LJOBG ) ) THEN - DWORK(1) = ONE - IF ( .NOT.LFACTA ) DWORK(2) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = 1 -C -C Set relative machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C - IF ( .NOT.LFACTA ) THEN -C -C Compute the norm of the matrix R, which is not factored. -C Then save the given triangle of R in the other strict triangle -C and the diagonal in the workspace, and try Cholesky -C factorization. -C Workspace: need M. -C - RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - CALL DCOPY( M, R, LDR+1, DWORK, 1 ) - IF( LUPLOU ) THEN -C - DO 20 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 20 CONTINUE -C - ELSE -C - DO 40 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 40 CONTINUE -C - END IF - CALL DPOTRF( UPLO, M, R, LDR, INFO ) - IF( INFO.EQ.0 ) THEN -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 3*M. -C - CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, - $ INFO ) -C -C Return if the matrix is singular to working precision. -C - OUFACT = 1 - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, 3*M ) - ELSE -C -C Use UdU' or LdL' factorization, first restoring the saved -C triangle. -C - CALL DCOPY( M, DWORK, 1, R, LDR+1 ) - IF( LUPLOU ) THEN -C - DO 60 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 60 CONTINUE -C - ELSE -C - DO 80 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 80 CONTINUE -C - END IF -C -C Compute the UdU' or LdL' factorization. -C Workspace: need 1, -C prefer M*NB. -C - CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) - OUFACT = 2 - IF( INFO.GT.0 ) THEN - DWORK(2) = ONE - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 2*M. -C - CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, - $ IWORK, INFO ) -C -C Return if the matrix is singular to working precision. -C - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - END IF - END IF -C - IF (OUFACT.EQ.1 ) THEN -C -C Solve positive definite linear system(s). -C - IF ( LUPLOU ) THEN - TRANS = 'N' - ELSE - TRANS = 'T' - END IF -C -C Solve the system X*U = B, overwriting B with X. -C - CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, - $ ONE, R, LDR, B, LDB ) -C - IF ( LJOBG ) THEN -C -1 -C Compute the matrix G = B*R *B', multiplying X*X' in G. -C - CALL DSYRK( UPLO, 'No transpose', N, M, ONE, B, LDB, ZERO, - $ G, LDG ) - END IF -C - IF( LJOBL ) THEN -C -C Update matrices A and Q. -C -C Solve the system Y*U = L, overwriting L with Y. -C - CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, - $ ONE, R, LDR, L, LDL ) -C -C Compute A <- A - X*Y'. -C - CALL DGEMM( 'No transpose', 'Transpose', N, N, M, -ONE, B, - $ LDB, L, LDL, ONE, A, LDA ) -C -C Compute Q <- Q - Y*Y'. -C - CALL DSYRK( UPLO, 'No transpose', N, M, -ONE, L, LDL, ONE, - $ Q, LDQ ) - END IF - ELSE -C -C Solve indefinite linear system(s). -C -C Solve the system UdU'*X = B' (or LdL'*X = B'). -C Workspace: need N*M. -C - DO 100 J = 1, M - CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) - 100 CONTINUE -C - CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) -C - IF ( LJOBG ) THEN -C -1 -C Compute a triangle of the matrix G = B*R *B' = B*X. -C - IF ( LUPLOU ) THEN - I = 1 -C - DO 120 J = 1, N - CALL DGEMV( 'No transpose', J, M, ONE, B, LDB, - $ DWORK(I), 1, ZERO, G(1,J), 1 ) - I = I + M - 120 CONTINUE -C - ELSE -C - DO 140 J = 1, N - CALL DGEMV( 'Transpose', M, J, ONE, DWORK, M, B(J,1), - $ LDB, ZERO, G(J,1), LDG ) - 140 CONTINUE -C - END IF - END IF -C - IF( LJOBL ) THEN -C -C Update matrices A and Q. -C -C Solve the system UdU'*Y = L' (or LdL'*Y = L'). -C - DO 160 J = 1, M - CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) - 160 CONTINUE -C - CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) -C -C A <- A - B*Y. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, M, -ONE, - $ B, LDB, DWORK, M, ONE, A, LDA ) -C - -1 -C Compute a triangle of the matrix Q = Q - L*R *L' = Q - L*Y. -C - IF ( LUPLOU ) THEN - I = 1 -C - DO 180 J = 1, N - CALL DGEMV( 'No transpose', J, M, -ONE, L, LDL, - $ DWORK(I), 1, ONE, Q(1,J), 1 ) - I = I + M - 180 CONTINUE -C - ELSE -C - DO 200 J = 1, N - CALL DGEMV( 'Transpose', M, J, -ONE, DWORK, M, L(J,1), - $ LDL, ONE, Q(J,1), LDQ ) - 200 CONTINUE -C - END IF - END IF - END IF -C - DWORK(1) = WRKOPT - IF ( .NOT.LFACTA ) DWORK(2) = RCOND -C -C *** Last line of SB02MT *** - RETURN - END diff --git a/slycot/src/SB02MU.f b/slycot/src/SB02MU.f deleted file mode 100644 index 567a2247..00000000 --- a/slycot/src/SB02MU.f +++ /dev/null @@ -1,486 +0,0 @@ - SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, - $ LDS, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the 2n-by-2n Hamiltonian or symplectic matrix S -C associated to the linear-quadratic optimization problem, used to -C solve the continuous- or discrete-time algebraic Riccati equation, -C respectively. -C -C For a continuous-time problem, S is defined by -C -C ( A -G ) -C S = ( ), (1) -C ( -Q -A') -C -C and for a discrete-time problem by -C -C -1 -1 -C ( A A *G ) -C S = ( -1 -1 ), (2) -C ( QA A' + Q*A *G ) -C -C or -C -C -T -T -C ( A + G*A *Q -G*A ) -C S = ( -T -T ), (3) -C ( -A *Q A ) -C -C where A, G, and Q are N-by-N matrices, with G and Q symmetric. -C Matrix A must be nonsingular in the discrete-time case. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': Continuous-time system; -C = 'D': Discrete-time system. -C -C HINV CHARACTER*1 -C If DICO = 'D', specifies which of the matrices (2) or (3) -C is constructed, as follows: -C = 'D': The matrix S in (2) is constructed; -C = 'I': The (inverse) matrix S in (3) is constructed. -C HINV is not referenced if DICO = 'C'. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. -C On exit, if DICO = 'D', and INFO = 0, the leading N-by-N -C -1 -C part of this array contains the matrix A . -C Otherwise, the array A is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C The leading N-by-N upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C must contain the upper triangular part or lower triangular -C part, respectively, of the symmetric matrix G. The stricly -C lower triangular part (if UPLO = 'U') or stricly upper -C triangular part (if UPLO = 'L') is not referenced. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C The leading N-by-N upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C must contain the upper triangular part or lower triangular -C part, respectively, of the symmetric matrix Q. The stricly -C lower triangular part (if UPLO = 'U') or stricly upper -C triangular part (if UPLO = 'L') is not referenced. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,N). -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If INFO = 0, the leading 2N-by-2N part of this array -C contains the Hamiltonian or symplectic matrix of the -C problem. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,2*N). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal -C condition number of the given matrix A. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 if DICO = 'C'; -C LDWORK >= MAX(2,4*N) if DICO = 'D'. -C For optimum performance LDWORK should be larger, if -C DICO = 'D'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the leading i-by-i (1 <= i <= N) upper triangular -C submatrix of A is singular in discrete-time case; -C = N+1: if matrix A is numerically singular in discrete- -C time case. -C -C METHOD -C -C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) -C is constructed. -C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or -C (3) - the inverse of the matrix in (2) - is constructed. -C -C NUMERICAL ASPECTS -C -C The discrete-time case needs the inverse of the matrix A, hence -C the routine should not be used when A is ill-conditioned. -C 3 -C The algorithm requires 0(n ) floating point operations in the -C discrete-time case. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HINV, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*) -C .. Local Scalars .. - LOGICAL DISCR, LHINV, LUPLO - INTEGER I, J, MAXWRK, N2, NJ, NP1 - DOUBLE PRECISION ANORM, RCOND -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS, - $ DLACPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - N2 = N + N - DISCR = LSAME( DICO, 'D' ) - LUPLO = LSAME( UPLO, 'U' ) - IF( DISCR ) THEN - LHINV = LSAME( HINV, 'D' ) - ELSE - LHINV = .FALSE. - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( DISCR ) THEN - IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) - $ INFO = -2 - END IF - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN - INFO = -12 - ELSE IF( ( LDWORK.LT.1 ) .OR. - $ ( DISCR .AND. LDWORK.LT.MAX( 2, 4*N ) ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02MU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = ONE - IF ( DISCR ) DWORK(2) = ONE - RETURN - END IF -C -C The code tries to exploit data locality as much as possible. -C - IF ( .NOT.LHINV ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) -C -C Construct Hamiltonian matrix in the continuous-time case, or -C prepare symplectic matrix in (3) in the discrete-time case: -C -C Construct full Q in S(N+1:2*N,1:N) and change the sign, and -C construct full G in S(1:N,N+1:2*N) and change the sign. -C - DO 200 J = 1, N - NJ = N + J - IF ( LUPLO ) THEN -C - DO 20 I = 1, J - S(N+I,J) = -Q(I,J) - 20 CONTINUE -C - DO 40 I = J + 1, N - S(N+I,J) = -Q(J,I) - 40 CONTINUE -C - DO 60 I = 1, J - S(I,NJ) = -G(I,J) - 60 CONTINUE -C - DO 80 I = J + 1, N - S(I,NJ) = -G(J,I) - 80 CONTINUE -C - ELSE -C - DO 100 I = 1, J - 1 - S(N+I,J) = -Q(J,I) - 100 CONTINUE -C - DO 120 I = J, N - S(N+I,J) = -Q(I,J) - 120 CONTINUE -C - DO 140 I = 1, J - 1 - S(I,NJ) = -G(J,I) - 140 CONTINUE -C - DO 180 I = J, N - S(I,NJ) = -G(I,J) - 180 CONTINUE -C - END IF - 200 CONTINUE -C - IF ( .NOT.DISCR ) THEN -C - DO 240 J = 1, N - NJ = N + J -C - DO 220 I = 1, N - S(N+I,NJ) = -A(J,I) - 220 CONTINUE -C - 240 CONTINUE -C - DWORK(1) = ONE - END IF - END IF -C - IF ( DISCR ) THEN -C -C Construct the symplectic matrix (2) or (3) in the discrete-time -C case. -C -C Compute workspace. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of workspace needed at that point in the code, -C as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - MAXWRK = MAX( 4*N, - $ N*ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) ) - NP1 = N + 1 -C - IF ( LHINV ) THEN -C -C Put A' in S(N+1:2*N,N+1:2*N). -C - DO 260 I = 1, N - CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 ) - 260 CONTINUE -C - END IF -C -C Compute the norm of the matrix A. -C - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) -C -C Compute the LU factorization of A. -C - CALL DGETRF( N, N, A, LDA, IWORK, INFO ) -C -C Return if INFO is non-zero. -C - IF( INFO.GT.0 ) THEN - DWORK(2) = ZERO - RETURN - END IF -C -C Compute the reciprocal of the condition number of A. -C Workspace: need 4*N. -C - CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK, - $ IWORK(NP1), INFO ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN - INFO = N + 1 - DWORK(2) = RCOND - RETURN - END IF -C - IF ( LHINV ) THEN -C -C Compute S in (2). -C -C Construct full Q in S(N+1:2*N,1:N). -C - IF ( LUPLO ) THEN - DO 270 J = 1, N - 1 - CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 ) - CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 ) - 270 CONTINUE - CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 ) - ELSE - CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 ) - DO 280 J = 2, N - CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 ) - CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 ) - 280 CONTINUE - END IF -C -C Compute the solution matrix X of the system X*A = Q by -C -1 -C solving A'*X' = Q and transposing the result to get Q*A . -C - CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), - $ LDS, INFO ) -C - DO 300 J = 1, N - 1 - CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) - 300 CONTINUE -C -C Construct full G in S(1:N,N+1:2*N). -C - IF ( LUPLO ) THEN - DO 310 J = 1, N - 1 - CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 ) - CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 ) - 310 CONTINUE - CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 ) - ELSE - CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 ) - DO 320 J = 2, N - CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 ) - CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 ) - 320 CONTINUE - END IF -C -1 -C Compute A' + Q*A *G in S(N+1:2N,N+1:2N). -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1), - $ LDS ) -C -C Compute the solution matrix Y of the system A*Y = G. -C - CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), - $ LDS, INFO ) -C -C Compute the inverse of A in situ. -C Workspace: need N; prefer N*NB. -C - CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) -C -1 -C Copy A in S(1:N,1:N). -C - CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) -C - ELSE -C -C Compute S in (3) using the already prepared part. -C -C Compute the solution matrix X' of the system A*X' = -G -C -T -C and transpose the result to obtain X = -G*A . -C - CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), - $ LDS, INFO ) -C - DO 340 J = 1, N - 1 - CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS ) - 340 CONTINUE -C -T -C Compute A + G*A *Q in S(1:N,1:N). -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS ) -C -C Compute the solution matrix Y of the system A'*Y = -Q. -C - CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), - $ LDS, INFO ) -C -C Compute the inverse of A in situ. -C Workspace: need N; prefer N*NB. -C - CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) -C -T -C Copy A in S(N+1:2N,N+1:2N). -C - DO 360 J = 1, N - CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 ) - 360 CONTINUE -C - END IF - DWORK(1) = MAXWRK - DWORK(2) = RCOND - END IF -C -C *** Last line of SB02MU *** - RETURN - END diff --git a/slycot/src/SB02MV.f b/slycot/src/SB02MV.f deleted file mode 100644 index 5dc8e245..00000000 --- a/slycot/src/SB02MV.f +++ /dev/null @@ -1,75 +0,0 @@ - LOGICAL FUNCTION SB02MV( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable eigenvalues for solving the continuous-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MV is set to .TRUE. for a stable eigenvalue -C and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. Executable Statements .. -C - SB02MV = REIG.LT.ZERO -C - RETURN -C *** Last line of SB02MV *** - END diff --git a/slycot/src/SB02MW.f b/slycot/src/SB02MW.f deleted file mode 100644 index eb54ebae..00000000 --- a/slycot/src/SB02MW.f +++ /dev/null @@ -1,79 +0,0 @@ - LOGICAL FUNCTION SB02MW( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable eigenvalues for solving the discrete-time -C algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C REIG (input) DOUBLE PRECISION -C The real part of the current eigenvalue considered. -C -C IEIG (input) DOUBLE PRECISION -C The imaginary part of the current eigenvalue considered. -C -C METHOD -C -C The function value SB02MW is set to .TRUE. for a stable -C eigenvalue (i.e., with modulus less than one) and to .FALSE., -C otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, discrete-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION IEIG, REIG -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Executable Statements .. -C - SB02MW = DLAPY2( REIG, IEIG ).LT.ONE -C - RETURN -C *** Last line of SB02MW *** - END diff --git a/slycot/src/SB02ND.f b/slycot/src/SB02ND.f deleted file mode 100644 index 1f446c02..00000000 --- a/slycot/src/SB02ND.f +++ /dev/null @@ -1,755 +0,0 @@ - SUBROUTINE SB02ND( DICO, FACT, UPLO, JOBL, N, M, P, A, LDA, B, - $ LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F, - $ LDF, OUFACT, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the optimal feedback matrix F for the problem of -C optimal control given by -C -C -1 -C F = (R + B'XB) (B'XA + L') (1) -C -C in the discrete-time case and -C -C -1 -C F = R (B'X + L') (2) -C -C in the continuous-time case, where A, B and L are N-by-N, N-by-M -C and N-by-M matrices respectively; R and X are M-by-M and N-by-N -C symmetric matrices respectively. -C -C Optionally, matrix R may be specified in a factored form, and L -C may be zero. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the equation from which F is to be determined, -C as follows: -C = 'D': Equation (1), discrete-time case; -C = 'C': Equation (2), continuous-time case. -C -C FACT CHARACTER*1 -C Specifies how the matrix R is given (factored or not), as -C follows: -C = 'N': Array R contains the matrix R; -C = 'D': Array R contains a P-by-M matrix D, where R = D'D; -C = 'C': Array R contains the Cholesky factor of R; -C = 'U': Array R contains the symmetric indefinite UdU' or -C LdL' factorization of R. This option is not -C available for DICO = 'D'. -C -C UPLO CHARACTER*1 -C Specifies which triangle of the possibly factored matrix R -C (or R + B'XB, on exit) is or should be stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C This parameter must be specified only for FACT = 'D'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If DICO = 'D', the leading N-by-N part of this array must -C contain the state matrix A of the system. -C If DICO = 'C', this array is not referenced. -C -C LDA INTEGER -C The leading dimension of array A. -C LDA >= MAX(1,N) if DICO = 'D'; -C LDA >= 1 if DICO = 'C'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C If DICO = 'D' and FACT = 'D' or 'C', the contents of this -C array is destroyed. -C Otherwise, B is unchanged on exit. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry, if FACT = 'N', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the upper -C triangular part or lower triangular part, respectively, -C of the symmetric input weighting matrix R. -C On entry, if FACT = 'D', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. -C On entry, if FACT = 'C', the leading M-by-M upper -C triangular part (if UPLO = 'U') or lower triangular part -C (if UPLO = 'L') of this array must contain the Cholesky -C factor of the positive definite input weighting matrix R -C (as produced by LAPACK routine DPOTRF). -C On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M -C upper triangular part (if UPLO = 'U') or lower triangular -C part (if UPLO = 'L') of this array must contain the -C factors of the UdU' or LdL' factorization, respectively, -C of the symmetric indefinite input weighting matrix R (as -C produced by LAPACK routine DSYTRF). -C The stricly lower triangular part (if UPLO = 'U') or -C stricly upper triangular part (if UPLO = 'L') of this -C array is used as workspace. -C On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the Cholesky factor of the given input weighting -C matrix (for DICO = 'C'), or that of the matrix R + B'XB -C (for DICO = 'D'). -C On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1), -C the leading M-by-M upper triangular part (if UPLO = 'U') -C or lower triangular part (if UPLO = 'L') of this array -C contains the factors of the UdU' or LdL' factorization, -C respectively, of the given input weighting matrix -C (for DICO = 'C'), or that of the matrix R + B'XB -C (for DICO = 'D'). -C On exit R is unchanged if FACT = 'U'. -C -C LDR INTEGER. -C The leading dimension of the array R. -C LDR >= MAX(1,M) if FACT <> 'D'; -C LDR >= MAX(1,M,P) if FACT = 'D'. -C -C IPIV (input/output) INTEGER array, dimension (M) -C On entry, if FACT = 'U', this array must contain details -C of the interchanges performed and the block structure of -C the d factor in the UdU' or LdL' factorization of matrix R -C (as produced by LAPACK routine DSYTRF). -C On exit, if OUFACT(1) = 2, this array contains details of -C the interchanges performed and the block structure of the -C d factor in the UdU' or LdL' factorization of matrix R (or -C D'D) or R + B'XB (or D'D + B'XB), as produced by LAPACK -C routine DSYTRF. -C This array is not referenced for DICO = 'D' or FACT = 'D', -C or 'C'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,M) -C If JOBL = 'N', the leading N-by-M part of this array must -C contain the cross weighting matrix L. -C If JOBL = 'Z', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N'; -C LDL >= 1 if JOBL = 'Z'. -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading N-by-N part of this array must -C contain the solution matrix X of the algebraic Riccati -C equation as produced by SLICOT Library routines SB02MD or -C SB02OD. Matrix X is assumed non-negative definite. -C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 1, -C and INFO = 0, the N-by-N upper triangular part of this -C array contains the Cholesky factor of the given matrix X, -C which is found to be positive definite. -C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2, -C and INFO = 0, the leading N-by-N part of this array -C contains the matrix of orthonormal eigenvectors of X. -C On exit X is unchanged if DICO = 'C' or FACT = 'N'. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C RNORM (input) DOUBLE PRECISION -C If FACT = 'U', this parameter must contain the 1-norm of -C the original matrix R (before factoring it). -C Otherwise, this parameter is not used. -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the -C optimal feedback matrix F. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C OUFACT (output) INTEGER array, dimension (2) -C Information about the factorization finally used. -C OUFACT(1) = 1: Cholesky factorization of R (or R + B'XB) -C has been used; -C OUFACT(1) = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = -C 'L') factorization of R (or R + B'XB) -C has been used; -C OUFACT(2) = 1: Cholesky factorization of X has been used; -C OUFACT(2) = 2: Spectral factorization of X has been used. -C The value of OUFACT(2) is not set for DICO = 'C' or for -C DICO = 'D' and FACT = 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2) contains the reciprocal condition -C number of the matrix R (for DICO = 'C') or of R + B'XB -C (for DICO = 'D'). -C If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),..., -C DWORK(N+2) contain the eigenvalues of X, in ascending -C order. -C -C LDWORK INTEGER -C Dimension of working array DWORK. -C LDWORK >= max(2,3*M) if FACT = 'N'; -C LDWORK >= max(2,2*M) if FACT = 'U'; -C LDWORK >= max(2,3*M) if FACT = 'C', DICO = 'C'; -C LDWORK >= N+3*M+2 if FACT = 'C', DICO = 'D'; -C LDWORK >= max(2,min(P,M)+M) if FACT = 'D', DICO = 'C'; -C LDWORK >= max(N+3*M+2,4*N+1) if FACT = 'D', DICO = 'D'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the i-th element of the d factor is exactly zero; -C the UdU' (or LdL') factorization has been completed, -C but the block diagonal matrix d is exactly singular; -C = M+1: if the matrix R (if DICO = 'C'), or R + B'XB -C (if DICO = 'D') is numerically singular (to working -C precision); -C = M+2: if one or more of the eigenvalues of X has not -C converged. -C -C METHOD -C -C The optimal feedback matrix F is obtained as the solution to the -C system of linear equations -C -C (R + B'XB) * F = B'XA + L' -C -C in the discrete-time case and -C -C R * F = B'X + L' -C -C in the continuous-time case, with R replaced by D'D if FACT = 'D'. -C The factored form of R, specified by FACT <> 'N', is taken into -C account. If FACT = 'N', Cholesky factorization is tried first, but -C if the coefficient matrix is not positive definite, then UdU' (or -C LdL') factorization is used. The discrete-time case involves -C updating of a triangular factorization of R (or D'D); Cholesky or -C symmetric spectral factorization of X is employed to avoid -C squaring of the condition number of the matrix. When D is given, -C its QR factorization is determined, and the triangular factor is -C used as described above. -C -C NUMERICAL ASPECTS -C -C The algorithm consists of numerically stable steps. -C 3 2 -C For DICO = 'C', it requires O(m + mn ) floating point operations -C 2 -C if FACT = 'N' and O(mn ) floating point operations, otherwise. -C For DICO = 'D', the operation counts are similar, but additional -C 3 -C O(n ) floating point operations may be needed in the worst case. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, matrix algebra, optimal control, -C optimal regulator. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOBL, UPLO - INTEGER INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M, - $ N, P - DOUBLE PRECISION RNORM -C .. Array Arguments .. - INTEGER IPIV(*), IWORK(*), OUFACT(2) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), - $ L(LDL,*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - LOGICAL DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LUPLOU, - $ WITHL - INTEGER I, IFAIL, ITAU, J, JW, JWORK, JZ, WRKOPT - DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUMMY(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, DPOCON, - $ DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, DSYTRF, - $ DSYTRS, DTRCON, DTRMM, MB04KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LFACTC = LSAME( FACT, 'C' ) - LFACTD = LSAME( FACT, 'D' ) - LFACTU = LSAME( FACT, 'U' ) - LUPLOU = LSAME( UPLO, 'U' ) - WITHL = LSAME( JOBL, 'N' ) - LFACTA = LFACTC.OR.LFACTD.OR.LFACTU -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( ( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. - $ ( DISCR .AND. LFACTU ) ) THEN - INFO = -2 - ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -3 - ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( ( .NOT.DISCR .AND. LDA.LT.1 ) .OR. - $ ( DISCR .AND. LDA.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( ( LDR.LT.MAX( 1, M ) ) .OR. - $ ( LFACTD .AND. LDR.LT.MAX( 1, P ) ) ) THEN - INFO = -13 - ELSE IF( ( .NOT.WITHL .AND. LDL.LT.1 ) .OR. - $ ( WITHL .AND. LDL.LT.MAX( 1, N ) ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LFACTU ) THEN - IF( RNORM.LT.ZERO ) - $ INFO = -19 - END IF - IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -21 - ELSE IF( ( ( .NOT.LFACTA .OR. ( LFACTC .AND. .NOT.DISCR ) ) - $ .AND. LDWORK.LT.MAX( 2, 3*M ) ) .OR. - $ ( LFACTU .AND. LDWORK.LT.MAX( 2, 2*M ) ) .OR. - $ ( DISCR .AND. LFACTC .AND. LDWORK.LT.N + 3*M + 2 ) .OR. - $(.NOT.DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( 2, MIN(P,M) + M ) ) - $ .OR. - $ ( DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( N + 3*M + 2, - $ 4*N + 1 ) ) ) THEN - INFO = -25 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 .OR. ( LFACTD .AND. P.EQ.0 ) ) THEN - DWORK(1) = ONE - DWORK(2) = ONE - RETURN - END IF -C - WRKOPT = 1 - EPS = DLAMCH( 'Epsilon' ) -C -C Determine the right-hand side of the matrix equation. -C Compute B'X in F. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DGEMM( 'Transpose', 'No transpose', M, N, N, ONE, B, LDB, X, - $ LDX, ZERO, F, LDF ) -C - IF ( .NOT.LFACTA ) THEN - IF ( DISCR ) THEN -C -C Discrete-time case with R not factored. Compute R + B'XB. -C - IF ( LUPLOU ) THEN -C - DO 10 J = 1, M - CALL DGEMV( 'No transpose', J, N, ONE, F, LDF, B(1,J), - $ 1, ONE, R(1,J), 1 ) - 10 CONTINUE -C - ELSE -C - DO 20 J = 1, M - CALL DGEMV( 'Transpose', N, J, ONE, B, LDB, F(J,1), - $ LDF, ONE, R(J,1), LDR ) - 20 CONTINUE -C - END IF - END IF -C -C Compute the 1-norm of the matrix R or R + B'XB. -C Workspace: need M. -C - RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - WRKOPT = MAX( WRKOPT, M ) - END IF -C - IF ( DISCR ) THEN -C -C For discrete-time case, postmultiply B'X by A. -C Workspace: need N. -C - DO 30 I = 1, M - CALL DCOPY( N, F(I,1), LDF, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, A, LDA, DWORK, 1, ZERO, - $ F(I,1), LDF ) - 30 CONTINUE -C - WRKOPT = MAX( WRKOPT, N ) - END IF -C - IF( WITHL ) THEN -C -C Add L'. -C - DO 50 I = 1, M -C - DO 40 J = 1, N - F(I,J) = F(I,J) + L(J,I) - 40 CONTINUE -C - 50 CONTINUE -C - END IF -C -C Solve the matrix equation. -C - IF ( LFACTA ) THEN -C -C Case 1: Matrix R is given in a factored form. -C - IF ( LFACTD ) THEN -C -C Use QR factorization of D. -C Workspace: need min(P,M) + M, -C prefer min(P,M) + M*NB. -C - ITAU = 1 - JWORK = ITAU + MIN( P, M ) - CALL DGEQRF( P, M, R, LDR, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Make positive the diagonal elements of the triangular -C factor. Construct the strictly lower triangle, if requested. -C - DO 70 I = 1, M - IF ( R(I,I).LT.ZERO ) THEN -C - DO 60 J = I, M - R(I,J) = -R(I,J) - 60 CONTINUE -C - END IF - IF ( .NOT.LUPLOU ) - $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) - 70 CONTINUE -C - IF ( P.LT.M ) THEN - CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) - IF ( .NOT.DISCR ) THEN - DWORK(2) = ZERO - INFO = M + 1 - RETURN - END IF - END IF - END IF -C - JW = 1 - IF ( DISCR ) THEN -C -C Discrete-time case. Update the factorization for B'XB. -C Try first the Cholesky factorization of X, saving the -C diagonal of X, in order to recover it, if X is not positive -C definite. In the later case, use spectral factorization. -C Workspace: need N. -C Define JW = 1 for Cholesky factorization of X, -C JW = N+3 for spectral factorization of X. -C - CALL DCOPY( N, X, LDX+1, DWORK, 1 ) - CALL DPOTRF( 'Upper', N, X, LDX, IFAIL ) - IF ( IFAIL.EQ.0 ) THEN -C -C Use Cholesky factorization of X to compute chol(X)*B. -C - OUFACT(2) = 1 - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non unit', - $ N, M, ONE, X, LDX, B, LDB ) - ELSE -C -C Use spectral factorization of X, X = UVU'. -C Workspace: need 4*N+1, -C prefer N*(NB+2)+N+2. -C - JW = N + 3 - OUFACT(2) = 2 - CALL DCOPY( N, DWORK, 1, X, LDX+1 ) - CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK(3), - $ DWORK(JW), LDWORK-JW+1, IFAIL ) - IF ( IFAIL.GT.0 ) THEN - INFO = M + 2 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) - TEMP = ABS( DWORK(N+2) )*EPS -C -C Count the negligible eigenvalues and compute sqrt(V)U'B. -C Workspace: need 2*N+2. -C - JZ = 0 -C - 80 CONTINUE - IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN - JZ = JZ + 1 - IF ( JZ.LT.N) GO TO 80 - END IF -C - DO 90 J = 1, M - CALL DCOPY( N, B(1,J), 1, DWORK(JW), 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, X, LDX, DWORK(JW), - $ 1, ZERO, B(1,J), 1 ) - 90 CONTINUE -C - DO 100 I = JZ + 1, N - CALL DSCAL( M, SQRT( ABS( DWORK(I+2) ) ), B(I,1), LDB - $ ) - 100 CONTINUE -C - IF ( JZ.GT.0 ) - $ CALL DLASET( 'Full', JZ, M, ZERO, ZERO, B, LDB ) - END IF -C -C Update the triangular factorization. -C - IF ( .NOT.LUPLOU ) THEN -C -C For efficiency, use the transposed of the lower triangle. -C - DO 110 I = 2, M - CALL DCOPY( I-1, R(I,1), LDR, R(1,I), 1 ) - 110 CONTINUE -C - END IF -C -C Workspace: need JW+2*M-1. -C - CALL MB04KD( 'Full', M, 0, N, R, LDR, B, LDB, DUMMY, N, - $ DUMMY, M, DWORK(JW), DWORK(JW+N) ) - WRKOPT = MAX( WRKOPT, JW + 2*M - 1 ) -C -C Make positive the diagonal elements of the triangular -C factor. -C - DO 130 I = 1, M - IF ( R(I,I).LT.ZERO ) THEN -C - DO 120 J = I, M - R(I,J) = -R(I,J) - 120 CONTINUE -C - END IF - 130 CONTINUE -C - IF ( .NOT.LUPLOU ) THEN -C -C Construct the lower triangle. -C - DO 140 I = 2, M - CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) - 140 CONTINUE -C - END IF - END IF -C -C Compute the condition number of the coefficient matrix. -C - IF ( .NOT.LFACTU ) THEN -C -C Workspace: need JW+3*M-1. -C - CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, - $ DWORK(JW), IWORK, IFAIL ) - OUFACT(1) = 1 - WRKOPT = MAX( WRKOPT, JW + 3*M - 1 ) - ELSE -C -C Workspace: need 2*M. -C - CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, - $ IWORK, INFO ) - OUFACT(1) = 2 - WRKOPT = MAX( WRKOPT, 2*M ) - END IF - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF -C - ELSE -C -C Case 2: Matrix R is given in an unfactored form. -C -C Save the given triangle of R or R + B'XB in the other -C strict triangle and the diagonal in the workspace, and try -C Cholesky factorization. -C Workspace: need M. -C - CALL DCOPY( M, R, LDR+1, DWORK, 1 ) - IF( LUPLOU ) THEN -C - DO 150 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 150 CONTINUE -C - ELSE -C - DO 160 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 160 CONTINUE -C - END IF - CALL DPOTRF( UPLO, M, R, LDR, INFO ) - OUFACT(1) = 1 - IF( INFO.EQ.0 ) THEN -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 3*M. -C - CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, - $ INFO ) -C -C Return if the matrix is singular to working precision. -C - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, 3*M ) - ELSE -C -C Use UdU' or LdL' factorization, first restoring the saved -C triangle. -C - CALL DCOPY( M, DWORK, 1, R, LDR+1 ) - IF( LUPLOU ) THEN -C - DO 170 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) - 170 CONTINUE -C - ELSE -C - DO 180 J = 2, M - CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) - 180 CONTINUE -C - END IF -C -C Workspace: need 1, -C prefer M*NB. -C - CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) - OUFACT(1) = 2 - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Compute the reciprocal of the condition number of R. -C Workspace: need 2*M. -C - CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, - $ IWORK, INFO ) -C -C Return if the matrix is singular to working precision. -C - DWORK(2) = RCOND - IF( RCOND.LT.EPS ) THEN - INFO = M + 1 - RETURN - END IF - END IF - END IF -C - IF (OUFACT(1).EQ.1 ) THEN -C -C Solve the positive definite linear system. -C - CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, INFO ) - ELSE -C -C Solve the indefinite linear system. -C - CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, INFO ) - END IF -C -C Set the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB02ND *** - END diff --git a/slycot/src/SB02OD.f b/slycot/src/SB02OD.f deleted file mode 100644 index 7408ba39..00000000 --- a/slycot/src/SB02OD.f +++ /dev/null @@ -1,856 +0,0 @@ - SUBROUTINE SB02OD( DICO, JOBB, FACT, UPLO, JOBL, SORT, N, M, P, A, - $ LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, RCOND, X, - $ LDX, ALFAR, ALFAI, BETA, S, LDS, T, LDT, U, - $ LDU, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + A'X + XA - (L+XB)R (L+XB)' = 0 (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C X = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q (2) -C -C where A, B, Q, R, and L are N-by-N, N-by-M, N-by-N, M-by-M and -C N-by-M matrices, respectively, such that Q = C'C, R = D'D and -C L = C'D; X is an N-by-N symmetric matrix. -C The routine also returns the computed values of the closed-loop -C spectrum of the system, i.e., the stable eigenvalues lambda(1), -C ..., lambda(N) of the corresponding Hamiltonian or symplectic -C pencil, in the continuous-time case or discrete-time case, -C respectively. -C -1 -C Optionally, matrix G = BR B' may be given instead of B and R. -C Other options include the case with Q and/or R given in a -C factored form, Q = C'C, R = D'D, and with L a zero matrix. -C -C The routine uses the method of deflating subspaces, based on -C reordering the eigenvalues in a generalized Schur matrix pair. -C A standard eigenproblem is solved in the continuous-time case -C if G is given. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved as -C follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C JOBB CHARACTER*1 -C Specifies whether or not the matrix G is given, instead -C of the matrices B and R, as follows: -C = 'B': B and R are given; -C = 'G': G is given. -C -C FACT CHARACTER*1 -C Specifies whether or not the matrices Q and/or R (if -C JOBB = 'B') are factored, as follows: -C = 'N': Not factored, Q and R are given; -C = 'C': C is given, and Q = C'C; -C = 'D': D is given, and R = D'D; -C = 'B': Both factors C and D are given, Q = C'C, R = D'D. -C -C UPLO CHARACTER*1 -C If JOBB = 'G', or FACT = 'N', specifies which triangle of -C the matrices G and Q (if FACT = 'N'), or Q and R (if -C JOBB = 'B'), is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. -C SLICOT Library routine SB02MT should be called just before -C SB02OD, for obtaining the results when JOBB = 'G' and -C JOBL = 'N'. -C -C SORT CHARACTER*1 -C Specifies which eigenvalues should be obtained in the top -C of the generalized Schur form, as follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the matrices -C A, Q, and X, and the number of rows of the matrices B -C and L. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. If JOBB = 'B', M is the -C order of the matrix R, and the number of columns of the -C matrix B. M >= 0. -C M is not used if JOBB = 'G'. -C -C P (input) INTEGER -C The number of system outputs. If FACT = 'C' or 'D' or 'B', -C P is the number of rows of the matrices C and/or D. -C P >= 0. -C Otherwise, P is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,*) -C If JOBB = 'B', the leading N-by-M part of this array must -C contain the input matrix B of the system. -C If JOBB = 'G', the leading N-by-N upper triangular part -C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') -C of this array must contain the upper triangular part or -C lower triangular part, respectively, of the matrix -C -1 -C G = BR B'. The stricly lower triangular part (if -C UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If FACT = 'N' or 'D', the leading N-by-N upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C state weighting matrix Q. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If JOBB = 'B', the triangular part of this array defined -C by UPLO is modified internally, but is restored on exit. -C If FACT = 'C' or 'B', the leading P-by-N part of this -C array must contain the output matrix C of the system. -C If JOBB = 'B', this part is modified internally, but is -C restored on exit. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if FACT = 'N' or 'D', -C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. -C -C R (input) DOUBLE PRECISION array, dimension (LDR,M) -C If FACT = 'N' or 'C', the leading M-by-M upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C input weighting matrix R. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C The triangular part of this array defined by UPLO is -C modified internally, but is restored on exit. -C If FACT = 'D' or 'B', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. This part is modified internally, but is restored -C on exit. -C If JOBB = 'G', this array is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; -C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; -C LDR >= 1 if JOBB = 'G'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,M) -C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of -C this array must contain the cross weighting matrix L. -C This part is modified internally, but is restored on exit. -C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; -C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. -C -C RCOND (output) DOUBLE PRECISION -C An estimate of the reciprocal of the condition number (in -C the 1-norm) of the N-th order system of algebraic -C equations from which the solution matrix X is obtained. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the -C solution matrix X of the problem. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) -C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) -C BETA (output) DOUBLE PRECISION array, dimension (2*N) -C The generalized eigenvalues of the 2N-by-2N matrix pair, -C ordered as specified by SORT (if INFO = 0). For instance, -C if SORT = 'S', the leading N elements of these arrays -C contain the closed-loop spectrum of the system matrix -C A - BF, where F is the optimal feedback matrix computed -C based on the solution matrix X. Specifically, -C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for -C k = 1,2,...,N. -C If DICO = 'C' and JOBB = 'G', the elements of BETA are -C set to 1. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,*) -C The leading 2N-by-2N part of this array contains the -C ordered real Schur form S of the first matrix in the -C reduced matrix pencil associated to the optimal problem, -C or of the corresponding Hamiltonian matrix, if DICO = 'C' -C and JOBB = 'G'. That is, -C -C (S S ) -C ( 11 12) -C S = ( ), -C (0 S ) -C ( 22) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C Array S must have 2*N+M columns if JOBB = 'B', and 2*N -C columns, otherwise. -C -C LDS INTEGER -C The leading dimension of array S. -C LDS >= MAX(1,2*N+M) if JOBB = 'B', -C LDS >= MAX(1,2*N) if JOBB = 'G'. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) -C If DICO = 'D' or JOBB = 'B', the leading 2N-by-2N part of -C this array contains the ordered upper triangular form T of -C the second matrix in the reduced matrix pencil associated -C to the optimal problem. That is, -C -C (T T ) -C ( 11 12) -C T = ( ), -C (0 T ) -C ( 22) -C -C where T , T and T are N-by-N matrices. -C 11 12 22 -C If DICO = 'C' and JOBB = 'G' this array is not referenced. -C -C LDT INTEGER -C The leading dimension of array T. -C LDT >= MAX(1,2*N+M) if JOBB = 'B', -C LDT >= MAX(1,2*N) if JOBB = 'G' and DICO = 'D', -C LDT >= 1 if JOBB = 'G' and DICO = 'C'. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) -C The leading 2N-by-2N part of this array contains the right -C transformation matrix U which reduces the 2N-by-2N matrix -C pencil to the ordered generalized real Schur form (S,T), -C or the Hamiltonian matrix to the ordered real Schur -C form S, if DICO = 'C' and JOBB = 'G'. That is, -C -C (U U ) -C ( 11 12) -C U = ( ), -C (U U ) -C ( 21 22) -C -C where U , U , U and U are N-by-N matrices. -C 11 12 21 22 -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,2*N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the original matrix pencil, specifically of the triangular -C factor obtained during the reduction process. If the user -C sets TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then a default tolerance, defined by -C TOLDEF = EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not referenced if JOBB = 'G'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,M,2*N) if JOBB = 'B', -C LIWORK >= MAX(1,2*N) if JOBB = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the -C reciprocal of the condition number of the M-by-M lower -C triangular matrix obtained after compressing the matrix -C pencil of order 2N+M to obtain a pencil of order 2N. -C If INFO = 0 or INFO = 6, DWORK(3) returns the scaling -C factor used internally, which should multiply the -C submatrix Y2 to recover X from the first N columns of U -C (see METHOD). -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(3,6*N), if JOBB = 'G', -C DICO = 'C'; -C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G', -C DICO = 'D'; -C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the computed extended matrix pencil is singular, -C possibly due to rounding errors; -C = 2: if the QZ (or QR) algorithm failed; -C = 3: if reordering of the (generalized) eigenvalues -C failed; -C = 4: if after reordering, roundoff changed values of -C some complex eigenvalues so that leading eigenvalues -C in the (generalized) Schur form no longer satisfy -C the stability condition; this could also be caused -C due to scaling; -C = 5: if the computed dimension of the solution does not -C equal N; -C = 6: if a singular matrix was encountered during the -C computation of the solution matrix X. -C -C METHOD -C -C The routine uses a variant of the method of deflating subspaces -C proposed by van Dooren [1]. See also [2], [3]. -C It is assumed that (A,B) is stabilizable and (C,A) is detectable. -C Under these assumptions the algebraic Riccati equation is known to -C have a unique non-negative definite solution. -C The first step in the method of deflating subspaces is to form the -C extended Hamiltonian matrices, dimension 2N + M given by -C -C discrete-time continuous-time -C -C |A 0 B| |I 0 0| |A 0 B| |I 0 0| -C |Q -I L| - z |0 -A' 0|, |Q A' L| - s |0 -I 0|. -C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| -C -C Next, these pencils are compressed to a form (see [1]) -C -C lambda x A - B . -C f f -C -C This generalized eigenvalue problem is then solved using the QZ -C algorithm and the stable deflating subspace Ys is determined. -C If [Y1'|Y2']' is a basis for Ys, then the required solution is -C -1 -C X = Y2 x Y1 . -C A standard eigenvalue problem is solved using the QR algorithm in -C the continuous-time case when G is given (DICO = 'C', JOBB = 'G'). -C -C REFERENCES -C -C [1] Van Dooren, P. -C A Generalized Eigenvalue Approach for Solving Riccati -C Equations. -C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. -C -C [2] Mehrmann, V. -C The Autonomous Linear Quadratic Control Problem. Theory and -C Numerical Solution. -C Lect. Notes in Control and Information Sciences, vol. 163, -C Springer-Verlag, Berlin, 1991. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C This routine is particularly suited for systems where the matrix R -C is ill-conditioned. Internal scaling is used. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equations set SORT = 'S'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying SORT = 'U'. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CD by T.G.J. Beelen, Philips, -C Eindhoven, Holland. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, June 2002, -C December 2002, January 2005. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, THREE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOBB, JOBL, SORT, UPLO - INTEGER INFO, LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, - $ LDWORK, LDX, M, N, P - DOUBLE PRECISION RCOND, TOL -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), - $ DWORK(*), L(LDL,*), Q(LDQ,*), R(LDR,*), - $ S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) -C .. Local Scalars .. - CHARACTER QTYPE, RTYPE - LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBL, - $ LJOBLN, LSCAL, LSCL, LSORT, LUPLO - INTEGER I, INFO1, J, LDW, MP, NDIM, NN, NNM, NP, NP1, - $ WRKOPT - DOUBLE PRECISION QSCAL, RCONDL, RNORM, RSCAL, SCALE, UNORM -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME, SB02MR, SB02MV, SB02OU, SB02OV, SB02OW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MV, - $ SB02OU, SB02OV, SB02OW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, - $ DGGES, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, - $ SB02OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBB = LSAME( JOBB, 'B' ) - LFACN = LSAME( FACT, 'N' ) - LFACQ = LSAME( FACT, 'C' ) - LFACR = LSAME( FACT, 'D' ) - LFACB = LSAME( FACT, 'B' ) - LUPLO = LSAME( UPLO, 'U' ) - LSORT = LSAME( SORT, 'S' ) -C - NN = 2*N - IF ( LJOBB ) THEN - LJOBL = LSAME( JOBL, 'Z' ) - LJOBLN = LSAME( JOBL, 'N' ) - NNM = NN + M - LDW = MAX( NNM, 3*M ) - ELSE - NNM = NN - LDW = 1 - END IF - NP1 = N + 1 -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB - $ .AND. .NOT.LFACN ) THEN - INFO = -3 - ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) - $ INFO = -4 - END IF - IF( INFO.EQ.0 .AND. LJOBB ) THEN - IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) - $ INFO = -5 - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN - INFO = -6 - ELSE IF( N.LT.0 ) THEN - INFO = -7 - ELSE IF( LJOBB ) THEN - IF( M.LT.0 ) - $ INFO = -8 - END IF - END IF - IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN - IF( P.LT.0 ) - $ INFO = -9 - END IF - IF( INFO.EQ.0 ) THEN - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN - INFO = -15 - ELSE IF( LDR.LT.1 ) THEN - INFO = -17 - ELSE IF( LDL.LT.1 ) THEN - INFO = -19 - ELSE IF( LJOBB ) THEN - IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. - $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN - INFO = -17 - ELSE IF( LJOBLN .AND. LDL.LT.N ) THEN - INFO = -19 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN - INFO = -27 - ELSE IF( LDT.LT.1 ) THEN - INFO = -29 - ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN - INFO = -31 - ELSE IF( LDWORK.LT.MAX( 3, 6*N ) ) THEN - INFO = -35 - ELSE IF( DISCR .OR. LJOBB ) THEN - IF( LDT.LT.NNM ) THEN - INFO = -29 - ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN - INFO = -35 - END IF - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - RCOND = ONE - DWORK(1) = THREE - DWORK(3) = ONE - RETURN - END IF -C -C Always scale the matrix pencil. -C - LSCAL = .TRUE. -C -C Start computations. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( LSCAL .AND. LJOBB ) THEN -C -C Scale the matrices Q, R, and L so that -C norm(Q) + norm(R) + norm(L) = 1, -C using the 1-norm. If Q and/or R are factored, the norms of -C the factors are used. -C Workspace: need max(N,M), if FACT = 'N'; -C N, if FACT = 'D'; -C M, if FACT = 'C'. -C - IF ( LFACN .OR. LFACR ) THEN - SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - QTYPE = UPLO - NP = N - ELSE - SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) - QTYPE = 'G' - NP = P - END IF -C - IF ( LFACN .OR. LFACQ ) THEN - RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - RTYPE = UPLO - MP = M - ELSE - RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) - RTYPE = 'G' - MP = P - END IF - SCALE = SCALE + RNORM -C - IF ( LJOBLN ) - $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) - IF ( SCALE.EQ.ZERO ) - $ SCALE = ONE -C - IF ( LFACN .OR. LFACR ) THEN - QSCAL = SCALE - ELSE - QSCAL = SQRT( SCALE ) - END IF -C - IF ( LFACN .OR. LFACQ ) THEN - RSCAL = SCALE - ELSE - RSCAL = SQRT( SCALE ) - END IF -C - CALL DLASCL( QTYPE, 0, 0, QSCAL, ONE, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, RSCAL, ONE, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) - END IF -C -C Construct the extended matrix pair. -C -C Workspace: need 1, if JOBB = 'G', -C max(1,2*N+M,3*M), if JOBB = 'B'; -C prefer larger. -C - CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, - $ 'Identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, - $ LDR, L, LDL, U, 1, S, LDS, T, LDT, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C - IF ( LSCAL .AND. LJOBB ) THEN -C -C Undo scaling of the data arrays. -C - CALL DLASCL( QTYPE, 0, 0, ONE, QSCAL, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, ONE, RSCAL, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) - END IF -C - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = DWORK(1) - IF ( LJOBB ) RCONDL = DWORK(2) -C - IF ( LSCAL .AND. .NOT.LJOBB ) THEN -C -C This part of the code is used when G is given (JOBB = 'G'). -C A standard eigenproblem is solved in the continuous-time case. -C Scale the Hamiltonian matrix S, if DICO = 'C', or the -C symplectic pencil (S,T), if DICO = 'D', using the square roots -C of the norms of the matrices Q and G. -C Workspace: need N. -C - IF ( LFACN .OR. LFACR ) THEN - SCALE = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) - ELSE - SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) - END IF - RNORM = SQRT( DLANSY( '1-norm', UPLO, N, B, LDB, DWORK ) ) -C - LSCL = MIN( SCALE, RNORM ).GT.ZERO .AND. SCALE.NE.RNORM -C - IF( LSCL ) THEN - IF( DISCR ) THEN - CALL DLASCL( 'G', 0, 0, SCALE, RNORM, N, N, S(NP1,1), - $ LDS, INFO1 ) - CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, T(1,NP1), - $ LDT, INFO1 ) - ELSE - CALL DLASCL( 'G', 0, 0, SCALE, -RNORM, N, N, S(NP1,1), - $ LDS, INFO1 ) - CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, S(1,NP1), - $ LDS, INFO1 ) - CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, N, S(NP1,NP1), - $ LDS, INFO1 ) - END IF - ELSE - IF( .NOT.DISCR ) THEN - CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, NN, S(NP1,1), LDS, - $ INFO1 ) - END IF - END IF - ELSE - LSCL = .FALSE. - END IF -C -C Workspace: need max(7*(2*N+1)+16,16*N), -C if JOBB = 'B' or DICO = 'D'; -C 6*N, if JOBB = 'G' and DICO = 'C'; -C prefer larger. -C - IF ( DISCR ) THEN - IF ( LSORT ) THEN -C -C The natural tendency of the QZ algorithm to get the largest -C eigenvalues in the leading part of the matrix pair is -C exploited, by computing the unstable eigenvalues of the -C permuted matrix pair. -C - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, - $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) - CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) - CALL DSWAP( N, BETA (NP1), 1, BETA, 1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - ELSE - IF ( LJOBB ) THEN - IF ( LSORT ) THEN - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, - $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, - $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, - $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, - $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sort', SB02MV, NN, S, LDS, NDIM, - $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, - $ INFO1 ) - ELSE - CALL DGEES( 'Vectors', 'Sort', SB02MR, NN, S, LDS, NDIM, - $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, - $ INFO1 ) - END IF - DUM(1) = ONE - CALL DCOPY( NN, DUM, 0, BETA, 1 ) - END IF - END IF - IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN - INFO = 2 - ELSE IF ( INFO1.EQ.NN+2 ) THEN - INFO = 4 - ELSE IF ( INFO1.EQ.NN+3 ) THEN - INFO = 3 - ELSE IF ( NDIM.NE.N ) THEN - INFO = 5 - END IF - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Select submatrices U1 and U2 out of the array U which define the -C solution X = U2 x inv(U1). -C Since X = X' we may obtain X as the solution of the system of -C linear equations U1' x X = U2', where -C U1 = U(1:n, 1:n), -C U2 = U(n+1:2n, 1:n). -C Use the (2,1) block of S as a workspace for factoring U1. -C - DO 20 J = 1, N - CALL DCOPY( N, U(NP1,J), 1, X(J,1), LDX ) - 20 CONTINUE -C - CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) -C -C Check if U1 is singular. -C - UNORM = DLANGE( '1-norm', N, N, S(NP1,1), LDS, DWORK ) -C -C Solve the system U1' x X = U2'. -C - CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO1 ) - IF ( INFO1.NE.0 ) THEN - INFO = 6 - DWORK(3) = ONE - IF ( LSCAL ) THEN - IF ( LJOBB ) THEN - DWORK(3) = SCALE - ELSE IF ( LSCL ) THEN - DWORK(3) = SCALE / RNORM - END IF - END IF - RETURN - ELSE -C -C Estimate the reciprocal condition of U1. -C Workspace: need 3*N. -C - CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, DWORK, - $ IWORK(NP1), INFO ) -C - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN -C -C Nearly singular matrix. Set INFO for error return. -C - INFO = 6 - RETURN - END IF - WRKOPT = MAX( WRKOPT, 3*N ) - CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, X, LDX, - $ INFO1 ) -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) -C - IF ( LSCAL ) THEN -C -C Prepare to undo scaling for the solution X. -C - IF ( .NOT.LJOBB ) THEN - IF ( LSCL ) THEN - SCALE = SCALE / RNORM - ELSE - SCALE = ONE - END IF - END IF - DWORK(3) = SCALE - SCALE = HALF*SCALE - ELSE - DWORK(3) = ONE - SCALE = HALF - END IF -C -C Make sure the solution matrix X is symmetric. -C - DO 40 I = 1, N - CALL DAXPY( N-I+1, ONE, X(I,I), LDX, X(I,I), 1 ) - CALL DSCAL( N-I+1, SCALE, X(I,I), 1 ) - CALL DCOPY( N-I+1, X(I,I), 1, X(I,I), LDX ) - 40 CONTINUE - END IF -C - DWORK(1) = WRKOPT - IF ( LJOBB ) DWORK(2) = RCONDL -C - RETURN -C *** Last line of SB02OD *** - END diff --git a/slycot/src/SB02OU.f b/slycot/src/SB02OU.f deleted file mode 100644 index 530d202f..00000000 --- a/slycot/src/SB02OU.f +++ /dev/null @@ -1,83 +0,0 @@ - LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable generalized eigenvalues for solving the -C continuous-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. It is assumed that BETA <> 0 (regular case). -C -C METHOD -C -C The function value SB02OU is set to .TRUE. for an unstable -C eigenvalue and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. Executable Statements .. -C - SB02OU = ( ALPHAR.LT.ZERO .AND. BETA.LT.ZERO ) .OR. - $ ( ALPHAR.GT.ZERO .AND. BETA.GT.ZERO ) -C - RETURN -C *** Last line of SB02OU *** - END diff --git a/slycot/src/SB02OV.f b/slycot/src/SB02OV.f deleted file mode 100644 index db114ae9..00000000 --- a/slycot/src/SB02OV.f +++ /dev/null @@ -1,88 +0,0 @@ - LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the unstable generalized eigenvalues for solving the -C discrete-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. -C -C METHOD -C -C The function value SB02OV is set to .TRUE. for an unstable -C eigenvalue (i.e., with modulus greater than or equal to one) and -C to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - SB02OV = DLAPY2( ALPHAR, ALPHAI ).GE.ABS( BETA ) -C - RETURN -C *** Last line of SB02OV *** - END diff --git a/slycot/src/SB02OW.f b/slycot/src/SB02OW.f deleted file mode 100644 index 11de0b23..00000000 --- a/slycot/src/SB02OW.f +++ /dev/null @@ -1,83 +0,0 @@ - LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable generalized eigenvalues for solving the -C continuous-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. It is assumed that BETA <> 0 (regular case). -C -C METHOD -C -C The function value SB02OW is set to .TRUE. for a stable eigenvalue -C and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. Executable Statements .. -C - SB02OW = ( ALPHAR.LT.ZERO .AND. BETA.GT.ZERO ) .OR. - $ ( ALPHAR.GT.ZERO .AND. BETA.LT.ZERO ) -C - RETURN -C *** Last line of SB02OW *** - END diff --git a/slycot/src/SB02OX.f b/slycot/src/SB02OX.f deleted file mode 100644 index b3f90b53..00000000 --- a/slycot/src/SB02OX.f +++ /dev/null @@ -1,87 +0,0 @@ - LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To select the stable generalized eigenvalues for solving the -C discrete-time algebraic Riccati equation. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ALPHAR (input) DOUBLE PRECISION -C The real part of the numerator of the current eigenvalue -C considered. -C -C ALPHAI (input) DOUBLE PRECISION -C The imaginary part of the numerator of the current -C eigenvalue considered. -C -C BETA (input) DOUBLE PRECISION -C The (real) denominator of the current eigenvalue -C considered. -C -C METHOD -C -C The function value SB02OX is set to .TRUE. for a stable eigenvalue -C (i.e., with modulus less than one) and to .FALSE., otherwise. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHAR, ALPHAI, BETA -C .. External Functions .. - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2 -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - SB02OX = DLAPY2( ALPHAR, ALPHAI ).LT.ABS( BETA ) -C - RETURN -C *** Last line of SB02OX *** - END diff --git a/slycot/src/SB02OY.f b/slycot/src/SB02OY.f deleted file mode 100644 index 367befee..00000000 --- a/slycot/src/SB02OY.f +++ /dev/null @@ -1,791 +0,0 @@ - SUBROUTINE SB02OY( TYPE, DICO, JOBB, FACT, UPLO, JOBL, JOBE, N, M, - $ P, A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, E, - $ LDE, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the extended matrix pairs for the computation of the -C solution of the algebraic matrix Riccati equations arising in the -C problems of optimal control, both discrete and continuous-time, -C and of spectral factorization, both discrete and continuous-time. -C These matrix pairs, of dimension 2N + M, are given by -C -C discrete-time continuous-time -C -C |A 0 B| |E 0 0| |A 0 B| |E 0 0| -C |Q -E' L| - z |0 -A' 0|, |Q A' L| - s |0 -E' 0|. (1) -C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| -C -C After construction, these pencils are compressed to a form -C (see [1]) -C -C lambda x A - B , -C f f -C -C where A and B are 2N-by-2N matrices. -C f f -C -1 -C Optionally, matrix G = BR B' may be given instead of B and R; -C then, for L = 0, 2N-by-2N matrix pairs are directly constructed as -C -C discrete-time continuous-time -C -C |A 0 | |E G | |A -G | |E 0 | -C | | - z | |, | | - s | |. (2) -C |Q -E'| |0 -A'| |Q A'| |0 -E'| -C -C Similar pairs are obtained for non-zero L, if SLICOT Library -C routine SB02MT is called before SB02OY. -C Other options include the case with E identity matrix, L a zero -C matrix, or Q and/or R given in a factored form, Q = C'C, R = D'D. -C For spectral factorization problems, there are minor differences -C (e.g., B is replaced by C'). -C The second matrix in (2) is not constructed in the continuous-time -C case if E is specified as being an identity matrix. -C -C ARGUMENTS -C -C Mode Parameters -C -C TYPE CHARACTER*1 -C Specifies the type of problem to be addressed as follows: -C = 'O': Optimal control problem; -C = 'S': Spectral factorization problem. -C -C DICO CHARACTER*1 -C Specifies the type of linear system considered as follows: -C = 'C': Continuous-time system; -C = 'D': Discrete-time system. -C -C JOBB CHARACTER*1 -C Specifies whether or not the matrix G is given, instead -C of the matrices B and R, as follows: -C = 'B': B and R are given; -C = 'G': G is given. -C For JOBB = 'G', a 2N-by-2N matrix pair is directly -C obtained assuming L = 0 (see the description of JOBL). -C -C FACT CHARACTER*1 -C Specifies whether or not the matrices Q and/or R (if -C JOBB = 'B') are factored, as follows: -C = 'N': Not factored, Q and R are given; -C = 'C': C is given, and Q = C'C; -C = 'D': D is given, and R = D'D (if TYPE = 'O'), or -C R = D + D' (if TYPE = 'S'); -C = 'B': Both factors C and D are given, Q = C'C, R = D'D -C (or R = D + D'). -C -C UPLO CHARACTER*1 -C If JOBB = 'G', or FACT = 'N', specifies which triangle of -C the matrices G and Q (if FACT = 'N'), or Q and R (if -C JOBB = 'B'), is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. -C Using SLICOT Library routine SB02MT to compute the -C corresponding A and Q in this case, before calling SB02OY, -C enables to obtain 2N-by-2N matrix pairs directly. -C -C JOBE CHARACTER*1 -C Specifies whether or not the matrix E is identity, as -C follows: -C = 'I': E is the identity matrix; -C = 'N': E is a general matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, and E, and the number -C of rows of the matrices B and L. N >= 0. -C -C M (input) INTEGER -C If JOBB = 'B', M is the order of the matrix R, and the -C number of columns of the matrix B. M >= 0. -C M is not used if JOBB = 'G'. -C -C P (input) INTEGER -C If FACT = 'C' or 'D' or 'B', or if TYPE = 'S', P is the -C number of rows of the matrix C and/or D, respectively. -C P >= 0, and if JOBB = 'B' and TYPE = 'S', then P = M. -C Otherwise, P is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,*) -C If JOBB = 'B', the leading N-by-M part of this array must -C contain the input matrix B of the system. -C If JOBB = 'G', the leading N-by-N upper triangular part -C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') -C of this array must contain the upper triangular part or -C lower triangular part, respectively, of the matrix -C -1 -C G = BR B'. The stricly lower triangular part (if -C UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If FACT = 'N' or 'D', the leading N-by-N upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C output weighting matrix Q. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'C' or 'B', the leading P-by-N part of this -C array must contain the output matrix C of the system. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if FACT = 'N' or 'D', -C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. -C -C R (input) DOUBLE PRECISION array, dimension (LDR,M) -C If FACT = 'N' or 'C', the leading M-by-M upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C input weighting matrix R. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'D' or 'B', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. -C If JOBB = 'G', this array is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; -C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; -C LDR >= 1 if JOBB = 'G'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,M) -C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of -C this array must contain the cross weighting matrix L. -C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N'; -C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C If JOBE = 'N', the leading N-by-N part of this array must -C contain the matrix E of the descriptor system. -C If JOBE = 'I', E is taken as identity and this array is -C not referenced. -C -C LDE INTEGER -C The leading dimension of array E. -C LDE >= MAX(1,N) if JOBE = 'N'; -C LDE >= 1 if JOBE = 'I'. -C -C AF (output) DOUBLE PRECISION array, dimension (LDAF,*) -C The leading 2N-by-2N part of this array contains the -C matrix A in the matrix pencil. -C f -C Array AF must have 2*N+M columns if JOBB = 'B', and 2*N -C columns, otherwise. -C -C LDAF INTEGER -C The leading dimension of array AF. -C LDAF >= MAX(1,2*N+M) if JOBB = 'B', -C LDAF >= MAX(1,2*N) if JOBB = 'G'. -C -C BF (output) DOUBLE PRECISION array, dimension (LDBF,2*N) -C If DICO = 'D' or JOBB = 'B' or JOBE = 'N', the leading -C 2N-by-2N part of this array contains the matrix B in the -C f -C matrix pencil. -C The last M zero columns are never constructed. -C If DICO = 'C' and JOBB = 'G' and JOBE = 'I', this array -C is not referenced. -C -C LDBF INTEGER -C The leading dimension of array BF. -C LDBF >= MAX(1,2*N+M) if JOBB = 'B', -C LDBF >= MAX(1,2*N) if JOBB = 'G' and ( DICO = 'D' or -C JOBE = 'N' ), -C LDBF >= 1 if JOBB = 'G' and ( DICO = 'C' and -C JOBE = 'I' ). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the original matrix pencil, specifically of the triangular -C factor obtained during the reduction process. If the user -C sets TOL > 0, then the given value of TOL is used as a -C lower bound for the reciprocal condition number of that -C matrix; a matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. If the user -C sets TOL <= 0, then a default tolerance, defined by -C TOLDEF = EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not referenced if JOBB = 'G'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= M if JOBB = 'B', -C LIWORK >= 1 if JOBB = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If JOBB = 'B', DWORK(2) returns the reciprocal -C of the condition number of the M-by-M lower triangular -C matrix obtained after compression. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 1 if JOBB = 'G', -C LDWORK >= MAX(1,2*N + M,3*M) if JOBB = 'B'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the computed extended matrix pencil is singular, -C possibly due to rounding errors. -C -C METHOD -C -C The extended matrix pairs are constructed, taking various options -C into account. If JOBB = 'B', the problem order is reduced from -C 2N+M to 2N (see [1]). -C -C REFERENCES -C -C [1] Van Dooren, P. -C A Generalized Eigenvalue Approach for Solving Riccati -C Equations. -C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. -C -C [2] Mehrmann, V. -C The Autonomous Linear Quadratic Control Problem. Theory and -C Numerical Solution. -C Lect. Notes in Control and Information Sciences, vol. 163, -C Springer-Verlag, Berlin, 1991. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB02CY by T.G.J. Beelen, Philips, -C Eindhoven, Holland, M. Vanbegin, and P. Van Dooren, Philips -C Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOBB, JOBE, JOBL, TYPE, UPLO - INTEGER INFO, LDA, LDAF, LDB, LDBF, LDE, LDL, LDQ, LDR, - $ LDWORK, M, N, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), - $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBE, - $ LJOBL, LUPLO, OPTC - INTEGER I, ITAU, J, JWORK, N2, N2P1, NM, NNM, NP1, - $ WRKOPT - DOUBLE PRECISION RCOND, TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQLF, DLACPY, DLASET, DORMQL, DSYRK, - $ DTRCON, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - OPTC = LSAME( TYPE, 'O' ) - DISCR = LSAME( DICO, 'D' ) - LJOBB = LSAME( JOBB, 'B' ) - LFACN = LSAME( FACT, 'N' ) - LFACQ = LSAME( FACT, 'C' ) - LFACR = LSAME( FACT, 'D' ) - LFACB = LSAME( FACT, 'B' ) - LUPLO = LSAME( UPLO, 'U' ) - LJOBE = LSAME( JOBE, 'I' ) - N2 = N + N - IF ( LJOBB ) THEN - LJOBL = LSAME( JOBL, 'Z' ) - NM = N + M - NNM = N2 + M - ELSE - NM = N - NNM = N2 - END IF - NP1 = N + 1 - N2P1 = N2 + 1 -C -C Test the input scalar arguments. -C - IF( .NOT.OPTC .AND. .NOT.LSAME( TYPE, 'S' ) ) THEN - INFO = -1 - ELSE IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB - $ .AND. .NOT.LFACN ) THEN - INFO = -4 - ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) - $ INFO = -5 - ELSE IF( LJOBB ) THEN - IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'N' ) ) - $ INFO = -6 - ELSE IF( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'N' ) ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( LJOBB ) THEN - IF( M.LT.0 ) - $ INFO = -9 - ELSE IF( .NOT.LFACN .OR. .NOT.OPTC ) THEN - IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( LJOBB ) THEN - IF( .NOT.OPTC .AND. P.NE.M ) - $ INFO = -10 - END IF - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN - INFO = -16 - ELSE IF( LDR.LT.1 ) THEN - INFO = -18 - ELSE IF( LJOBB ) THEN - IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. - $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN - INFO = -18 - ELSE IF( ( .NOT.LJOBL .AND. LDL.LT.MAX( 1, N ) ) .OR. - $ ( LJOBL .AND. LDL.LT.1 ) ) THEN - INFO = -20 - END IF - END IF - IF( ( .NOT.LJOBE .AND. LDE.LT.MAX( 1, N ) ) .OR. - $ ( LJOBE .AND. LDE.LT.1 ) ) THEN - INFO = -22 - ELSE IF( LDAF.LT.MAX( 1, NNM ) ) THEN - INFO = -24 - ELSE IF( ( ( LJOBB .OR. DISCR .OR. .NOT.LJOBE ) .AND. - $ LDBF.LT.NNM ) .OR. ( LDBF.LT.1 ) ) THEN - INFO = -26 - ELSE IF( ( LJOBB .AND. LDWORK.LT.MAX( NNM, 3*M ) ) .OR. - $ LDWORK.LT.1 ) THEN - INFO = -30 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02OY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C -C Construct the extended matrices in AF and BF, by block-columns. -C - CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) -C - IF ( .NOT.LFACQ .AND. .NOT.LFACB ) THEN - CALL DLACPY( UPLO, N, N, Q, LDQ, AF(NP1,1), LDAF ) - IF ( LUPLO ) THEN -C -C Construct the lower triangle of Q. -C - DO 20 J = 1, N - 1 - CALL DCOPY( N-J, Q(J,J+1), LDQ, AF(NP1+J,J), 1 ) - 20 CONTINUE -C - ELSE -C -C Construct the upper triangle of Q. -C - DO 40 J = 2, N - CALL DCOPY( J-1, Q(J,1), LDQ, AF(NP1,J), 1 ) - 40 CONTINUE -C - END IF - ELSE - CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, Q, LDQ, ZERO, - $ AF(NP1,1), LDAF ) -C - DO 60 J = 2, N - CALL DCOPY( J-1, AF(NP1,J), 1, AF(N+J,1), LDAF ) - 60 CONTINUE -C - END IF -C - IF ( LJOBB ) THEN - IF ( LJOBL ) THEN - CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,1), LDAF ) - ELSE -C - DO 80 I = 1, N - CALL DCOPY( M, L(I,1), LDL, AF(N2P1,I), 1 ) - 80 CONTINUE -C - END IF - END IF -C - IF ( DISCR.OR.LJOBB ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, AF(1,NP1), LDAF ) - ELSE - IF ( LUPLO ) THEN -C -C Construct (1,2) block of AF using the upper triangle of G. -C - DO 140 J = 1, N -C - DO 100 I = 1, J - AF(I,N+J)= -B(I,J) - 100 CONTINUE -C - DO 120 I = J + 1, N - AF(I,N+J)= -B(J,I) - 120 CONTINUE -C - 140 CONTINUE -C - ELSE -C -C Construct (1,2) block of AF using the lower triangle of G. -C - DO 200 J = 1, N -C - DO 160 I = 1, J - 1 - AF(I,N+J)= -B(J,I) - 160 CONTINUE -C - DO 180 I = J, N - AF(I,N+J)= -B(I,J) - 180 CONTINUE -C - 200 CONTINUE -C - END IF - END IF -C - IF ( DISCR ) THEN - IF ( LJOBE ) THEN - CALL DLASET( 'Full', NM, N, ZERO, -ONE, AF(NP1,NP1), LDAF ) - ELSE -C - DO 240 J = 1, N -C - DO 220 I = 1, N - AF(N+I,N+J)= -E(J,I) - 220 CONTINUE -C - 240 CONTINUE -C - IF ( LJOBB ) - $ CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,NP1), - $ LDAF ) - END IF - ELSE -C - DO 280 J = 1, N -C - DO 260 I = 1, N - AF(N+I,N+J)= A(J,I) - 260 CONTINUE -C - 280 CONTINUE -C - IF ( LJOBB ) THEN - IF ( OPTC ) THEN -C - DO 300 J = 1, N - CALL DCOPY ( M, B(J,1), LDB, AF(N2P1,N+J), 1 ) - 300 CONTINUE -C - ELSE - CALL DLACPY( 'Full', P, N, Q, LDQ, AF(N2P1,NP1), LDAF ) - END IF - END IF - END IF -C - IF ( LJOBB ) THEN -C - IF ( OPTC ) THEN - CALL DLACPY( 'Full', N, M, B, LDB, AF(1,N2P1), LDAF ) - ELSE -C - DO 320 I = 1, P - CALL DCOPY( N, Q(I,1), LDQ, AF(1,N2+I), 1 ) - 320 CONTINUE -C - END IF -C - IF ( LJOBL ) THEN - CALL DLASET( 'Full', N, M, ZERO, ZERO, AF(NP1,N2P1), LDAF ) - ELSE - CALL DLACPY( 'Full', N, M, L, LDL, AF(NP1,N2P1), LDAF ) - END IF -C - IF ( .NOT.LFACR .AND. .NOT.LFACB ) THEN - CALL DLACPY( UPLO, M, M, R, LDR, AF(N2P1,N2P1), LDAF ) - IF ( LUPLO ) THEN -C -C Construct the lower triangle of R. -C - DO 340 J = 1, M - 1 - CALL DCOPY( M-J, R(J,J+1), LDR, AF(N2P1+J,N2+J), 1 ) - 340 CONTINUE -C - ELSE -C -C Construct the upper triangle of R. -C - DO 360 J = 2, M - CALL DCOPY( J-1, R(J,1), LDR, AF(N2P1,N2+J), 1 ) - 360 CONTINUE -C - END IF - ELSE IF ( OPTC ) THEN - CALL DSYRK( 'Upper', 'Transpose', M, P, ONE, R, LDR, ZERO, - $ AF(N2P1,N2P1), LDAF ) -C - DO 380 J = 2, M - CALL DCOPY( J-1, AF(N2P1,N2+J), 1, AF(N2+J,N2P1), LDAF ) - 380 CONTINUE -C - ELSE -C - DO 420 J = 1, M -C - DO 400 I = 1, P - AF(N2+I,N2+J) = R(I,J) + R(J,I) - 400 CONTINUE -C - 420 CONTINUE -C - END IF - END IF -C - IF ( .NOT.LJOBB .AND. .NOT.DISCR .AND. LJOBE ) - $ RETURN -C -C Construct the first two block columns of BF. -C - IF ( LJOBE ) THEN - CALL DLASET( 'Full', N+NM, N, ZERO, ONE, BF, LDBF ) - ELSE - CALL DLACPY( 'Full', N, N, E, LDE, BF, LDBF ) - CALL DLASET( 'Full', NM, N, ZERO, ZERO, BF(NP1,1), LDBF ) - END IF -C - IF ( .NOT.DISCR.OR.LJOBB ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, BF(1,NP1), LDBF ) - ELSE - IF ( LUPLO ) THEN -C -C Construct (1,2) block of BF using the upper triangle of G. -C - DO 480 J = 1, N -C - DO 440 I = 1, J - BF(I,N+J)= B(I,J) - 440 CONTINUE -C - DO 460 I = J + 1, N - BF(I,N+J)= B(J,I) - 460 CONTINUE -C - 480 CONTINUE -C - ELSE -C -C Construct (1,2) block of BF using the lower triangle of G. -C - DO 540 J = 1, N -C - DO 500 I = 1, J - 1 - BF(I,N+J)= B(J,I) - 500 CONTINUE -C - DO 520 I = J, N - BF(I,N+J)= B(I,J) - 520 CONTINUE -C - 540 CONTINUE -C - END IF - END IF -C - IF ( DISCR ) THEN -C - DO 580 J = 1, N -C - DO 560 I = 1, N - BF(N+I,N+J)= -A(J,I) - 560 CONTINUE -C - 580 CONTINUE -C - IF ( LJOBB ) THEN -C - IF ( OPTC ) THEN -C - DO 620 J = 1, N -C - DO 600 I = 1, M - BF(N2+I,N+J)= -B(J,I) - 600 CONTINUE -C - 620 CONTINUE -C - ELSE -C - DO 660 J = 1, N -C - DO 640 I = 1, P - BF(N2+I,N+J) = -Q(I,J) - 640 CONTINUE -C - 660 CONTINUE -C - END IF - END IF -C - ELSE - IF ( LJOBE ) THEN - CALL DLASET( 'Full', NM, N, ZERO, -ONE, BF(NP1,NP1), LDBF ) - ELSE -C - DO 700 J = 1, N -C - DO 680 I = 1, N - BF(N+I,N+J)= -E(J,I) - 680 CONTINUE -C - 700 CONTINUE -C - IF ( LJOBB ) - $ CALL DLASET( 'Full', M, N, ZERO, ZERO, BF(N2P1,NP1), - $ LDBF ) - END IF - END IF -C - IF ( .NOT.LJOBB ) - $ RETURN -C -C Compress the pencil lambda x BF - AF, using QL factorization. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Workspace: need 2*M; prefer M + M*NB. -C - ITAU = 1 - JWORK = ITAU + M - CALL DGEQLF( NNM, M, AF(1,N2P1), LDAF, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = DWORK(JWORK) -C -C Workspace: need 2*N+M; prefer M + 2*N*NB. -C - CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, - $ DWORK(ITAU), AF, LDAF, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, - $ DWORK(ITAU), BF, LDBF, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) -C -C Check the singularity of the L factor in the QL factorization: -C if singular, then the extended matrix pencil is also singular. -C Workspace 3*M. -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) - $ TOLDEF = DLAMCH( 'Epsilon' ) -C - CALL DTRCON( '1-norm', 'Lower', 'Non unit', M, AF(N2P1,N2P1), - $ LDAF, RCOND, DWORK, IWORK, INFO ) - WRKOPT = MAX( WRKOPT, 3*M ) -C - IF ( RCOND.LE.TOLDEF ) - $ INFO = 1 -C - DWORK(1) = WRKOPT - DWORK(2) = RCOND -C - RETURN -C *** Last line of SB02OY *** - END diff --git a/slycot/src/SB02PD.f b/slycot/src/SB02PD.f deleted file mode 100644 index fe63ddfc..00000000 --- a/slycot/src/SB02PD.f +++ /dev/null @@ -1,756 +0,0 @@ - SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, - $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real continuous-time matrix algebraic Riccati -C equation -C -C op(A)'*X + X*op(A) + Q - X*G*X = 0, -C -C where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T, -C Q = Q**T). The matrices A, G and Q are N-by-N and the solution X -C is an N-by-N symmetric matrix. -C -C An error bound on the solution and a condition estimate are also -C optionally provided. -C -C It is assumed that the matrices A, G and Q are such that the -C corresponding Hamiltonian matrix has N eigenvalues with negative -C real parts. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'A': Compute all: the solution, reciprocal condition -C number, and the error bound. -C -C TRANA CHARACTER*1 -C Specifies the option op(A): -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangles of G and Q are stored; -C = 'L': Lower triangles of G and Q are stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, Q, and X. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix G. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix G. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix Q. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix Q. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N -C part of this array contains the symmetric solution matrix -C X of the algebraic Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'A', the estimate of the reciprocal condition -C number of the Riccati equation. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'A', the estimated forward error bound for the -C solution X. If XTRUE is the true solution, FERR bounds the -C magnitude of the largest entry in (X - XTRUE) divided by -C the magnitude of the largest entry in X. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If JOB = 'A' and TRANA = 'N', WR and WI contain the real -C and imaginary parts, respectively, of the eigenvalues of -C the matrix A - G*X, i.e., the closed-loop system poles. -C If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the -C real and imaginary parts, respectively, of the eigenvalues -C of the matrix A - X*G, i.e., the closed-loop system poles. -C If JOB = 'X', these arrays are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= 2*N, if JOB = 'X'; -C LIWORK >= max(2*N,N*N), if JOB = 'A'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the -C optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1) -C and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the -C closed-loop system matrix, Ac = A - G*X (if TRANA = 'N') -C or Ac = A - X*G (if TRANA = 'T' or 'C'), and the -C orthogonal matrix which reduced Ac to real Schur form, -C respectively. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 4*N*N + 8*N + 1, if JOB = 'X'; -C LDWORK >= max( 4*N*N + 8*N, 6*N*N ) + 1, if JOB = 'A'. -C For good performance, LDWORK should be larger, e.g., -C LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB, if JOB = 'X', -C where NB is the optimal blocksize. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the Hamiltonian matrix has eigenvalues on the -C imaginary axis, so the solution and error bounds -C could not be computed; -C = 2: the iteration for the matrix sign function failed to -C converge after 50 iterations, but an approximate -C solution and error bounds (if JOB = 'A') have been -C computed; -C = 3: the system of linear equations for the solution is -C singular to working precision, so the solution and -C error bounds could not be computed; -C = 4: the matrix A-G*X (or A-X*G) cannot be reduced to -C Schur canonical form and condition number estimate -C and forward error estimate have not been computed. -C -C METHOD -C -C The Riccati equation is solved by the matrix sign function -C approach [1], [2], implementing a scaling which enhances the -C numerical stability [4]. -C -C REFERENCES -C -C [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H., -C and Stanley, K. -C The spectral decomposition of nonsymmetric matrices on -C distributed memory parallel computers. -C SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997. -C -C [2] Byers, R., He, C., and Mehrmann, V. -C The matrix sign function method and the computation of -C invariant subspaces. -C SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997. -C -C [3] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V., -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Technical -C University Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C -C The solution accuracy can be controlled by the output parameter -C FERR. -C -C FURTHER COMMENTS -C -C The condition number of the Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W + W*op(Ac), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), -C Pi(W) = inv(Omega(X*W*X)), -C -C and the matrix Ac (the closed-loop system matrix) is given by -C Ac = A - G*X, if TRANA = 'N', or -C Ac = A - X*G, if TRANA = 'T' or 'C'. -C -C The program estimates the quantities -C -C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [3]. -C -C CONTRIBUTOR -C -C P. Petkov, Tech. University of Sofia, March 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, continuous-time system, -C optimal control, optimal regulator. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER MAXIT - PARAMETER ( MAXIT = 50 ) - DOUBLE PRECISION ZERO, HALF, ONE, TWO, TEN - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, TEN = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), - $ Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL ALL, LOWER, NOTRNA - CHARACTER EQUED, LOUP - INTEGER I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2, - $ INI, IR, ISCL, ISV, IT, ITAU, ITER, IU, IWRK, - $ J, JI, LWAMAX, MINWRK, N2, SDIM - DOUBLE PRECISION CONV, GNORM2, EPS, HNORM, HINNRM, QNORM2, - $ SCALE, SEP, TEMP, TOL -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, ILAENV, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEQP3, DGESVX, DLACPY, DLASCL, - $ DLASET, DORMQR, DSCAL, DSWAP, DSYMM, DSYTRF, - $ DSYTRI, MA02AD, MA02ED, SB02QD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - ALL = LSAME( JOB, 'A' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) -C - INFO = 0 - IF( .NOT.ALL .AND. .NOT.LSAME( JOB, 'X' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) .AND. .NOT.NOTRNA ) THEN - INFO = -2 - ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE -C -C Compute workspace. -C - IF( ALL ) THEN - MINWRK = MAX( 4*N*N + 8*N + 1, 6*N*N ) - ELSE - MINWRK = 4*N*N + 8*N + 1 - END IF - IF( LDWORK.LT.MINWRK ) THEN - INFO = -19 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( ALL ) THEN - RCOND = ONE - FERR = ZERO - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Set tol. -C - EPS = DLAMCH( 'P' ) - TOL = TEN*DBLE( N )*EPS -C -C Compute the square-roots of the norms of the matrices Q and G . -C - QNORM2 = SQRT( DLANSY( '1', UPLO, N, Q, LDQ, DWORK ) ) - GNORM2 = SQRT( DLANSY( '1', UPLO, N, G, LDG, DWORK ) ) -C - N2 = 2*N -C -C Construct the lower (if UPLO = 'L') or upper (if UPLO = 'U') -C triangle of the symmetric block-permuted Hamiltonian matrix. -C During iteration, both the current iterate corresponding to the -C Hamiltonian matrix, and its inverse are needed. To reduce the -C workspace length, the transpose of the triangle specified by UPLO -C of the current iterate H is saved in the opposite triangle, -C suitably shifted with one column, and then the inverse of H -C overwrites H. The triangles of the saved iterate and its inverse -C are stored together in an 2*N-by-(2*N+1) matrix. For instance, if -C UPLO = 'U', then the upper triangle is built starting from the -C location 2*N+1 of the array DWORK, so that its transpose can be -C stored in the lower triangle of DWORK. -C Workspace: need 4*N*N, if UPLO = 'L'; -C 4*N*N + 2*N, if UPLO = 'U'. -C - IF ( LOWER ) THEN - INI = 0 - ISV = N2 - LOUP = 'U' -C - DO 40 J = 1, N - IJ = ( J - 1 )*N2 + J -C - DO 10 I = J, N - DWORK(IJ) = -Q(I,J) - IJ = IJ + 1 - 10 CONTINUE -C - IF( NOTRNA ) THEN -C - DO 20 I = 1, N - DWORK( IJ ) = -A( I, J ) - IJ = IJ + 1 - 20 CONTINUE -C - ELSE -C - DO 30 I = 1, N - DWORK( IJ ) = -A( J, I ) - IJ = IJ + 1 - 30 CONTINUE -C - END IF - 40 CONTINUE -C - DO 60 J = 1, N - IJ = ( N + J - 1 )*N2 + N + J -C - DO 50 I = J, N - DWORK( IJ ) = G( I, J ) - IJ = IJ + 1 - 50 CONTINUE -C - 60 CONTINUE -C - ELSE - INI = N2 - ISV = 0 - LOUP = 'L' -C - DO 80 J = 1, N - IJ = J*N2 + 1 -C - DO 70 I = 1, J - DWORK(IJ) = -Q(I,J) - IJ = IJ + 1 - 70 CONTINUE -C - 80 CONTINUE -C - DO 120 J = 1, N - IJ = ( N + J )*N2 + 1 -C - IF( NOTRNA ) THEN -C - DO 90 I = 1, N - DWORK( IJ ) = -A( J, I ) - IJ = IJ + 1 - 90 CONTINUE -C - ELSE -C - DO 100 I = 1, N - DWORK( IJ ) = -A( I, J ) - IJ = IJ + 1 - 100 CONTINUE -C - END IF -C - DO 110 I = 1, J - DWORK( IJ ) = G( I, J ) - IJ = IJ + 1 - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C -C Block-scaling. -C - ISCL = 0 - IF( QNORM2.GT.GNORM2 .AND. GNORM2.GT.ZERO ) THEN - CALL DLASCL( UPLO, 0, 0, QNORM2, GNORM2, N, N, DWORK( INI+1 ), - $ N2, INFO2 ) - CALL DLASCL( UPLO, 0, 0, GNORM2, QNORM2, N, N, - $ DWORK( N2*N+N+INI+1 ), N2, INFO2 ) - ISCL = 1 - END IF -C -C Workspace usage. -C - ITAU = N2*N2 - IWRK = ITAU + N2 -C - LWAMAX = N2*ILAENV( 1, 'DSYTRF', UPLO, N2, -1, -1, -1 ) -C -C Compute the matrix sign function. -C - DO 230 ITER = 1, MAXIT -C -C Save the transpose of the corresponding triangle of the -C current iterate in the free locations of the shifted opposite -C triangle. -C Workspace: need 4*N*N + 2*N. -C - IF( LOWER ) THEN -C - DO 130 I = 1, N2 - CALL DCOPY( I, DWORK( I ), N2, DWORK( I*N2+1 ), 1 ) - 130 CONTINUE -C - ELSE -C - DO 140 I = 1, N2 - CALL DCOPY( I, DWORK( I*N2+1 ), 1, DWORK( I ), N2 ) - 140 CONTINUE -C - END IF -C -C Store the norm of the Hamiltonian matrix. -C - HNORM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) -C -C Compute the inverse of the block-permuted Hamiltonian matrix. -C Workspace: need 4*N*N + 2*N + 1; -C prefer 4*N*N + 2*N + 2*N*NB. -C - CALL DSYTRF( UPLO, N2, DWORK( INI+1 ), N2, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C -C Workspace: need 4*N*N + 4*N. -C - CALL DSYTRI( UPLO, N2, DWORK( INI+1 ), N2, IWORK, - $ DWORK( IWRK+1 ), INFO2 ) -C -C Block-permutation of the inverse matrix. -C - IF( LOWER ) THEN -C - DO 160 J = 1, N - IJ2 = ( N + J - 1 )*N2 + N + J -C - DO 150 IJ1 = ( J - 1 )*N2 + J, ( J - 1 )*N2 + N - TEMP = DWORK( IJ1 ) - DWORK( IJ1 ) = -DWORK( IJ2 ) - DWORK( IJ2 ) = -TEMP - IJ2 = IJ2 + 1 - 150 CONTINUE -C - CALL DSWAP( J-1, DWORK( N+J ), N2, DWORK( (J-1)*N2+N+1 ), - $ 1 ) - 160 CONTINUE -C - ELSE -C - DO 180 J = 1, N - IJ2 = ( N + J )*N2 + N + 1 -C - DO 170 IJ1 = J*N2 + 1, J*N2 + J - TEMP = DWORK( IJ1 ) - DWORK( IJ1 ) = -DWORK( IJ2 ) - DWORK( IJ2 ) = -TEMP - IJ2 = IJ2 + 1 - 170 CONTINUE -C - CALL DSWAP( J-1, DWORK( (N+1)*N2+J ), N2, - $ DWORK( (N+J)*N2+1 ), 1 ) - 180 CONTINUE -C - END IF -C -C Scale the Hamiltonian matrix and its inverse and compute -C the next iterate. -C - HINNRM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) - SCALE = SQRT( HINNRM / HNORM ) -C - IF( LOWER ) THEN -C - DO 200 J = 1, N2 - JI = ( J - 1 )*N2 + J -C - DO 190 IJ = JI, J*N2 - JI = JI + N2 - DWORK( IJ ) = ( DWORK( IJ ) / SCALE + - $ DWORK( JI )*SCALE ) / TWO - DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) - 190 CONTINUE -C - 200 CONTINUE -C - ELSE -C - DO 220 J = 1, N2 - JI = J -C - DO 210 IJ = J*N2 + 1, J*N2 + J - DWORK( IJ ) = ( DWORK( IJ ) / SCALE + - $ DWORK( JI )*SCALE ) / TWO - DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) - JI = JI + N2 - 210 CONTINUE -C - 220 CONTINUE -C - END IF -C -C Test for convergence. -C - CONV = DLANSY( 'F', LOUP, N2, DWORK( ISV+1 ), N2, DWORK ) - IF( CONV.LE.TOL*HNORM ) GO TO 240 - 230 CONTINUE -C -C No convergence after MAXIT iterations, but an approximate solution -C has been found. -C - INFO = 2 -C - 240 CONTINUE -C -C If UPLO = 'U', shift the upper triangle one column to the left. -C - IF( .NOT.LOWER ) - $ CALL DLACPY( 'U', N2, N2, DWORK( INI+1 ), N2, DWORK, N2 ) -C -C Divide the triangle elements by -2 and then fill-in the other -C triangle by symmetry. -C - IF( LOWER ) THEN -C - DO 250 I = 1, N2 - CALL DSCAL( N2-I+1, -HALF, DWORK( (I-1)*N2+I ), 1 ) - 250 CONTINUE -C - ELSE -C - DO 260 I = 1, N2 - CALL DSCAL( I, -HALF, DWORK( (I-1)*N2+1 ), 1 ) - 260 CONTINUE -C - END IF - CALL MA02ED( UPLO, N2, DWORK, N2 ) -C -C Back block-permutation. -C - DO 280 J = 1, N2 -C - DO 270 I = ( J - 1 )*N2 + 1, ( J - 1 )*N2 + N - TEMP = DWORK( I ) - DWORK( I ) = -DWORK( I+N ) - DWORK( I+N ) = TEMP - 270 CONTINUE -C - 280 CONTINUE -C -C Compute the QR decomposition of the projector onto the stable -C invariant subspace. -C Workspace: need 4*N*N + 8*N + 1. -C prefer 4*N*N + 6*N + ( 2*N+1 )*NB. -C - DO 290 I = 1, N2 - IWORK( I ) = 0 - DWORK( ( I-1 )*N2 + I ) = DWORK( ( I-1 )*N2 + I ) + HALF - 290 CONTINUE -C - CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK( ITAU+1 ), - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) -C -C Accumulate the orthogonal transformations. Note that only the -C first N columns of the array DWORK, returned by DGEQP3, are -C needed, so that the last N columns of DWORK are used to get the -C orthogonal basis for the stable invariant subspace. -C Workspace: need 4*N*N + 3*N. -C prefer 4*N*N + 2*N + N*NB. -C - IB = N*N - IAF = N2*N - CALL DLASET( 'F', N2, N, ZERO, ONE, DWORK( IAF+1 ), N2 ) - CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK( ITAU+1 ), - $ DWORK( IAF+1 ), N2, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) -C -C Store the matrices V11 and V21' . -C - CALL DLACPY( 'F', N, N, DWORK( IAF+1 ), N2, DWORK, N ) - CALL MA02AD( 'F', N, N, DWORK( IAF+N+1 ), N2, DWORK( IB+1 ), N ) -C - IR = IAF + IB - IC = IR + N - IFR = IC + N - IBR = IFR + N - IWRK = IBR + N -C -C Compute the solution matrix X . -C Workspace: need 3*N*N + 8*N. -C - CALL DGESVX( 'E', 'T', N, N, DWORK, N, DWORK( IAF+1 ), N, - $ IWORK, EQUED, DWORK( IR+1 ), DWORK( IC+1 ), - $ DWORK( IB+1 ), N, X, LDX, RCOND, DWORK( IFR+1 ), - $ DWORK( IBR+1 ), DWORK( IWRK+1 ), IWORK( N+1 ), - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF -C -C Symmetrize the solution. -C - DO 310 I = 1, N - 1 -C - DO 300 J = I + 1, N - TEMP = ( X( I, J ) + X( J, I ) ) / TWO - X( I, J ) = TEMP - X( J, I ) = TEMP - 300 CONTINUE -C - 310 CONTINUE -C -C Undo scaling for the solution matrix. -C - IF( ISCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, GNORM2, QNORM2, N, N, X, LDX, INFO2 ) - END IF -C - IF( ALL ) THEN -C -C Compute the estimates of the reciprocal condition number and -C error bound. -C Workspace usage. -C - IT = 1 - IU = IT + N*N - IWRK = IU + N*N -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IT+1 ), N ) - IF( NOTRNA ) THEN -C -C Compute Ac = A-G*X . -C - CALL DSYMM( 'L', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK( IT+1 ), N ) - ELSE -C -C Compute Ac = A-X*G . -C - CALL DSYMM( 'R', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK( IT+1 ), N ) - END IF -C -C Compute the Schur factorization of Ac . -C Workspace: need 2*N*N + 5*N + 1; -C prefer larger. -C - CALL DGEES( 'V', 'N', SELECT, N, DWORK( IT+1 ), N, SDIM, WR, - $ WI, DWORK( IU+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, - $ BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) -C -C Estimate the reciprocal condition number and the forward error. -C Workspace: need 6*N*N + 1; -C prefer larger. -C - CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA, - $ DWORK( IT+1 ), N, DWORK( IU+1 ), N, G, LDG, Q, - $ LDQ, X, LDX, SEP, RCOND, FERR, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB02PD - END diff --git a/slycot/src/SB02QD.f b/slycot/src/SB02QD.f deleted file mode 100644 index 8ce39d1b..00000000 --- a/slycot/src/SB02QD.f +++ /dev/null @@ -1,804 +0,0 @@ - SUBROUTINE SB02QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, - $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real continuous-time matrix algebraic Riccati -C equation -C -C op(A)'*X + X*op(A) + Q - X*G*X = 0, (1) -C -C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, -C G = G**T). The matrices A, Q and G are N-by-N and the solution X -C is N-by-N. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization of -C the matrix Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G -C (if TRANA = 'T' or 'C') is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix Ac; -C = 'N': The Schur factorization of Ac will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrices Q and G is -C to be used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., RHS <-- U'*RHS*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, Q, and G. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input or output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then T is an input argument and on entry, -C the leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of Ac (see -C argument FACT). -C If FACT = 'N', then T is an output argument and on exit, -C if INFO = 0 or INFO = N+1, the leading N-by-N upper -C Hessenberg part of this array contains the upper quasi- -C triangular matrix T in Schur canonical form from a Schur -C factorization of Ac (see argument FACT). -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of Ac (see argument FACT). -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of Ac (see argument FACT). -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix G. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix G. _ -C Matrix G should correspond to G in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix Q. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix Q. _ -C Matrix Q should correspond to Q in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= max(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix of the original Riccati -C equation (with matrix A), if LYAPUN = 'O', or of the -C "reduced" Riccati equation (with matrix T), if -C LYAPUN = 'R'. See METHOD. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sep(op(Ac),-op(Ac)'). -C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the continuous-time Riccati equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C Let LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; -C LWA = 0, otherwise. -C If FACT = 'N', then -C LDWORK = MAX(1, 5*N, 2*N*N), if JOB = 'C'; -C LDWORK = MAX(1, LWA + 5*N, 4*N*N ), if JOB = 'E', 'B'. -C If FACT = 'F', then -C LDWORK = MAX(1, 2*N*N), if JOB = 'C'; -C LDWORK = MAX(1, 4*N*N ), if JOB = 'E' or 'B'. -C For good performance, LDWORK must generally be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction of the matrix Ac to Schur -C canonical form (see LAPACK Library routine DGEES); -C on exit, the matrix T(i+1:N,i+1:N) contains the -C partially converged Schur form, and DWORK(i+1:N) and -C DWORK(N+i+1:2*N) contain the real and imaginary -C parts, respectively, of the converged eigenvalues; -C this error is unlikely to appear; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations, but the matrix T, if given -C (for FACT = 'F'), is unchanged. -C -C METHOD -C -C The condition number of the Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W + W*op(Ac), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), -C Pi(W) = inv(Omega(X*W*X)), -C -C and Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G (if TRANA = 'T' -C or 'C'). Note that the Riccati equation (1) is equivalent to -C _ _ _ _ _ _ -C op(T)'*X + X*op(T) + Q + X*G*X = 0, (2) -C _ _ _ -C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the -C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. -C -C The routine estimates the quantities -C -C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [2]. -C -C REFERENCES -C -C [1] Ghavimi, A.R. and Laub, A.J. -C Backward error, sensitivity, and refinement of computed -C solutions of algebraic Riccati equations. -C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, -C 1995. -C -C [2] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEP is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C CONTRIBUTOR -C -C P.Hr. Petkov, Technical University of Sofia, December 1998. -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Conditioning, error estimates, orthogonal transformation, -C real Schur form, Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), - $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NEEDAC, NOFACT, - $ NOTRNA, UPDATE - CHARACTER LOUP, SJOB, TRANAT - INTEGER I, IABS, INFO2, IRES, ITMP, IXBS, J, JJ, JX, - $ KASE, LDW, LWA, NN, SDIM, WRKOPT - DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EST, GNORM, - $ PINORM, QNORM, SCALE, SIG, TEMP, THNORM, TMAX, - $ XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DLACON, DLACPY, DSCAL, - $ DSYMM, DSYR2K, MA02ED, MB01RU, MB01UD, SB03MY, - $ SB03QX, SB03QY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NEEDAC = UPDATE .AND. .NOT.JOBC -C - NN = N*N - IF( NEEDAC ) THEN - LWA = NN - ELSE - LWA = 0 - END IF -C - IF( NOFACT ) THEN - IF( JOBC ) THEN - LDW = MAX( 5*N, 2*NN ) - ELSE - LDW = MAX( LWA + 5*N, 4*NN ) - END IF - ELSE - IF( JOBC ) THEN - LDW = 2*NN - ELSE - LDW = 4*NN - END IF - END IF -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -8 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, LDW ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Workspace usage. -C - IXBS = 0 - ITMP = IXBS + NN - IABS = ITMP + NN - IRES = IABS + NN -C -C Workspace: LWR, where -C LWR = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B', or -C FACT = 'N', -C LWR = 0, otherwise. -C - IF( NEEDAC .OR. NOFACT ) THEN -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - IF( NOTRNA ) THEN -C -C Compute Ac = A - G*X. -C - CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK, N ) - ELSE -C -C Compute Ac = A - X*G. -C - CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, - $ DWORK, N ) - END IF -C - WRKOPT = DBLE( NN ) - IF( NOFACT ) - $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) - ELSE - WRKOPT = DBLE( N ) - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of Ac, Ac = U*T*U'. -C Workspace: need LWA + 5*N; -C prefer larger; -C LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; -C LWA = 0, otherwise. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, - $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) THEN - IF( LWA.GT.0 ) - $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) - END IF - IF( NEEDAC ) - $ CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sep(op(Ac),-op(Ac)') = sep(op(T),-op(T)') and -C norm(Theta). -C Workspace LWA + 2*N*N. -C - CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C - WRKOPT = MAX( WRKOPT, LWA + 2*NN ) -C -C Return if the equation is singular. -C - IF( SEP.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate norm(Pi). -C Workspace LWA + 2*N*N. -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP+1 )) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP+1 )) - $ ) THEN - LOUP = 'U' - ELSE - LOUP = 'L' - END IF -C -C Compute RHS = X*W*X. -C - CALL MB01RU( LOUP, 'No Transpose', N, N, ZERO, ONE, DWORK, - $ N, X, LDX, DWORK, N, DWORK( ITMP+1 ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP+1 ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP+1 ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) - END IF - GO TO 10 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - PINORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - PINORM = EST / SCALE - ELSE - PINORM = BIGNUM - END IF - END IF -C -C Compute the 1-norm of A or T. -C - IF( UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C Compute the 1-norms of the matrices Q and G. -C - QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEP, XNORM, ANORM, GNORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEP*XNORM - DENOM = QNORM + ( SEP*ANORM )*THNORM + - $ ( SEP*GNORM )*PINORM - ELSE - TEMP = ( SEP / TMAX )*( XNORM / TMAX ) - DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + - $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + - $ ( ( SEP / TMAX )*( GNORM / TMAX ) )*PINORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = op(A)'*X + X*op(A) + Q - X*G*X, -C or _ _ _ _ _ _ -C R = op(T)'*X + X*op(T) + Q + X*G*X, -C exploiting the symmetry. -C Workspace 4*N*N. -C - IF( UPDATE ) THEN - CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, ONE, - $ DWORK( IRES+1 ), N ) - SIG = -ONE - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IRES+1 ), N, INFO2 ) - JJ = IRES + 1 - IF( LOWER ) THEN - DO 20 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( N-J+1, ONE, Q( J, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N + 1 - 20 CONTINUE - ELSE - DO 30 J = 1, N - CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( J, ONE, Q( 1, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - 30 CONTINUE - END IF - SIG = ONE - END IF - CALL MB01RU( UPLO, TRANAT, N, N, ONE, SIG, DWORK( IRES+1 ), - $ N, X, LDX, G, LDG, DWORK( ITMP+1 ), NN, INFO2 ) -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( N + 4 ) - TEMP = EPS*FOUR -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(Ac))'*abs(X) -C + abs(X)*abs(op(Ac))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), -C or _ _ -C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(T))'*abs(X) -C _ _ _ _ -C + abs(X)*abs(op(T))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), -C where EPS is the machine precision. -C - DO 50 J = 1, N - DO 40 I = 1, N - DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) - 40 CONTINUE - 50 CONTINUE -C - IF( LOWER ) THEN - DO 70 J = 1, N - DO 60 I = J, N - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 60 CONTINUE - 70 CONTINUE - ELSE - DO 90 J = 1, N - DO 80 I = 1, J - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 80 CONTINUE - 90 CONTINUE - END IF -C - IF( UPDATE ) THEN -C - DO 110 J = 1, N - DO 100 I = 1, N - DWORK( IABS+(J-1)*N+I ) = - $ ABS( DWORK( IABS+(J-1)*N+I ) ) - 100 CONTINUE - 110 CONTINUE -C - CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) - ELSE -C - DO 130 J = 1, N - DO 120 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 120 CONTINUE - 130 CONTINUE -C - CALL MB01UD( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1), N, DWORK( ITMP+1 ), N, INFO2 ) - JJ = IRES + 1 - JX = ITMP + 1 - IF( LOWER ) THEN - DO 140 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), - $ 1 ) - JJ = JJ + N + 1 - JX = JX + N + 1 - 140 CONTINUE - ELSE - DO 150 J = 1, N - CALL DAXPY( J, ONE, DWORK( ITMP+J ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - JX = JX + N - 150 CONTINUE - END IF - END IF -C - IF( LOWER ) THEN - DO 170 J = 1, N - DO 160 I = J, N - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 J = 1, N - DO 180 I = 1, J - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 180 CONTINUE - 190 CONTINUE - END IF -C - CALL MB01RU( UPLO, TRANA, N, N, ONE, EPS*DBLE( 2*( N + 1 ) ), - $ DWORK( IRES+1 ), N, DWORK( IXBS+1), N, - $ DWORK( IABS+1 ), N, DWORK( ITMP+1 ), NN, INFO2 ) -C - WRKOPT = MAX( WRKOPT, 4*NN ) -C -C Compute forward error bound, using matrix norm estimator. -C Workspace 4*N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, - $ INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB02QD *** - END diff --git a/slycot/src/SB02RD.f b/slycot/src/SB02RD.f deleted file mode 100644 index e4d14172..00000000 --- a/slycot/src/SB02RD.f +++ /dev/null @@ -1,1133 +0,0 @@ - SUBROUTINE SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT, - $ LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q, - $ LDQ, X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS, - $ IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + op(A)'*X + X*op(A) - X*op(B)*R op(B)'*X = 0, (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C X = op(A)'*X*op(A) - op(A)'*X*op(B)*(R + op(B)'*X*op(B)) * -C op(B)'*X*op(A) + Q, (2) -C -C where op(M) = M or M' (M**T), A, op(B), Q, and R are N-by-N, -C N-by-M, N-by-N, and M-by-M matrices respectively, with Q symmetric -C and R symmetric nonsingular; X is an N-by-N symmetric matrix. -C -1 -C The matrix G = op(B)*R *op(B)' must be provided on input, instead -C of B and R, that is, the continuous-time equation -C -C Q + op(A)'*X + X*op(A) - X*G*X = 0, (3) -C -C or the discrete-time equation -C -1 -C Q + op(A)'*X*(I_n + G*X) *op(A) - X = 0, (4) -C -C are solved, where G is an N-by-N symmetric matrix. SLICOT Library -C routine SB02MT should be used to compute G, given B and R. SB02MT -C also enables to solve Riccati equations corresponding to optimal -C problems with coupling terms. -C -C The routine also returns the computed values of the closed-loop -C spectrum of the optimal system, i.e., the stable eigenvalues -C lambda(1),...,lambda(N) of the corresponding Hamiltonian or -C symplectic matrix associated to the optimal problem. It is assumed -C that the matrices A, G, and Q are such that the associated -C Hamiltonian or symplectic matrix has N stable eigenvalues, i.e., -C with negative real parts, in the continuous-time case, and with -C moduli less than one, in the discrete-time case. -C -C Optionally, estimates of the conditioning and error bound on the -C solution of the Riccati equation (3) or (4) are returned. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'A': Compute all: the solution, reciprocal condition -C number, and the error bound. -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved or -C analyzed, as follows: -C = 'C': Equation (3), continuous-time case; -C = 'D': Equation (4), discrete-time case. -C -C HINV CHARACTER*1 -C If DICO = 'D' and JOB = 'X' or JOB = 'A', specifies which -C symplectic matrix is to be constructed, as follows: -C = 'D': The matrix H in (6) (see METHOD) is constructed; -C = 'I': The inverse of the matrix H in (6) is constructed. -C HINV is not used if DICO = 'C', or JOB = 'C' or 'E'. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C SCAL CHARACTER*1 -C If JOB = 'X' or JOB = 'A', specifies whether or not a -C scaling strategy should be used, as follows: -C = 'G': General scaling should be used; -C = 'N': No scaling should be used. -C SCAL is not used if JOB = 'C' or 'E'. -C -C SORT CHARACTER*1 -C If JOB = 'X' or JOB = 'A', specifies which eigenvalues -C should be obtained in the top of the Schur form, as -C follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C SORT is not used if JOB = 'C' or 'E'. -C -C FACT CHARACTER*1 -C If JOB <> 'X', specifies whether or not a real Schur -C factorization of the closed-loop system matrix Ac is -C supplied on entry, as follows: -C = 'F': On entry, T and V contain the factors from a real -C Schur factorization of the matrix Ac; -C = 'N': A Schur factorization of Ac will be computed -C and the factors will be stored in T and V. -C For a continuous-time system, the matrix Ac is given by -C Ac = A - G*X, if TRANA = 'N', or -C Ac = A - X*G, if TRANA = 'T' or 'C', -C and for a discrete-time system, the matrix Ac is given by -C Ac = inv(I_n + G*X)*A, if TRANA = 'N', or -C Ac = A*inv(I_n + X*G), if TRANA = 'T' or 'C'. -C FACT is not used if JOB = 'X'. -C -C LYAPUN CHARACTER*1 -C If JOB <> 'X', specifies whether or not the original or -C "reduced" Lyapunov equations should be solved for -C estimating reciprocal condition number and/or the error -C bound, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix V, e.g., X <-- V'*X*V; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C This means that a real Schur form T of Ac appears -C in the equations, instead of Ac. -C LYAPUN is not used if JOB = 'X'. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, Q, G, and X. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If JOB = 'X' or JOB = 'A' or FACT = 'N' or LYAPUN = 'O', -C the leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C If JOB = 'C' or 'E' and FACT = 'F' and LYAPUN = 'R', A is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if JOB = 'X' or JOB = 'A' or -C FACT = 'N' or LYAPUN = 'O'. -C LDA >= 1, otherwise. -C -C T (input or output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If JOB <> 'X' and FACT = 'F', then T is an input argument -C and on entry, the leading N-by-N upper Hessenberg part of -C this array must contain the upper quasi-triangular matrix -C T in Schur canonical form from a Schur factorization of Ac -C (see argument FACT). -C If JOB <> 'X' and FACT = 'N', then T is an output argument -C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N -C upper Hessenberg part of this array contains the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of Ac (see argument FACT). -C If JOB = 'X', the array T is not referenced. -C -C LDT INTEGER -C The leading dimension of the array T. -C LDT >= 1, if JOB = 'X'; -C LDT >= MAX(1,N), if JOB <> 'X'. -C -C V (input or output) DOUBLE PRECISION array, dimension -C (LDV,N) -C If JOB <> 'X' and FACT = 'F', then V is an input argument -C and on entry, the leading N-by-N part of this array must -C contain the orthogonal matrix V from a real Schur -C factorization of Ac (see argument FACT). -C If JOB <> 'X' and FACT = 'N', then V is an output argument -C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N -C part of this array contains the orthogonal N-by-N matrix -C from a real Schur factorization of Ac (see argument FACT). -C If JOB = 'X', the array V is not referenced. -C -C LDV INTEGER -C The leading dimension of the array V. -C LDV >= 1, if JOB = 'X'; -C LDV >= MAX(1,N), if JOB <> 'X'. -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix G. -C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and -C LYAPUN = 'R', the leading N-by-N part of this array -C contains the symmetric matrix G fully stored. -C If JOB <> 'X' and LYAPUN = 'R', this array is modified -C internally, but restored on exit. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix Q. -C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and -C LYAPUN = 'R', the leading N-by-N part of this array -C contains the symmetric matrix Q fully stored. -C If JOB <> 'X' and LYAPUN = 'R', this array is modified -C internally, but restored on exit. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C X (input or output) DOUBLE PRECISION array, dimension -C (LDX,N) -C If JOB = 'C' or JOB = 'E', then X is an input argument -C and on entry, the leading N-by-N part of this array must -C contain the symmetric solution matrix of the algebraic -C Riccati equation. If LYAPUN = 'R', this array is modified -C internally, but restored on exit; however, it could differ -C from the input matrix at the round-off error level. -C If JOB = 'X' or JOB = 'A', then X is an output argument -C and on exit, if INFO = 0 or INFO >= 6, the leading N-by-N -C part of this array contains the symmetric solution matrix -C X of the algebraic Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, the -C estimated quantity -C sep(op(Ac),-op(Ac)'), if DICO = 'C', or -C sepd(op(Ac),op(Ac)'), if DICO = 'D'. (See METHOD.) -C If JOB = 'C' or JOB = 'A' and X = 0, or JOB = 'E', SEP is -C not referenced. -C If JOB = 'X', and INFO = 0, INFO = 5 or INFO = 7, -C SEP contains the scaling factor used, which should -C multiply the (2,1) submatrix of U to recover X from the -C first N columns of U (see METHOD). If SCAL = 'N', SEP is -C set to 1. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, an -C estimate of the reciprocal condition number of the -C algebraic Riccati equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'X', or JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = 7, an -C estimated forward error bound for the solution X. If XTRUE -C is the true solution, FERR bounds the magnitude of the -C largest entry in (X - XTRUE) divided by the magnitude of -C the largest entry in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'X', or JOB = 'C', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (2*N) -C WI (output) DOUBLE PRECISION array, dimension (2*N) -C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, -C these arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the 2N-by-2N matrix S, -C ordered as specified by SORT (except for the case -C HINV = 'D', when the order is opposite to that specified -C by SORT). The leading N elements of these arrays contain -C the closed-loop spectrum of the system matrix Ac (see -C argument FACT). Specifically, -C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. -C If JOB = 'C' or JOB = 'E', these arrays are not -C referenced. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, the -C leading 2N-by-2N part of this array contains the ordered -C real Schur form S of the (scaled, if SCAL = 'G') -C Hamiltonian or symplectic matrix H. That is, -C -C ( S S ) -C ( 11 12 ) -C S = ( ), -C ( 0 S ) -C ( 22 ) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C If JOB = 'C' or JOB = 'E', this array is not referenced. -C -C LDS INTEGER -C The leading dimension of the array S. -C LDS >= MAX(1,2*N), if JOB = 'X' or JOB = 'A'; -C LDS >= 1, if JOB = 'C' or JOB = 'E'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= 2*N, if JOB = 'X'; -C LIWORK >= N*N, if JOB = 'C' or JOB = 'E'; -C LIWORK >= MAX(2*N,N*N), if JOB = 'A'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = 7, DWORK(1) returns the -C optimal value of LDWORK. If INFO = 0, or INFO >= 5, and -C JOB = 'X', or JOB = 'A', then DWORK(2) returns an estimate -C RCONDU of the reciprocal of the condition number (in the -C 1-norm) of the N-th order system of algebraic equations -C from which the solution matrix X is obtained, and DWORK(3) -C returns the reciprocal pivot growth factor for the LU -C factorization of the coefficient matrix of that system -C (see SLICOT Library routine MB02PD); if DWORK(3) is much -C less than 1, then the computed X and RCONDU could be -C unreliable. -C If DICO = 'D', and JOB = 'X', or JOB = 'A', then DWORK(4) -C returns the reciprocal condition number RCONDA of the -C given matrix A, and DWORK(5) returns the reciprocal pivot -C growth factor for A or for its leading columns, if A is -C singular (see SLICOT Library routine MB02PD); if DWORK(5) -C is much less than 1, then the computed S and RCONDA could -C be unreliable. -C On exit, if INFO = 0, or INFO >= 4, and JOB = 'X', the -C elements DWORK(6:5+4*N*N) contain the 2*N-by-2*N -C transformation matrix U which reduced the Hamiltonian or -C symplectic matrix H to the ordered real Schur form S. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 5+MAX(1,4*N*N+8*N), if JOB = 'X' or JOB = 'A'; -C This may also be used for JOB = 'C' or JOB = 'E', but -C exact bounds are as follows: -C LDWORK >= 5 + MAX(1,LWS,LWE) + LWN, where -C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; -C = 5*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'C' and JOB = 'C'; -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'C' and JOB = 'E'; -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'D'; -C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; -C = 4*N*N, if DICO = 'C' and JOB = 'E'; -C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; -C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and JOB = 'E'; -C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; -C = 2*N, if LYAPUN = 'R' and DICO = 'C' and JOB = 'E'; -C = 3*N, if LYAPUN = 'R' and DICO = 'D' and JOB = 'E'. -C For optimum performance LDWORK should sometimes be larger. -C -C BWORK LOGICAL array, dimension (LBWORK) -C LBWORK >= 2*N, if JOB = 'X' or JOB = 'A'; -C LBWORK >= 1, if JOB = 'C' or JOB = 'E', and -C FACT = 'N' and LYAPUN = 'R'; -C LBWORK >= 0, otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if matrix A is (numerically) singular in discrete- -C time case; -C = 2: if the Hamiltonian or symplectic matrix H cannot be -C reduced to real Schur form; -C = 3: if the real Schur form of the Hamiltonian or -C symplectic matrix H cannot be appropriately ordered; -C = 4: if the Hamiltonian or symplectic matrix H has less -C than N stable eigenvalues; -C = 5: if the N-th order system of linear algebraic -C equations, from which the solution matrix X would -C be obtained, is singular to working precision; -C = 6: if the QR algorithm failed to complete the reduction -C of the matrix Ac to Schur canonical form, T; -C = 7: if T and -T' have some almost equal eigenvalues, if -C DICO = 'C', or T has almost reciprocal eigenvalues, -C if DICO = 'D'; perturbed values were used to solve -C Lyapunov equations, but the matrix T, if given (for -C FACT = 'F'), is unchanged. (This is a warning -C indicator.) -C -C METHOD -C -C The method used is the Schur vector approach proposed by Laub [1], -C but with an optional scaling, which enhances the numerical -C stability [6]. It is assumed that [A,B] is a stabilizable pair -C (where for (3) or (4), B is any matrix such that B*B' = G with -C rank(B) = rank(G)), and [E,A] is a detectable pair, where E is any -C matrix such that E*E' = Q with rank(E) = rank(Q). Under these -C assumptions, any of the algebraic Riccati equations (1)-(4) is -C known to have a unique non-negative definite solution. See [2]. -C Now consider the 2N-by-2N Hamiltonian or symplectic matrix -C -C ( op(A) -G ) -C H = ( ), (5) -C ( -Q -op(A)' ), -C -C for continuous-time equation, and -C -1 -1 -C ( op(A) op(A) *G ) -C H = ( -1 -1 ), (6) -C ( Q*op(A) op(A)' + Q*op(A) *G ) -C -C for discrete-time equation, respectively, where -C -1 -C G = op(B)*R *op(B)'. -C The assumptions guarantee that H in (5) has no pure imaginary -C eigenvalues, and H in (6) has no eigenvalues on the unit circle. -C If Y is an N-by-N matrix then there exists an orthogonal matrix U -C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U -C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks -C (corresponding to the complex conjugate eigenvalues and real -C eigenvalues respectively) appear in any desired order. This is the -C ordered real Schur form. Thus, we can find an orthogonal -C similarity transformation U which puts (5) or (6) in ordered real -C Schur form -C -C U'*H*U = S = (S(1,1) S(1,2)) -C ( 0 S(2,2)) -C -C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) -C have negative real parts in case of (5), or moduli greater than -C one in case of (6). If U is conformably partitioned into four -C N-by-N blocks -C -C U = (U(1,1) U(1,2)) -C (U(2,1) U(2,2)) -C -C with respect to the assumptions we then have -C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), -C (2), (3), or (4) with X = X' and non-negative definite; -C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if -C DICO = 'D') are equal to the eigenvalues of optimal system -C (the 'closed-loop' spectrum). -C -C [A,B] is stabilizable if there exists a matrix F such that (A-BF) -C is stable. [E,A] is detectable if [A',E'] is stabilizable. -C -C The condition number of a Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W + W*op(Ac), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), -C Pi(W) = inv(Omega(X*W*X)), -C -C in the continuous-time case, and -C -C Omega(W) = op(Ac)'*W*op(Ac) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), -C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), -C -C in the discrete-time case, and Ac has been defined (see argument -C FACT). Details are given in the comments of SLICOT Library -C routines SB02QD and SB02SD. -C -C The routine estimates the quantities -C -C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), -C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [5]. -C -C REFERENCES -C -C [1] Laub, A.J. -C A Schur Method for Solving Algebraic Riccati equations. -C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. -C -C [2] Wonham, W.M. -C On a matrix Riccati equation of stochastic control. -C SIAM J. Contr., 6, pp. 681-697, 1968. -C -C [3] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C [4] Ghavimi, A.R. and Laub, A.J. -C Backward error, sensitivity, and refinement of computed -C solutions of algebraic Riccati equations. -C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, -C 1995. -C -C [5] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [6] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. The solution accuracy -C can be controlled by the output parameter FERR. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set -C SORT = 'S', if HINV = 'I'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying -C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or -C SORT = 'S' if DICO = 'D' and HINV = 'D'. -C -C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' -C and SORT = 'U', for stabilizing and anti-stabilizing solutions, -C respectively, will be faster then the other combinations [3]. -C -C The option LYAPUN = 'R' may produce slightly worse or better -C estimates, and it is faster than the option 'O'. -C -C This routine is a functionally extended and more accurate -C version of the SLICOT Library routine SB02MD. Transposed problems -C can be dealt with as well. Iterative refinement is used whenever -C useful to solve linear algebraic systems. Condition numbers and -C error bounds on the solutions are optionally provided. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, -C Dec. 2002, Oct. 2004. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, - $ TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDT, LDV, LDWORK, LDX, - $ N - DOUBLE PRECISION FERR, RCOND, SEP -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*), T(LDT,*), V(LDV,*), WI(*), WR(*), - $ X(LDX,*) -C .. Local Scalars .. - LOGICAL COLEQU, DISCR, JBXA, JOBA, JOBC, JOBE, JOBX, - $ LHINV, LSCAL, LSCL, LSORT, LUPLO, NOFACT, - $ NOTRNA, ROWEQU, UPDATE - CHARACTER EQUED, JOBS, LOFACT, LOUP, TRANAT - INTEGER I, IERR, IU, IW, IWB, IWC, IWF, IWI, IWR, LDW, - $ LWE, LWN, LWS, N2, NN, NP1, NROT - DOUBLE PRECISION GNORM, QNORM, PIVOTA, PIVOTU, RCONDA, RCONDU, - $ WRKOPT -C .. External Functions .. - LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, - $ SB02MV, SB02MW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DGESV, DLACPY, DLASCL, - $ DLASET, DSCAL, DSWAP, DSYMM, MA02AD, MA02ED, - $ MB01RU, MB01SD, MB02PD, SB02QD, SB02RU, SB02SD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C -C Decode the input parameters. -C - N2 = N + N - NN = N*N - NP1 = N + 1 - INFO = 0 - JOBA = LSAME( JOB, 'A' ) - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBX = LSAME( JOB, 'X' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - DISCR = LSAME( DICO, 'D' ) - LUPLO = LSAME( UPLO, 'U' ) - LSCAL = LSAME( SCAL, 'G' ) - LSORT = LSAME( SORT, 'S' ) - UPDATE = LSAME( LYAPUN, 'O' ) - JBXA = JOBX .OR. JOBA - LHINV = .FALSE. - IF ( DISCR .AND. JBXA ) - $ LHINV = LSAME( HINV, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.( JBXA .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -2 - ELSE IF( DISCR .AND. JBXA ) THEN - IF( .NOT.( LHINV .OR. LSAME( HINV, 'I' ) ) ) - $ INFO = -3 - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( LUPLO .OR. LSAME( UPLO, 'L' ) ) ) - $ THEN - INFO = -5 - ELSE IF( JBXA ) THEN - IF( .NOT.( LSCAL .OR. LSAME( SCAL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( .NOT.( LSORT .OR. LSAME( SORT, 'U' ) ) ) THEN - INFO = -7 - END IF - END IF - IF( INFO.EQ.0 .AND. .NOT.JOBX ) THEN - IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -8 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -9 - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( N.LT.0 ) THEN - INFO = -10 - ELSE IF( LDA.LT.1 .OR. ( ( JBXA .OR. NOFACT .OR. UPDATE ) - $ .AND. LDA.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDT.LT.1 .OR. ( .NOT. JOBX .AND. LDT.LT.N ) ) THEN - INFO = -14 - ELSE IF( LDV.LT.1 .OR. ( .NOT. JOBX .AND. LDV.LT.N ) ) THEN - INFO = -16 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDS.LT.1 .OR. ( JBXA .AND. LDS.LT.N2 ) ) THEN - INFO = -29 - ELSE - IF( JBXA ) THEN - IF( LDWORK.LT.5 + MAX( 1, 4*NN + 8*N ) ) - $ INFO = -32 - ELSE - IF( NOFACT .AND. UPDATE ) THEN - IF( .NOT.DISCR .AND. JOBC ) THEN - LWS = 5*N - ELSE - LWS = 5*N + NN - END IF - ELSE - LWS = 0 - END IF - IF( DISCR ) THEN - IF( JOBC ) THEN - LWE = MAX( 3, 2*NN) + NN - ELSE - LWE = MAX( 3, 2*NN) + 2*NN - END IF - ELSE - IF( JOBC ) THEN - LWE = 2*NN - ELSE - LWE = 4*NN - END IF - END IF - IF( UPDATE .OR. JOBC ) THEN - LWN = 0 - ELSE - IF( DISCR ) THEN - LWN = 3*N - ELSE - LWN = 2*N - END IF - END IF - IF( LDWORK.LT.5 + MAX( 1, LWS, LWE ) + LWN ) - $ INFO = -32 - END IF - END IF - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF( JOBX ) - $ SEP = ONE - IF( JOBC .OR. JOBA ) - $ RCOND = ONE - IF( JOBE .OR. JOBA ) - $ FERR = ZERO - DWORK(1) = ONE - DWORK(2) = ONE - DWORK(3) = ONE - IF ( DISCR ) THEN - DWORK(4) = ONE - DWORK(5) = ONE - END IF - RETURN - END IF -C - IF ( JBXA ) THEN -C -C Compute the solution matrix X. -C -C Initialise the Hamiltonian or symplectic matrix associated with -C the problem. -C Workspace: need 0 if DICO = 'C'; -C 6*N, if DICO = 'D'. -C - CALL SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, - $ LDQ, S, LDS, IWORK, DWORK, LDWORK, IERR ) -C - IF ( IERR.NE.0 ) THEN - INFO = 1 - IF ( DISCR ) THEN - DWORK(4) = DWORK(1) - DWORK(5) = DWORK(2) - END IF - RETURN - END IF -C - IF ( DISCR ) THEN - WRKOPT = 6*N - RCONDA = DWORK(1) - PIVOTA = DWORK(2) - ELSE - WRKOPT = 0 - END IF -C - IF ( LSCAL ) THEN -C -C Scale the Hamiltonian or symplectic matrix S, using the -C square roots of the norms of the matrices Q and G. -C - QNORM = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) - GNORM = SQRT( DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) ) -C - LSCL = QNORM.GT.GNORM .AND. GNORM.GT.ZERO - IF( LSCL ) THEN - CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), - $ LDS, IERR ) - CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), - $ LDS, IERR ) - END IF - ELSE - LSCL = .FALSE. - END IF -C -C Find the ordered Schur factorization of S, S = U*H*U'. -C Workspace: need 5 + 4*N*N + 6*N; -C prefer larger. -C - IU = 6 - IW = IU + 4*NN - LDW = LDWORK - IW + 1 - IF ( .NOT.DISCR ) THEN - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - ELSE - CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, - $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, - $ BWORK, IERR ) - END IF - IF ( LHINV ) THEN - CALL DSWAP( N, WR, 1, WR(NP1), 1 ) - CALL DSWAP( N, WI, 1, WI(NP1), 1 ) - END IF - END IF - IF ( IERR.GT.N2 ) THEN - INFO = 3 - ELSE IF ( IERR.GT.0 ) THEN - INFO = 2 - ELSE IF ( NROT.NE.N ) THEN - INFO = 4 - END IF - IF ( INFO.NE.0 ) THEN - IF ( DISCR ) THEN - DWORK(4) = RCONDA - DWORK(5) = PIVOTA - END IF - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) -C -C Compute the solution of X*U(1,1) = U(2,1) using -C LU factorization and iterative refinement. The (2,1) block of S -C is used as a workspace for factoring U(1,1). -C Workspace: need 5 + 4*N*N + 8*N. -C -C First transpose U(2,1) in-situ. -C - DO 20 I = 1, N - 1 - CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, - $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) - 20 CONTINUE -C - IWR = IW - IWC = IWR + N - IWF = IWC + N - IWB = IWF + N - IW = IWB + N -C - CALL MB02PD( 'Equilibrate', 'Transpose', N, N, DWORK(IU), N2, - $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), - $ DWORK(IWC), DWORK(IU+N), N2, X, LDX, RCONDU, - $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), - $ IERR ) - IF( JOBX ) THEN -C -C Restore U(2,1) back in-situ. -C - DO 40 I = 1, N - 1 - CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, - $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) - 40 CONTINUE -C - IF( .NOT.LSAME( EQUED, 'N' ) ) THEN -C -C Undo the equilibration of U(1,1) and U(2,1). -C - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) -C - IF( ROWEQU ) THEN -C - DO 60 I = 1, N - DWORK(IWR+I-1) = ONE / DWORK(IWR+I-1) - 60 CONTINUE -C - CALL MB01SD( 'Row scaling', N, N, DWORK(IU), N2, - $ DWORK(IWR), DWORK(IWC) ) - END IF -C - IF( COLEQU ) THEN -C - DO 80 I = 1, N - DWORK(IWC+I-1) = ONE / DWORK(IWC+I-1) - 80 CONTINUE -C - CALL MB01SD( 'Column scaling', N, N, DWORK(IU), N2, - $ DWORK(IWR), DWORK(IWC) ) - CALL MB01SD( 'Column scaling', N, N, DWORK(IU+N), N2, - $ DWORK(IWR), DWORK(IWC) ) - END IF - END IF -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) - END IF -C - PIVOTU = DWORK(IW) -C - IF ( IERR.GT.0 ) THEN -C -C Singular matrix. Set INFO and DWORK for error return. -C - INFO = 5 - GO TO 160 - END IF -C -C Make sure the solution matrix X is symmetric. -C - DO 100 I = 1, N - 1 - CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) - CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) - CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) - 100 CONTINUE -C - IF( LSCAL ) THEN -C -C Undo scaling for the solution matrix. -C - IF( LSCL ) - $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, X, LDX, - $ IERR ) - END IF - END IF -C - IF ( .NOT.JOBX ) THEN - IF ( .NOT.JOBA ) - $ WRKOPT = 0 -C -C Estimate the conditioning and compute an error bound on the -C solution of the algebraic Riccati equation. -C - IW = 6 - LOFACT = FACT - IF ( NOFACT .AND. .NOT.UPDATE ) THEN -C -C Compute Ac and its Schur factorization. -C - IF ( DISCR ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IW), N ) - CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, - $ ONE, DWORK(IW), N ) - IF ( NOTRNA ) THEN -C -C Compute Ac = inv(I_n + G*X)*A. -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) - ELSE -C -C Compute Ac = A*inv(I_n + X*G). -C - CALL MA02AD( 'Full', N, N, A, LDA, T, LDT ) - CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) - DO 120 I = 2, N - CALL DSWAP( I-1, T(1,I), 1, T(I,1), LDT ) - 120 CONTINUE - END IF -C - ELSE -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF ( NOTRNA ) THEN -C -C Compute Ac = A - G*X. -C - CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, - $ ONE, T, LDT ) - ELSE -C -C Compute Ac = A - X*G. -C - CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, - $ ONE, T, LDT ) - END IF - END IF -C -C Compute the Schur factorization of Ac, Ac = V*T*V'. -C Workspace: need 5 + 5*N. -C prefer larger. -C - IWR = IW - IWI = IWR + N - IW = IWI + N - LDW = LDWORK - IW + 1 -C - CALL DGEES( 'Vectors', 'Not ordered', SB02MS, N, T, LDT, - $ NROT, DWORK(IWR), DWORK(IWI), V, LDV, DWORK(IW), - $ LDW, BWORK, IERR ) -C - IF( IERR.NE.0 ) THEN - INFO = 6 - GO TO 160 - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) - LOFACT = 'F' - IW = 6 - END IF -C - IF ( .NOT.UPDATE ) THEN -C -C Update G, Q, and X using the orthogonal matrix V. -C - TRANAT = 'T' -C -C Save the diagonal elements of G and Q. -C - CALL DCOPY( N, G, LDG+1, DWORK(IW), 1 ) - CALL DCOPY( N, Q, LDQ+1, DWORK(IW+N), 1 ) - IW = IW + N2 -C - IF ( JOBA ) - $ CALL DLACPY( 'Full', N, N, X, LDX, S(NP1,1), LDS ) - CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, V, LDV, - $ X, LDX, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, X, LDX+1 ) - CALL MA02ED( UPLO, N, X, LDX ) - IF( .NOT.DISCR ) THEN - CALL MA02ED( UPLO, N, G, LDG ) - CALL MA02ED( UPLO, N, Q, LDQ ) - END IF - CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, V, LDV, - $ G, LDG, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, G, LDG+1 ) - CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, V, LDV, - $ Q, LDQ, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, Q, LDQ+1 ) - END IF -C -C Estimate the conditioning and/or the error bound. -C Workspace: 5 + MAX(1,LWS,LWE) + LWN, where -C -C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; -C = 5*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' -C and JOB = 'C'; -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' -C and (JOB = 'E' or JOB = 'A'); -C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and -C DICO = 'D'; -C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; -C = 4*N*N, if DICO = 'C' and (JOB = 'E' or -C JOB = 'A'); -C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; -C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and (JOB = 'E' or -C JOB = 'A'); -C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; -C = 2*N, if LYAPUN = 'R' and DICO = 'C' and (JOB = 'E' or -C JOB = 'A'); -C = 3*N, if LYAPUN = 'R' and DICO = 'D' and (JOB = 'E' or -C JOB = 'A'). -C - LDW = LDWORK - IW + 1 - IF ( JOBA ) THEN - JOBS = 'B' - ELSE - JOBS = JOB - END IF -C - IF ( DISCR ) THEN - CALL SB02SD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, - $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) - ELSE - CALL SB02QD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, - $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) - END IF -C - WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) - IF( IERR.EQ.NP1 ) THEN - INFO = 7 - ELSE IF( IERR.GT.0 ) THEN - INFO = 6 - GO TO 160 - END IF -C - IF ( .NOT.UPDATE ) THEN -C -C Restore X, G, and Q and set S(2,1) to zero, if needed. -C - IF ( JOBA ) THEN - CALL DLACPY( 'Full', N, N, S(NP1,1), LDS, X, LDX ) - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) - ELSE - CALL MB01RU( UPLO, TRANA, N, N, ZERO, ONE, X, LDX, V, - $ LDV, X, LDX, DWORK(IW), NN, IERR ) - CALL DSCAL( N, HALF, X, LDX+1 ) - CALL MA02ED( UPLO, N, X, LDX ) - END IF - IF ( LUPLO ) THEN - LOUP = 'L' - ELSE - LOUP = 'U' - END IF -C - IW = 6 - CALL DCOPY( N, DWORK(IW), 1, G, LDG+1 ) - CALL MA02ED( LOUP, N, G, LDG ) - CALL DCOPY( N, DWORK(IW+N), 1, Q, LDQ+1 ) - CALL MA02ED( LOUP, N, Q, LDQ ) - END IF -C - END IF -C -C Set the optimal workspace and other details. -C - DWORK(1) = WRKOPT - 160 CONTINUE - IF( JBXA ) THEN - DWORK(2) = RCONDU - DWORK(3) = PIVOTU - IF ( DISCR ) THEN - DWORK(4) = RCONDA - DWORK(5) = PIVOTA - END IF - IF( JOBX ) THEN - IF ( LSCL ) THEN - SEP = QNORM / GNORM - ELSE - SEP = ONE - END IF - END IF - END IF -C - RETURN -C *** Last line of SB02RD *** - END diff --git a/slycot/src/SB02RU.f b/slycot/src/SB02RU.f deleted file mode 100644 index 947d1814..00000000 --- a/slycot/src/SB02RU.f +++ /dev/null @@ -1,508 +0,0 @@ - SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, - $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the 2n-by-2n Hamiltonian or symplectic matrix S -C associated to the linear-quadratic optimization problem, used to -C solve the continuous- or discrete-time algebraic Riccati equation, -C respectively. -C -C For a continuous-time problem, S is defined by -C -C ( op(A) -G ) -C S = ( ), (1) -C ( -Q -op(A)' ) -C -C and for a discrete-time problem by -C -C -1 -1 -C ( op(A) op(A) *G ) -C S = ( -1 -1 ), (2) -C ( Q*op(A) op(A)' + Q*op(A) *G ) -C -C or -C -T -T -C ( op(A) + G*op(A) *Q -G*op(A) ) -C S = ( -T -T ), (3) -C ( -op(A) *Q op(A) ) -C -C where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices, -C with G and Q symmetric. Matrix A must be nonsingular in the -C discrete-time case. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': Continuous-time system; -C = 'D': Discrete-time system. -C -C HINV CHARACTER*1 -C If DICO = 'D', specifies which of the matrices (2) or (3) -C is constructed, as follows: -C = 'D': The matrix S in (2) is constructed; -C = 'I': The (inverse) matrix S in (3) is constructed. -C HINV is not referenced if DICO = 'C'. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which triangle of the matrices G and Q is -C stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, G, and Q. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix G. -C On exit, if DICO = 'D', the leading N-by-N part of this -C array contains the symmetric matrix G fully stored. -C If DICO = 'C', this array is not modified on exit, and the -C strictly lower triangular part (if UPLO = 'U') or strictly -C upper triangular part (if UPLO = 'L') is not referenced. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, the leading N-by-N upper triangular part (if -C UPLO = 'U') or lower triangular part (if UPLO = 'L') of -C this array must contain the upper triangular part or lower -C triangular part, respectively, of the symmetric matrix Q. -C On exit, if DICO = 'D', the leading N-by-N part of this -C array contains the symmetric matrix Q fully stored. -C If DICO = 'C', this array is not modified on exit, and the -C strictly lower triangular part (if UPLO = 'U') or strictly -C upper triangular part (if UPLO = 'L') is not referenced. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) -C If INFO = 0, the leading 2N-by-2N part of this array -C contains the Hamiltonian or symplectic matrix of the -C problem. -C -C LDS INTEGER -C The leading dimension of the array S. LDS >= MAX(1,2*N). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK >= 0, if DICO = 'C'; -C LIWORK >= 2*N, if DICO = 'D'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if DICO = 'D', DWORK(1) returns the reciprocal -C condition number RCOND of the given matrix A, and -C DWORK(2) returns the reciprocal pivot growth factor -C norm(A)/norm(U) (see SLICOT Library routine MB02PD). -C If DWORK(2) is much less than 1, then the computed S -C and RCOND could be unreliable. If 0 < INFO <= N, then -C DWORK(2) contains the reciprocal pivot growth factor for -C the leading INFO columns of A. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if DICO = 'C'; -C LDWORK >= MAX(2,6*N), if DICO = 'D'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if the leading i-by-i (1 <= i <= N) upper triangular -C submatrix of A is singular in discrete-time case; -C = N+1: if matrix A is numerically singular in discrete- -C time case. -C -C METHOD -C -C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) -C is constructed. -C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or -C (3) - the inverse of the matrix in (2) - is constructed. -C -C NUMERICAL ASPECTS -C -C The discrete-time case needs the inverse of the matrix A, hence -C the routine should not be used when A is ill-conditioned. -C 3 -C The algorithm requires 0(n ) floating point operations in the -C discrete-time case. -C -C FURTHER COMMENTS -C -C This routine is a functionally extended and with improved accuracy -C version of the SLICOT Library routine SB02MU. Transposed problems -C can be dealt with as well. The LU factorization of op(A) (with -C no equilibration) and iterative refinement are used for solving -C the various linear algebraic systems involved. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, HINV, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), - $ S(LDS,*) -C .. Local Scalars .. - CHARACTER EQUED, TRANAT - LOGICAL DISCR, LHINV, LUPLO, NOTRNA - INTEGER I, J, N2, NJ, NP1 - DOUBLE PRECISION PIVOTG, RCOND, RCONDA, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSWAP, MA02AD, - $ MA02ED, MB02PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - N2 = N + N - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LUPLO = LSAME( UPLO, 'U' ) - NOTRNA = LSAME( TRANA, 'N' ) - IF( DISCR ) - $ LHINV = LSAME( HINV, 'D' ) -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( DISCR ) THEN - IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) - $ INFO = -2 - ELSE IF( INFO.EQ.0 ) THEN - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) - $ .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN - INFO = -13 - ELSE IF( ( LDWORK.LT.0 ) .OR. - $ ( DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) ) THEN - INFO = -16 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB02RU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( DISCR ) THEN - DWORK(1) = ONE - DWORK(2) = ONE - END IF - RETURN - END IF -C -C The code tries to exploit data locality as much as possible, -C assuming that LDS is greater than LDA, LDQ, and/or LDG. -C - IF ( .NOT.DISCR ) THEN -C -C Continuous-time case: Construct Hamiltonian matrix column-wise. -C -C Copy op(A) in S(1:N,1:N), and construct full Q -C in S(N+1:2*N,1:N) and change the sign. -C - DO 100 J = 1, N - IF ( NOTRNA ) THEN - CALL DCOPY( N, A(1,J), 1, S(1,J), 1 ) - ELSE - CALL DCOPY( N, A(J,1), LDA, S(1,J), 1 ) - END IF -C - IF ( LUPLO ) THEN -C - DO 20 I = 1, J - S(N+I,J) = -Q(I,J) - 20 CONTINUE -C - DO 40 I = J + 1, N - S(N+I,J) = -Q(J,I) - 40 CONTINUE -C - ELSE -C - DO 60 I = 1, J - 1 - S(N+I,J) = -Q(J,I) - 60 CONTINUE -C - DO 80 I = J, N - S(N+I,J) = -Q(I,J) - 80 CONTINUE -C - END IF - 100 CONTINUE -C -C Construct full G in S(1:N,N+1:2*N) and change the sign, and -C construct -op(A)' in S(N+1:2*N,N+1:2*N). -C - DO 240 J = 1, N - NJ = N + J - IF ( LUPLO ) THEN -C - DO 120 I = 1, J - S(I,NJ) = -G(I,J) - 120 CONTINUE -C - DO 140 I = J + 1, N - S(I,NJ) = -G(J,I) - 140 CONTINUE -C - ELSE -C - DO 160 I = 1, J - 1 - S(I,NJ) = -G(J,I) - 160 CONTINUE -C - DO 180 I = J, N - S(I,NJ) = -G(I,J) - 180 CONTINUE -C - END IF -C - IF ( NOTRNA ) THEN -C - DO 200 I = 1, N - S(N+I,NJ) = -A(J,I) - 200 CONTINUE -C - ELSE -C - DO 220 I = 1, N - S(N+I,NJ) = -A(I,J) - 220 CONTINUE -C - END IF - 240 CONTINUE -C - ELSE -C -C Discrete-time case: Construct the symplectic matrix (2) or (3). -C -C Fill in the remaining triangles of the symmetric matrices Q -C and G. -C - CALL MA02ED( UPLO, N, Q, LDQ ) - CALL MA02ED( UPLO, N, G, LDG ) -C -C Prepare the construction of S in (2) or (3). -C - NP1 = N + 1 - IF ( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C -C Solve op(A)'*X = Q in S(N+1:2*N,1:N), using the LU -C factorization of op(A), obtained in S(1:N,1:N), and -C iterative refinement. No equilibration of A is used. -C Workspace: 6*N. -C - CALL MB02PD( 'No equilibration', TRANAT, N, N, A, LDA, S, - $ LDS, IWORK, EQUED, DWORK, DWORK, Q, LDQ, - $ S(NP1,1), LDS, RCOND, DWORK, DWORK(NP1), - $ IWORK(NP1), DWORK(N2+1), INFO ) -C -C Return if the matrix is exactly singular or singular to -C working precision. -C - IF( INFO.GT.0 ) THEN - DWORK(1) = RCOND - DWORK(2) = DWORK(N2+1) - RETURN - END IF -C - RCONDA = RCOND - PIVOTG = DWORK(N2+1) -C - IF ( LHINV ) THEN -C -C Complete the construction of S in (2). -C -C Transpose X in-situ. -C - DO 260 J = 1, N - 1 - CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) - 260 CONTINUE -C -C Solve op(A)*X = I_n in S(N+1:2*N,N+1:2*N), using the LU -C factorization of op(A), computed in S(1:N,1:N), and -C iterative refinement. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) - CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, - $ EQUED, DWORK, DWORK, S(1,NP1), LDS, S(NP1,NP1), - $ LDS, RCOND, DWORK, DWORK(NP1), IWORK(NP1), - $ DWORK(N2+1), INFO ) -C -C Solve op(A)*X = G in S(1:N,N+1:2*N), using the LU -C factorization of op(A), computed in S(1:N,1:N), and -C iterative refinement. -C - CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, - $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, - $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), - $ DWORK(N2+1), INFO ) -C -C -1 -C Copy op(A) from S(N+1:2*N,N+1:2*N) in S(1:N,1:N). -C - CALL DLACPY( 'Full', N, N, S(NP1,NP1), LDS, S, LDS ) -C -C -1 -C Compute op(A)' + Q*op(A) *G in S(N+1:2*N,N+1:2*N). -C - IF ( NOTRNA ) THEN - CALL MA02AD( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) - ELSE - CALL DLACPY( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) - END IF - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, - $ Q, LDQ, S(1,NP1), LDS, ONE, S(NP1,NP1), LDS ) -C - ELSE -C -C Complete the construction of S in (3). -C -C Change the sign of X. -C - DO 300 J = 1, N -C - DO 280 I = NP1, N2 - S(I,J) = -S(I,J) - 280 CONTINUE -C - 300 CONTINUE -C -C Solve op(A)'*X = I_n in S(N+1:2*N,N+1:2*N), using the LU -C factorization of op(A), computed in S(1:N,1:N), and -C iterative refinement. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) - CALL MB02PD( 'Factored', TRANAT, N, N, A, LDA, S, LDS, - $ IWORK, EQUED, DWORK, DWORK, S(1,NP1), LDS, - $ S(NP1,NP1), LDS, RCOND, DWORK, DWORK(NP1), - $ IWORK(NP1), DWORK(N2+1), INFO ) -C -C Solve op(A)*X' = -G in S(1:N,N+1:2*N), using the LU -C factorization of op(A), obtained in S(1:N,1:N), and -C iterative refinement. -C - CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, - $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, - $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), - $ DWORK(N2+1), INFO ) -C -C Change the sign of X and transpose it in-situ. -C - DO 340 J = NP1, N2 -C - DO 320 I = 1, N - TEMP = -S(I,J) - S(I,J) = -S(J-N,I+N) - S(J-N,I+N) = TEMP - 320 CONTINUE -C - 340 CONTINUE -C -T -C Compute op(A) + G*op(A) *Q in S(1:N,1:N). -C - IF ( NOTRNA ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) - ELSE - CALL MA02AD( 'Full', N, N, A, LDA, S, LDS ) - END IF - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE, - $ G, LDG, S(NP1,1), LDS, ONE, S, LDS ) -C - END IF - DWORK(1) = RCONDA - DWORK(2) = PIVOTG - END IF - RETURN -C -C *** Last line of SB02RU *** - END diff --git a/slycot/src/SB02SD.f b/slycot/src/SB02SD.f deleted file mode 100644 index 81685c3b..00000000 --- a/slycot/src/SB02SD.f +++ /dev/null @@ -1,859 +0,0 @@ - SUBROUTINE SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, - $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real discrete-time matrix algebraic Riccati -C equation (see FURTHER COMMENTS) -C -1 -C X = op(A)'*X*(I_n + G*X) *op(A) + Q, (1) -C -C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, -C G = G**T). The matrices A, Q and G are N-by-N and the solution X -C is N-by-N. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization of -C the matrix Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or -C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'), is supplied -C on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix Ac; -C = 'N': The Schur factorization of Ac will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrices Q and G is -C to be used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., RHS <-- U'*RHS*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, Q, and G. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input or output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then T is an input argument and on entry, -C the leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of Ac (see -C argument FACT). -C If FACT = 'N', then T is an output argument and on exit, -C if INFO = 0 or INFO = N+1, the leading N-by-N upper -C Hessenberg part of this array contains the upper quasi- -C triangular matrix T in Schur canonical form from a Schur -C factorization of Ac (see argument FACT). -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= max(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of Ac (see argument FACT). -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of Ac (see argument FACT). -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C G (input) DOUBLE PRECISION array, dimension (LDG,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix G. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix G. _ -C Matrix G should correspond to G in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDG INTEGER -C The leading dimension of the array G. LDG >= max(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix Q. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix Q. _ -C Matrix Q should correspond to Q in the "reduced" Riccati -C equation (with matrix T, instead of A), if LYAPUN = 'R'. -C See METHOD. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= max(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix of the original Riccati -C equation (with matrix A), if LYAPUN = 'O', or of the -C "reduced" Riccati equation (with matrix T), if -C LYAPUN = 'R'. See METHOD. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sepd(op(Ac),op(Ac)'). -C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the discrete-time Riccati equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C Let LWA = N*N, if LYAPUN = 'O'; -C LWA = 0, otherwise, -C and LWN = N, if LYAPUN = 'R' and JOB = 'E' or 'B'; -C LWN = 0, otherwise. -C If FACT = 'N', then -C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + N*N), -C if JOB = 'C'; -C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + 2*N*N + LWN), -C if JOB = 'E' or 'B'. -C If FACT = 'F', then -C LDWORK = MAX(3,2*N*N) + N*N, if JOB = 'C'; -C LDWORK = MAX(3,2*N*N) + 2*N*N + LWN, -C if JOB = 'E' or 'B'. -C For good performance, LDWORK must generally be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction of the matrix Ac to Schur -C canonical form (see LAPACK Library routine DGEES); -C on exit, the matrix T(i+1:N,i+1:N) contains the -C partially converged Schur form, and DWORK(i+1:N) and -C DWORK(N+i+1:2*N) contain the real and imaginary -C parts, respectively, of the converged eigenvalues; -C this error is unlikely to appear; -C = N+1: if T has almost reciprocal eigenvalues; perturbed -C values were used to solve Lyapunov equations, but -C the matrix T, if given (for FACT = 'F'), is -C unchanged. -C -C METHOD -C -C The condition number of the Riccati equation is estimated as -C -C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + -C norm(Pi)*norm(G) ) / norm(X), -C -C where Omega, Theta and Pi are linear operators defined by -C -C Omega(W) = op(Ac)'*W*op(Ac) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), -C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), -C -C and Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or -C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'). -C -C Note that the Riccati equation (1) is equivalent to -C -C X = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q, (2) -C -C and to -C _ _ _ _ _ _ -C X = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q, (3) -C _ _ _ -C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the -C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. -C -C The routine estimates the quantities -C -C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), -C -C norm(Theta) and norm(Pi) using 1-norm condition estimator. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [2]. -C -C REFERENCES -C -C [1] Ghavimi, A.R. and Laub, A.J. -C Backward error, sensitivity, and refinement of computed -C solutions of algebraic Riccati equations. -C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, -C 1995. -C -C [2] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortran 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEPD is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C Let B be an N-by-M matrix (if TRANA = 'N') or an M-by-N matrix -C (if TRANA = 'T' or 'C'), let R be an M-by-M symmetric positive -C definite matrix (R = R**T), and denote G = op(B)*inv(R)*op(B)'. -C Then, the Riccati equation (1) is equivalent to the standard -C discrete-time matrix algebraic Riccati equation -C -C X = op(A)'*X*op(A) - (4) -C -1 -C op(A)'*X*op(B)*(R + op(B)'*X*op(B)) *op(B)'*X*op(A) + Q. -C -C By symmetry, the equation (1) is also equivalent to -C -1 -C X = op(A)'*(I_n + X*G) *X*op(A) + Q. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, and -C P.Hr. Petkov, Technical University of Sofia, March 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Conditioning, error estimates, orthogonal transformation, -C real Schur form, Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), - $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NEEDAC, NOFACT, - $ NOTRNA, UPDATE - CHARACTER LOUP, SJOB, TRANAT - INTEGER I, IABS, INFO2, IRES, IWRK, IXBS, IXMA, J, JJ, - $ KASE, LDW, LWA, LWR, NN, SDIM, WRKOPT - DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EPST, EST, - $ GNORM, PINORM, QNORM, SCALE, TEMP, THNORM, - $ TMAX, XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DGESV, DLACON, - $ DLACPY, DLASET, DSCAL, DSWAP, DSYMM, MA02ED, - $ MB01RU, MB01RX, MB01RY, MB01UD, SB03MX, SB03SX, - $ SB03SY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NEEDAC = UPDATE .AND. .NOT.JOBC -C - NN = N*N - IF( UPDATE ) THEN - LWA = NN - ELSE - LWA = 0 - END IF -C - IF( JOBC ) THEN - LDW = MAX( 3, 2*NN ) + NN - ELSE - LDW = MAX( 3, 2*NN ) + 2*NN - IF( .NOT.UPDATE ) - $ LDW = LDW + N - END IF - IF( NOFACT ) - $ LDW = MAX( LWA + 5*N, LDW ) -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -8 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.LDW ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Workspace usage. -C - IRES = 0 - IXBS = IRES + NN - IXMA = MAX( 3, 2*NN ) - IABS = IXMA + NN - IWRK = IABS + NN -C -C Workspace: LWK, where -C LWK = 2*N*N, if LYAPUN = 'O', or FACT = 'N', -C LWK = N, otherwise. -C - IF( UPDATE .OR. NOFACT ) THEN -C - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK( IXBS+1 ), N ) - CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, ONE, - $ DWORK( IXBS+1 ), N ) - IF( NOTRNA ) THEN -C -1 -C Compute Ac = (I_n + G*X) *A. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, - $ INFO2 ) - ELSE -C -1 -C Compute Ac = A*(I_n + X*G) . -C - DO 10 J = 1, N - CALL DCOPY( N, A( 1, J ), 1, DWORK( J ), N ) - 10 CONTINUE - CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, - $ INFO2 ) - DO 20 J = 2, N - CALL DSWAP( J-1, DWORK( (J-1)*N+1 ), 1, DWORK( J ), N ) - 20 CONTINUE - END IF -C - WRKOPT = DBLE( 2*NN ) - IF( NOFACT ) - $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) - ELSE - WRKOPT = DBLE( N ) - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of Ac, Ac = U*T*U'. -C Workspace: need LWA + 5*N; -C prefer larger; -C LWA = N*N, if LYAPUN = 'O'; -C LWA = 0, otherwise. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, - $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) THEN - IF( LWA.GT.0 ) - $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) - RETURN - END IF -C - WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) - END IF - IF( NEEDAC ) THEN - CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) - LWR = NN - ELSE - LWR = 0 - END IF -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C _ -C Compute X*op(Ac) or X*op(T). -C - IF( UPDATE ) THEN - CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, DWORK, - $ N, ZERO, DWORK( IXMA+1 ), N ) - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IXMA+1 ), N, INFO2 ) - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sepd(op(Ac),op(Ac)') = sepd(op(T),op(T)') and -C norm(Theta). -C Workspace LWR + MAX(3,2*N*N) + N*N, where -C LWR = N*N, if LYAPUN = 'O' and JOB = 'B', -C LWR = 0, otherwise. -C - CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, - $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, - $ IXMA, INFO ) -C - WRKOPT = MAX( WRKOPT, LWR + MAX( 3, 2*NN ) + NN ) -C -C Return if the equation is singular. -C - IF( SEPD.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate norm(Pi). -C Workspace LWR + MAX(3,2*N*N) + N*N. -C - KASE = 0 -C -C REPEAT - 30 CONTINUE - CALL DLACON( NN, DWORK( IXBS+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( IXBS+1 )) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( IXBS+1 )) - $ ) THEN - LOUP = 'U' - ELSE - LOUP = 'L' - END IF -C _ _ -C Compute RHS = op(Ac)'*X*W*X*op(Ac) or op(T)'*X*W*X*op(T). -C - CALL MB01RU( LOUP, TRANAT, N, N, ZERO, ONE, DWORK, N, - $ DWORK( IXMA+1 ), N, DWORK, N, DWORK( IXBS+1 ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( IXBS+1 ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( IXBS+1 ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( IXBS+1 ), INFO2 ) - END IF -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( IXBS+1 ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( LOUP, N, DWORK, N ) - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - PINORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - PINORM = EST / SCALE - ELSE - PINORM = BIGNUM - END IF - END IF -C -C Compute the 1-norm of A or T. -C - IF( UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C Compute the 1-norms of the matrices Q and G. -C - QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEPD, XNORM, ANORM, GNORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEPD*XNORM - DENOM = QNORM + ( SEPD*ANORM )*THNORM + - $ ( SEPD*GNORM )*PINORM - ELSE - TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) - DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + - $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + - $ ( ( SEPD / TMAX )*( GNORM / TMAX ) )*PINORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q - X, -C or _ _ _ _ _ _ -C R = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q - X, -C exploiting the symmetry. Actually, the equivalent formula -C R = op(A)'*X*op(Ac) + Q - X -C is used in the first case. -C Workspace MAX(3,2*N*N) + 2*N*N, if LYAPUN = 'O'; -C MAX(3,2*N*N) + 2*N*N + N, if LYAPUN = 'R'. -C - CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) - JJ = IRES + 1 - IF( LOWER ) THEN - DO 40 J = 1, N - CALL DAXPY( N-J+1, -ONE, X( J, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N + 1 - 40 CONTINUE - ELSE - DO 50 J = 1, N - CALL DAXPY( J, -ONE, X( 1, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - 50 CONTINUE - END IF -C - IF( UPDATE ) THEN - CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, ONE, - $ DWORK( IRES+1 ), N, A, LDA, DWORK( IXMA+1 ), N, - $ INFO2 ) - ELSE - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, ONE, - $ DWORK( IRES+1 ), N, T, LDT, DWORK( IXMA+1 ), N, - $ DWORK( IWRK+1 ), INFO2 ) - CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, - $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) - CALL MB01RX( 'Left', UPLO, 'Transpose', N, N, ONE, ONE, - $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, - $ DWORK( IXBS+1 ), N, INFO2 ) - END IF -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( N + 4 ) - EPST = EPS*DBLE( 2*( N + 1 ) ) - TEMP = EPS*FOUR -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + -C (n+4)*abs(op(Ac))'*abs(X)*abs(op(Ac)) + 2*(n+1)* -C abs(op(Ac))'*abs(X)*abs(G)*abs(X)*abs(op(Ac))), -C or _ _ -C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + -C _ -C (n+4)*abs(op(T))'*abs(X)*abs(op(T)) + -C _ _ _ -C 2*(n+1)*abs(op(T))'*abs(X)*abs(G)*abs(X)*abs(op(T))), -C where EPS is the machine precision. -C - DO 70 J = 1, N - DO 60 I = 1, N - DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) - 60 CONTINUE - 70 CONTINUE -C - IF( LOWER ) THEN - DO 90 J = 1, N - DO 80 I = J, N - DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + - $ ABS( X( I, J ) ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 80 CONTINUE - 90 CONTINUE - ELSE - DO 110 J = 1, N - DO 100 I = 1, J - DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + - $ ABS( X( I, J ) ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 100 CONTINUE - 110 CONTINUE - END IF -C - IF( UPDATE ) THEN -C - DO 130 J = 1, N - DO 120 I = 1, N - DWORK( IABS+(J-1)*N+I ) = - $ ABS( DWORK( IABS+(J-1)*N+I ) ) - 120 CONTINUE - 130 CONTINUE -C - CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, - $ DWORK( IXBS+1 ), N, DWORK( IABS+1 ), N, ZERO, - $ DWORK( IXMA+1 ), N ) - CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, EPSN, - $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, - $ DWORK( IXMA+1 ), N, INFO2 ) - ELSE -C - DO 150 J = 1, N - DO 140 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 140 CONTINUE - 150 CONTINUE -C - CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), N, DWORK( IXMA+1 ), N, INFO2 ) - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, - $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, - $ DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), INFO2 ) - END IF -C - IF( LOWER ) THEN - DO 170 J = 1, N - DO 160 I = J, N - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 190 J = 1, N - DO 180 I = 1, J - DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) - 180 CONTINUE - 190 CONTINUE - END IF -C - IF( UPDATE ) THEN - CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPST, DWORK( IRES+1 ), - $ N, DWORK( IXMA+1 ), N, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), NN, INFO2 ) - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN ) - ELSE - CALL DSYMM( 'Left', UPLO, N, N, ONE, DWORK( IABS+1 ), N, - $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPST, - $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, - $ DWORK( IXBS+1 ), N, DWORK( IWRK+1 ), INFO2 ) - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN + N ) - END IF -C -C Compute forward error bound, using matrix norm estimator. -C Workspace MAX(3,2*N*N) + N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK( IXBS+1 ), - $ IXMA, INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB02SD *** - END diff --git a/slycot/src/SB03MD.f b/slycot/src/SB03MD.f deleted file mode 100644 index f11b3ff4..00000000 --- a/slycot/src/SB03MD.f +++ /dev/null @@ -1,556 +0,0 @@ - SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, C, LDC, A, LDA, U, - $ LDU, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the real continuous-time Lyapunov equation -C -C op(A)'*X + X*op(A) = scale*C (1) -C -C or the real discrete-time Lyapunov equation -C -C op(A)'*X*op(A) - X = scale*C (2) -C -C and/or estimate an associated condition number, called separation, -C where op(A) = A or A' (A**T) and C is symmetric (C = C'). -C (A' denotes the transpose of the matrix A.) A is N-by-N, the right -C hand side C and the solution X are N-by-N, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the equation from which X is to be determined -C as follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'B': Compute both the solution and the separation. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix in Schur canonical form; -C the elements below the upper Hessenberg part of the -C array A are not referenced. -C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N -C upper Hessenberg part of this array contains the upper -C quasi-triangular matrix in Schur canonical form from the -C Schur factorization of A. The contents of array A is not -C modified if FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If FACT = 'F', then U is an input argument and on entry -C the leading N-by-N part of this array must contain the -C orthogonal matrix U of the real Schur factorization of A. -C If FACT = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO = N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with JOB = 'X' or 'B', the leading N-by-N part of -C this array must contain the symmetric matrix C. -C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, -C the leading N-by-N part of C has been overwritten by the -C symmetric solution matrix X. -C If JOB = 'S', C is not referenced. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP -C contains the estimated separation of the matrices op(A) -C and -op(A)', if DICO = 'C' or of op(A) and op(A)', if -C DICO = 'D'. -C If JOB = 'X' or N = 0, SEP is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an -C estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the relative -C error in the computed solution, measured in the Frobenius -C norm: norm(X - XTRUE)/norm(XTRUE). -C If JOB = 'X' or JOB = 'S', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of -C the eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1, and -C If JOB = 'X' then -C If FACT = 'F', LDWORK >= N*N, for DICO = 'C'; -C LDWORK >= MAX(N*N, 2*N), for DICO = 'D'; -C If FACT = 'N', LDWORK >= MAX(N*N, 3*N). -C If JOB = 'S' or JOB = 'B' then -C If FACT = 'F', LDWORK >= 2*N*N, for DICO = 'C'; -C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. -C If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C'; -C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues (see LAPACK Library routine DGEES); -C elements i+1:n of WR and WI contain eigenvalues -C which have converged, and A contains the partially -C converged Schur form; -C = N+1: if DICO = 'C', and the matrices A and -A' have -C common or very close eigenvalues, or -C if DICO = 'D', and matrix A has almost reciprocal -C eigenvalues (that is, lambda(i) = 1/lambda(j) for -C some i and j, where lambda(i) and lambda(j) are -C eigenvalues of A and i <> j); perturbed values were -C used to solve the equation (but the matrix A is -C unchanged). -C -C METHOD -C -C The Schur factorization of a square matrix A is given by -C -C A = U*S*U' -C -C where U is orthogonal and S is block upper triangular with 1-by-1 -C and 2-by-2 blocks on its diagonal, these blocks corresponding to -C the eigenvalues of A, the 2-by-2 blocks being complex conjugate -C pairs. This factorization is obtained by numerically stable -C methods: first A is reduced to upper Hessenberg form (if FACT = -C 'N') by means of Householder transformations and then the -C QR Algorithm is applied to reduce the Hessenberg form to S, the -C transformation matrices being accumulated at each step to give U. -C If A has already been factorized prior to calling the routine -C however, then the factors U and S may be supplied and the initial -C factorization omitted. -C _ _ -C If we now put C = U'CU and X = UXU' equations (1) and (2) (see -C PURPOSE) become (for TRANS = 'N') -C _ _ _ -C S'X + XS = C, (3) -C and -C _ _ _ -C S'XS - X = C, (4) -C -C respectively. Partition S, C and X as -C _ _ _ _ -C (s s') (c c') (x x') -C ( 11 ) _ ( 11 ) _ ( 11 ) -C S = ( ), C = ( ), X = ( ) -C ( ) ( _ ) ( _ ) -C ( 0 S ) ( c C ) ( x X ) -C 1 1 1 -C _ _ -C where s , c and x are either scalars or 2-by-2 matrices and s, -C 11 11 11 -C _ _ -C c and x are either (N-1) element vectors or matrices with two -C columns. Equations (3) and (4) can then be re-written as -C _ _ _ -C s' x + x s = c (3.1) -C 11 11 11 11 11 -C -C _ _ _ _ -C S'x + xs = c - sx (3.2) -C 1 11 11 -C -C _ _ -C S'X + X S = C - (sx' + xs') (3.3) -C 1 1 1 1 1 -C and -C _ _ _ -C s' x s - x = c (4.1) -C 11 11 11 11 11 -C -C _ _ _ _ -C S'xs - x = c - sx s (4.2) -C 1 11 11 11 -C -C _ _ _ -C S'X S - X = C - sx s' - [s(S'x)' + (S'x)s'] (4.3) -C 1 1 1 1 1 11 1 1 -C _ -C respectively. If DICO = 'C' ['D'], then once x has been -C 11 -C found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be -C _ -C solved by forward substitution for x and then equation (3.3) -C [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or -C (N-2) depending upon whether s is 1-by-1 or 2-by-2. -C 11 -C _ _ -C When s is 2-by-2 then x and c will be 1-by-2 matrices and s, -C 11 11 11 -C _ _ -C x and c are matrices with two columns. In this case, equation -C (3.1) [(4.1)] defines the three equations in the unknown elements -C _ -C of x and equation (3.2) [(4.2)] can then be solved by forward -C 11 _ -C substitution, a row of x being found at each step. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [3] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C If DICO = 'C', SEP is defined as the separation of op(A) and -C -op(A)': -C -C sep( op(A), -op(A)' ) = sigma_min( T ) -C -C and if DICO = 'D', SEP is defined as -C -C sep( op(A), op(A)' ) = sigma_min( T ) -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ) (DICO = 'C'), -C -C T = kprod( op(A)', op(A)' ) - I(N**2) (DICO = 'D'). -C -C I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker -C product. The program estimates sigma_min(T) by the reciprocal of -C an estimate of the 1-norm of inverse(T). The true reciprocal -C 1-norm of inverse(T) cannot differ from sigma_min(T) by more -C than a factor of N. -C -C When SEP is small, small changes in A, C can cause large changes -C in the solution of the equation. An approximate bound on the -C maximum relative error in the computed solution is -C -C EPS * norm(A) / SEP (DICO = 'C'), -C -C EPS * norm(A)**2 / SEP (DICO = 'D'), -C -C where EPS is the machine precision. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, July 1997. -C Supersedes Release 2.0 routine SB03AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOB, TRANA - INTEGER INFO, LDA, LDC, LDU, LDWORK, N - DOUBLE PRECISION FERR, SCALE, SEP -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ U( LDU, * ), WI( * ), WR( * ) -C .. Local Scalars .. - LOGICAL CONT, NOFACT, NOTA, WANTBH, WANTSP, WANTX - CHARACTER NOTRA, NTRNST, TRANST, UPLO - INTEGER I, IERR, KASE, LWA, MINWRK, NN, NN2, SDIM - DOUBLE PRECISION EPS, EST, SCALEF -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, SB03MY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - CONT = LSAME( DICO, 'C' ) - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTA = LSAME( TRANA, 'N' ) - NN = N*N - NN2 = 2*NN -C - INFO = 0 - IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN - INFO = -2 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -3 - ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( WANTSP .AND. LDC.LT.1 .OR. - $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE - IF ( WANTX ) THEN - IF ( NOFACT ) THEN - MINWRK = MAX( NN, 3*N ) - ELSE IF ( CONT ) THEN - MINWRK = NN - ELSE - MINWRK = MAX( NN, 2*N ) - END IF - ELSE - IF ( CONT ) THEN - IF ( NOFACT ) THEN - MINWRK = MAX( NN2, 3*N ) - ELSE - MINWRK = NN2 - END IF - ELSE - MINWRK = NN2 + 2*N - END IF - END IF - IF( LDWORK.LT.MAX( 1, MINWRK ) ) - $ INFO = -19 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - SCALE = ONE - IF( WANTBH ) - $ FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - LWA = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LWA = INT( DWORK( 1 ) ) - END IF -C - IF( .NOT.WANTSP ) THEN -C -C Transform the right-hand side. -C Workspace: N*N. -C - NTRNST = 'N' - TRANST = 'T' - UPLO = 'U' - CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C, - $ LDC, DWORK, LDWORK, INFO ) -C - DO 10 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 10 CONTINUE -C - LWA = MAX( LWA, NN ) -C -C Solve the transformed equation. -C Workspace for DICO = 'D': 2*N. -C - IF ( CONT ) THEN - CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) - ELSE - CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) - END IF - IF( INFO.GT.0 ) - $ INFO = N + 1 -C -C Transform back the solution. -C Workspace: N*N. -C - CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C, - $ LDC, DWORK, LDWORK, IERR ) -C - DO 20 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 20 CONTINUE -C - END IF -C - IF( .NOT.WANTX ) THEN -C -C Estimate the separation. -C Workspace: 2*N*N for DICO = 'C'; -C 2*N*N + 2*N for DICO = 'D'. -C - IF( NOTA ) THEN - NOTRA = 'T' - ELSE - NOTRA = 'N' - END IF -C - EST = ZERO - KASE = 0 -C REPEAT - 30 CONTINUE - CALL DLACON( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN - IF( CONT ) THEN - CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, - $ IERR ) - ELSE - CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK(NN2+1), IERR ) - END IF - ELSE - IF( CONT ) THEN - CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, - $ IERR ) - ELSE - CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK(NN2+1), IERR ) - END IF - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - SEP = SCALEF / EST -C - IF( WANTBH ) THEN -C -C Get the machine precision. -C - EPS = DLAMCH( 'P' ) -C -C Compute the estimate of the relative error. -C - IF ( CONT ) THEN - FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP - ELSE - FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP - END IF - END IF - END IF -C - DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) - RETURN -C *** Last line of SB03MD *** - END diff --git a/slycot/src/SB03MU.f b/slycot/src/SB03MU.f deleted file mode 100644 index 69ddd742..00000000 --- a/slycot/src/SB03MU.f +++ /dev/null @@ -1,467 +0,0 @@ - SUBROUTINE SB03MU( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, - $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in -C -C ISGN*op(TL)*X*op(TR) - X = SCALE*B, -C -C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 -C or -1. op(T) = T or T', where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRANL LOGICAL -C Specifies the form of op(TL) to be used, as follows: -C = .FALSE.: op(TL) = TL, -C = .TRUE. : op(TL) = TL'. -C -C LTRANR LOGICAL -C Specifies the form of op(TR) to be used, as follows: -C = .FALSE.: op(TR) = TR, -C = .TRUE. : op(TR) = TR'. -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The order of matrix TL. N1 may only be 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of matrix TR. N2 may only be 0, 1 or 2. -C -C TL (input) DOUBLE PRECISION array, dimension (LDTL,2) -C The leading N1-by-N1 part of this array must contain the -C matrix TL. -C -C LDTL INTEGER -C The leading dimension of array TL. LDTL >= MAX(1,N1). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,2) -C The leading N2-by-N2 part of this array must contain the -C matrix TR. -C -C LDTR INTEGER -C The leading dimension of array TR. LDTR >= MAX(1,N2). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C The leading N1-by-N2 part of this array must contain the -C right-hand side of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N2) -C The leading N1-by-N2 part of this array contains the -C solution of the equation. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N1). -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if TL and TR have almost reciprocal eigenvalues, so -C TL or TR is perturbed to get a nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Based on DLASD2 by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Discrete-time system, Sylvester equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRANL, LTRANR - INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), - $ X( LDX, * ) -C .. -C .. 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 -C .. -C .. 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 ) -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. 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. / -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors. -C - INFO = 0 - SCALE = ONE -C -C Quick return if possible. -C - IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN - XNORM = ZERO - RETURN - END IF -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - SGN = ISGN -C - K = N1 + N1 + N2 - 2 - GO TO ( 10, 20, 30, 50 )K -C -C 1-by-1: SGN*TL11*X*TR11 - X = B11. -C - 10 CONTINUE - TAU1 = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - BET = ABS( TAU1 ) - IF( BET.LE.SMLNUM ) THEN - TAU1 = SMLNUM - BET = SMLNUM - INFO = 1 - END IF -C - GAM = ABS( B( 1, 1 ) ) - IF( SMLNUM*GAM.GT.BET ) - $ SCALE = ONE / GAM -C - X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 - XNORM = ABS( X( 1, 1 ) ) - RETURN -C -C 1-by-2: -C ISGN*TL11*[X11 X12]*op[TR11 TR12] = [B11 B12]. -C [TR21 TR22] -C - 20 CONTINUE -C - SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - $ *ABS( TL( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - TMP( 4 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE - IF( LTRANR ) THEN - TMP( 2 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - TMP( 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - ELSE - TMP( 2 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - TMP( 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 1, 2 ) - GO TO 40 -C -C 2-by-1: -C ISGN*op[TL11 TL12]*[X11]*TR11 = [B11]. -C [TL21 TL22] [X21] [B21] -C - 30 CONTINUE - SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) - $ *ABS( TR( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - TMP( 4 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE - IF( LTRANL ) THEN - TMP( 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - TMP( 3 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - ELSE - TMP( 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - TMP( 3 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - 40 CONTINUE -C -C Solve 2-by-2 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - 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 - 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( X2( 1 ) ) + ABS( X2( 2 ) ) - ELSE - X( 2, 1 ) = X2( 2 ) - XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) - END IF - RETURN -C -C 2-by-2: -C ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12]. -C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] -C -C Solve equivalent 4-by-4 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - 50 CONTINUE - SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN - SMIN = MAX( EPS*SMIN, SMLNUM ) - T16( 1, 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE - T16( 2, 2 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE - T16( 3, 3 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE - T16( 4, 4 ) = SGN*TL( 2, 2 )*TR( 2, 2 ) - ONE - IF( LTRANL ) THEN - T16( 1, 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - T16( 2, 1 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - T16( 3, 4 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) - T16( 4, 3 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) - ELSE - T16( 1, 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) - T16( 2, 1 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) - T16( 3, 4 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) - T16( 4, 3 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) - END IF - IF( LTRANR ) THEN - T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) - T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) - ELSE - T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) - T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) - T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) - T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) - END IF - IF( LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN - T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) - T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - ELSE - T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) - T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) - T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) - T16( 4, 1 ) = SGN*TL( 2, 1 )*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 ) -C -C Perform elimination -C - DO 100 I = 1, 3 - XMAX = ZERO -C - DO 70 IP = I, 4 -C - 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 -C - 70 CONTINUE -C - 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 -C - DO 90 J = I + 1, 4 - T16( J, I ) = T16( J, I ) / T16( I, I ) - BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) -C - DO 80 K = I + 1, 4 - T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) - 80 CONTINUE -C - 90 CONTINUE -C - 100 CONTINUE -C - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN - 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 -C - DO 120 I = 1, 4 - K = 5 - I - TEMP = ONE / T16( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 110 J = K + 1, 4 - TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) - 110 CONTINUE -C - 120 CONTINUE -C - 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 -C - 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 ) ) ) -C - RETURN -C *** Last line of SB03MU *** - END diff --git a/slycot/src/SB03MV.f b/slycot/src/SB03MV.f deleted file mode 100644 index 30dcc6af..00000000 --- a/slycot/src/SB03MV.f +++ /dev/null @@ -1,295 +0,0 @@ - SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, - $ XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the 2-by-2 symmetric matrix X in -C -C op(T)'*X*op(T) - X = SCALE*B, -C -C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', -C where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRAN LOGICAL -C Specifies the form of op(T) to be used, as follows: -C = .FALSE.: op(T) = T, -C = .TRUE. : op(T) = T'. -C -C LUPPER LOGICAL -C Specifies which triangle of the matrix B is used, and -C which triangle of the matrix X is computed, as follows: -C = .TRUE. : The upper triangular part; -C = .FALSE.: The lower triangular part. -C -C Input/Output Parameters -C -C T (input) DOUBLE PRECISION array, dimension (LDT,2) -C The leading 2-by-2 part of this array must contain the -C matrix T. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= 2. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C On entry with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix B and the strictly -C lower triangular part of B is not referenced. -C On entry with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix B and the strictly -C upper triangular part of B is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,2) -C On exit with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array contains the upper -C triangular part of the symmetric solution matrix X and the -C strictly lower triangular part of X is not referenced. -C On exit with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array contains the lower -C triangular part of the symmetric solution matrix X and the -C strictly upper triangular part of X is not referenced. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 2. -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if T has almost reciprocal eigenvalues, so T -C is perturbed to get a nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Based on DLALD2 by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, Lyapunov equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRAN, LUPPER - INTEGER INFO, LDB, LDT, LDX - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - INTEGER I, IP, IPSV, J, JP, JPSV, K - DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX -C .. -C .. Local Arrays .. - INTEGER JPIV( 3 ) - DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors. -C - INFO = 0 -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS -C -C Solve equivalent 3-by-3 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), - $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) - SMIN = MAX( EPS*SMIN, SMLNUM ) - T9( 1, 1 ) = T( 1, 1 )*T( 1, 1 ) - ONE - T9( 2, 2 ) = T( 1, 1 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 1 ) - ONE - T9( 3, 3 ) = T( 2, 2 )*T( 2, 2 ) - ONE - IF( LTRAN ) THEN - T9( 1, 2 ) = T( 1, 1 )*T( 1, 2 ) + T( 1, 1 )*T( 1, 2 ) - T9( 1, 3 ) = T( 1, 2 )*T( 1, 2 ) - T9( 2, 1 ) = T( 1, 1 )*T( 2, 1 ) - T9( 2, 3 ) = T( 1, 2 )*T( 2, 2 ) - T9( 3, 1 ) = T( 2, 1 )*T( 2, 1 ) - T9( 3, 2 ) = T( 2, 1 )*T( 2, 2 ) + T( 2, 1 )*T( 2, 2 ) - ELSE - T9( 1, 2 ) = T( 1, 1 )*T( 2, 1 ) + T( 1, 1 )*T( 2, 1 ) - T9( 1, 3 ) = T( 2, 1 )*T( 2, 1 ) - T9( 2, 1 ) = T( 1, 1 )*T( 1, 2 ) - T9( 2, 3 ) = T( 2, 1 )*T( 2, 2 ) - T9( 3, 1 ) = T( 1, 2 )*T( 1, 2 ) - T9( 3, 2 ) = T( 1, 2 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - IF ( LUPPER ) THEN - BTMP( 2 ) = B( 1, 2 ) - ELSE - BTMP( 2 ) = B( 2, 1 ) - END IF - BTMP( 3 ) = B( 2, 2 ) -C -C Perform elimination. -C - DO 50 I = 1, 2 - XMAX = ZERO -C - DO 20 IP = I, 3 -C - DO 10 JP = I, 3 - IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T9( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 10 CONTINUE -C - 20 CONTINUE -C - IF( IPSV.NE.I ) THEN - CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T9( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T9( I, I ) = SMIN - END IF -C - DO 40 J = I + 1, 3 - T9( J, I ) = T9( J, I ) / T9( I, I ) - BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) -C - DO 30 K = I + 1, 3 - T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) - 30 CONTINUE -C - 40 CONTINUE -C - 50 CONTINUE -C - IF( ABS( T9( 3, 3 ) ).LT.SMIN ) - $ T9( 3, 3 ) = SMIN - SCALE = ONE - IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN - SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - END IF -C - DO 70 I = 1, 3 - K = 4 - I - TEMP = ONE / T9( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 60 J = K + 1, 3 - TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) - 60 CONTINUE -C - 70 CONTINUE -C - DO 80 I = 1, 2 - IF( JPIV( 3-I ).NE.3-I ) THEN - TEMP = TMP( 3-I ) - TMP( 3-I ) = TMP( JPIV( 3-I ) ) - TMP( JPIV( 3-I ) ) = TEMP - END IF - 80 CONTINUE -C - X( 1, 1 ) = TMP( 1 ) - IF ( LUPPER ) THEN - X( 1, 2 ) = TMP( 2 ) - ELSE - X( 2, 1 ) = TMP( 2 ) - END IF - X( 2, 2 ) = TMP( 3 ) - XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), - $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) -C - RETURN -C *** Last line of SB03MV *** - END diff --git a/slycot/src/SB03MW.f b/slycot/src/SB03MW.f deleted file mode 100644 index 8a0a5120..00000000 --- a/slycot/src/SB03MW.f +++ /dev/null @@ -1,293 +0,0 @@ - SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, - $ XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the 2-by-2 symmetric matrix X in -C -C op(T)'*X + X*op(T) = SCALE*B, -C -C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', -C where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRAN LOGICAL -C Specifies the form of op(T) to be used, as follows: -C = .FALSE.: op(T) = T, -C = .TRUE. : op(T) = T'. -C -C LUPPER LOGICAL -C Specifies which triangle of the matrix B is used, and -C which triangle of the matrix X is computed, as follows: -C = .TRUE. : The upper triangular part; -C = .FALSE.: The lower triangular part. -C -C Input/Output Parameters -C -C T (input) DOUBLE PRECISION array, dimension (LDT,2) -C The leading 2-by-2 part of this array must contain the -C matrix T. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= 2. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C On entry with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix B and the strictly -C lower triangular part of B is not referenced. -C On entry with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix B and the strictly -C upper triangular part of B is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,2) -C On exit with LUPPER = .TRUE., the leading 2-by-2 upper -C triangular part of this array contains the upper -C triangular part of the symmetric solution matrix X and the -C strictly lower triangular part of X is not referenced. -C On exit with LUPPER = .FALSE., the leading 2-by-2 lower -C triangular part of this array contains the lower -C triangular part of the symmetric solution matrix X and the -C strictly upper triangular part of X is not referenced. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= 2. -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if T and -T have too close eigenvalues, so T -C is perturbed to get a nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Based on DLALY2 by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Continuous-time system, Lyapunov equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRAN, LUPPER - INTEGER INFO, LDB, LDT, LDX - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - INTEGER I, IP, IPSV, J, JP, JPSV, K - DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX -C .. -C .. Local Arrays .. - INTEGER JPIV( 3 ) - DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors -C - INFO = 0 -C -C Set constants to control overflow -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS -C -C Solve equivalent 3-by-3 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - SMIN = MAX( MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), - $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) )*EPS, - $ SMLNUM ) - T9( 1, 3 ) = ZERO - T9( 3, 1 ) = ZERO - T9( 1, 1 ) = T( 1, 1 ) - T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 ) - T9( 3, 3 ) = T( 2, 2 ) - IF( LTRAN ) THEN - T9( 1, 2 ) = T( 1, 2 ) - T9( 2, 1 ) = T( 2, 1 ) - T9( 2, 3 ) = T( 1, 2 ) - T9( 3, 2 ) = T( 2, 1 ) - ELSE - T9( 1, 2 ) = T( 2, 1 ) - T9( 2, 1 ) = T( 1, 2 ) - T9( 2, 3 ) = T( 2, 1 ) - T9( 3, 2 ) = T( 1, 2 ) - END IF - BTMP( 1 ) = B( 1, 1 )/TWO - IF ( LUPPER ) THEN - BTMP( 2 ) = B( 1, 2 ) - ELSE - BTMP( 2 ) = B( 2, 1 ) - END IF - BTMP( 3 ) = B( 2, 2 )/TWO -C -C Perform elimination -C - DO 50 I = 1, 2 - XMAX = ZERO -C - DO 20 IP = I, 3 -C - DO 10 JP = I, 3 - IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN - XMAX = ABS( T9( IP, JP ) ) - IPSV = IP - JPSV = JP - END IF - 10 CONTINUE -C - 20 CONTINUE -C - IF( IPSV.NE.I ) THEN - CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) - TEMP = BTMP( I ) - BTMP( I ) = BTMP( IPSV ) - BTMP( IPSV ) = TEMP - END IF - IF( JPSV.NE.I ) - $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) - JPIV( I ) = JPSV - IF( ABS( T9( I, I ) ).LT.SMIN ) THEN - INFO = 1 - T9( I, I ) = SMIN - END IF -C - DO 40 J = I + 1, 3 - T9( J, I ) = T9( J, I ) / T9( I, I ) - BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) -C - DO 30 K = I + 1, 3 - T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) - 30 CONTINUE -C - 40 CONTINUE -C - 50 CONTINUE -C - IF( ABS( T9( 3, 3 ) ).LT.SMIN ) - $ T9( 3, 3 ) = SMIN - SCALE = ONE - IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. - $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN - SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), - $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) - BTMP( 1 ) = BTMP( 1 )*SCALE - BTMP( 2 ) = BTMP( 2 )*SCALE - BTMP( 3 ) = BTMP( 3 )*SCALE - END IF -C - DO 70 I = 1, 3 - K = 4 - I - TEMP = ONE / T9( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 60 J = K + 1, 3 - TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) - 60 CONTINUE -C - 70 CONTINUE -C - DO 80 I = 1, 2 - IF( JPIV( 3-I ).NE.3-I ) THEN - TEMP = TMP( 3-I ) - TMP( 3-I ) = TMP( JPIV( 3-I ) ) - TMP( JPIV( 3-I ) ) = TEMP - END IF - 80 CONTINUE -C - X( 1, 1 ) = TMP( 1 ) - IF ( LUPPER ) THEN - X( 1, 2 ) = TMP( 2 ) - ELSE - X( 2, 1 ) = TMP( 2 ) - END IF - X( 2, 2 ) = TMP( 3 ) - XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), - $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) -C - RETURN -C *** Last line of SB03MW *** - END diff --git a/slycot/src/SB03MX.f b/slycot/src/SB03MX.f deleted file mode 100644 index 31b39299..00000000 --- a/slycot/src/SB03MX.f +++ /dev/null @@ -1,711 +0,0 @@ - SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real discrete Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C -C -C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is -C symmetric (C = C'). (A' denotes the transpose of the matrix A.) -C A is N-by-N, the right hand side C and the solution X are N-by-N, -C and scale is an output scale factor, set less than or equal to 1 -C to avoid overflow in X. The solution matrix X is overwritten -C onto C. -C -C A must be in Schur canonical form (as returned by LAPACK routines -C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and -C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its -C diagonal elements equal and its off-diagonal elements of opposite -C sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix A, in Schur canonical form. -C The part of A below the first sub-diagonal is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading N-by-N part of this array must -C contain the symmetric matrix C. -C On exit, if INFO >= 0, the leading N-by-N part of this -C array contains the symmetric solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if A has almost reciprocal eigenvalues; perturbed -C values were used to solve the equation (but the -C matrix A is unchanged). -C -C METHOD -C -C A discrete-time version of the Bartels-Stewart algorithm is used. -C A set of equivalent linear algebraic systems of equations of order -C at most four are formed and solved using Gaussian elimination with -C complete pivoting. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03AZ by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DTRLPD by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C A. Varga, DLR Oberpfaffenhofen, March 2002. -C -C KEYWORDS -C -C Discrete-time system, Lyapunov equation, matrix algebra, real -C Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANA - INTEGER INFO, LDA, LDC, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, LUPPER - INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, - $ MINK1N, MINK2N, MINL1N, MINL2N, NP1 - DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, - $ SCALOC, SMIN, SMLNUM, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT, DLAMCH, DLANHS - EXTERNAL DDOT, DLAMCH, DLANHS, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DSCAL, DSYMV, SB03MV, SB04PX, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - LUPPER = .TRUE. -C - INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03MX', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( N*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DWORK ) ) - NP1 = N + 1 -C - IF( NOTRNA ) THEN -C -C Solve A'*X*A - X = scale*C. -C -C The (K,L)th block of X is determined starting from -C upper-left corner column by column by -C -C A(K,K)'*X(K,L)*A(L,L) - X(K,L) = C(K,L) - R(K,L), -C -C where -C K L-1 -C R(K,L) = SUM {A(I,K)'*SUM [X(I,J)*A(J,L)]} + -C I=1 J=1 -C -C K-1 -C {SUM [A(I,K)'*X(I,L)]}*A(L,L). -C I=1 -C -C Start column loop (index = L). -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 60 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 60 - L1 = L - L2 = L - IF( L.LT.N ) THEN - IF( A( L+1, L ).NE.ZERO ) - $ L2 = L2 + 1 - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K). -C K1 (K2): row index of the first (last) row of X(K,L). -C - DWORK( L1 ) = ZERO - DWORK( N+L1 ) = ZERO - CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L1 ), 1, ZERO, - $ DWORK, 1 ) - CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L2 ), 1, ZERO, - $ DWORK( NP1 ), 1 ) -C - KNEXT = L -C - DO 50 K = L, N - IF( K.LT.KNEXT ) - $ GO TO 50 - K1 = K - K2 = K - IF( K.LT.N ) THEN - IF( A( K+1, K ).NE.ZERO ) - $ K2 = K2 + 1 - KNEXT = K2 + 1 - END IF -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) - $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*A( L1, L1 ) - ONE - 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), - $ 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) - $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + A( L1, L1 ) - $ *DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 20 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ A( 1, L2 ), 1 ) - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + - $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + - $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), - $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), - $ 1 ) - DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ A( 1, L2 ), 1 ) - DWORK( N+K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ A( 1, L2 ), 1 ) - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + - $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + - $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + - $ P21*A( L1, L1 ) + P22*A( L2, L1 ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK( NP1 ), 1 ) + - $ P21*A( L1, L2 ) + P22*A( L2, L2 ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MV( .FALSE., LUPPER, A( K1, K1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL SB04PX( .TRUE., .FALSE., -1, 2, 2, - $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 40 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - 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 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 50 CONTINUE -C - 60 CONTINUE -C - ELSE -C -C Solve A*X*A' - X = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-right corner column by column by -C -C A(K,K)*X(K,L)*A(L,L)' - X(K,L) = C(K,L) - R(K,L), -C -C where -C -C N N -C R(K,L) = SUM {A(K,I)* SUM [X(I,J)*A(L,J)']} + -C I=K J=L+1 -C -C N -C { SUM [A(K,J)*X(J,L)]}*A(L,L)' -C J=K+1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L) -C - LNEXT = N -C - DO 120 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 120 - L1 = L - L2 = L - IF( L.GT.1 ) THEN - IF( A( L, L-1 ).NE.ZERO ) THEN - L1 = L1 - 1 - DWORK( L1 ) = ZERO - DWORK( N+L1 ) = ZERO - END IF - LNEXT = L1 - 1 - END IF - MINL1N = MIN( L1+1, N ) - MINL2N = MIN( L2+1, N ) -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L) -C - IF( L2.LT.N ) THEN - CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, - $ A( L1, L2+1 ), LDA, ZERO, DWORK( L2+1 ), 1 ) - CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, - $ A( L2, L2+1 ), LDA, ZERO, DWORK( NP1+L2 ), 1) - END IF -C - KNEXT = L -C - DO 110 K = L, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 110 - K1 = K - K2 = K - IF( K.GT.1 ) THEN - IF( A( K, K-1 ).NE.ZERO ) - $ K1 = K1 - 1 - KNEXT = K1 - 1 - END IF - MINK1N = MIN( K1+1, N ) - MINK2N = MIN( K2+1, N ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 )*A( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*A( L1, L1 ) - ONE - 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) - DWORK( K2 ) = DDOT( N-L1, C( K2, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), 1 ) - $ + DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 80 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 80 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) - DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) - P11 = DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 ) - P12 = DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), 1) - $ + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), - $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 90 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 90 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) - DWORK( K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) - DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) - DWORK( N+K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) - P11 = DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) - P12 = DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) - P21 = DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) - P22 = DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) - $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), - $ 1) + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1) + P21*A( L1, L1 ) + P22*A( L1, L2 ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( N+K1 ), 1) - $ + P21*A( L2, L1 ) + P22*A( L2, L2 ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MV( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, - $ 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL SB04PX( .FALSE., .TRUE., -1, 2, 2, - $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE -C - CALL DSCAL( N, SCALOC, DWORK, 1 ) - CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) - 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 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB03MX *** - END diff --git a/slycot/src/SB03MY.f b/slycot/src/SB03MY.f deleted file mode 100644 index 6aa1642c..00000000 --- a/slycot/src/SB03MY.f +++ /dev/null @@ -1,613 +0,0 @@ - SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C -C -C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is -C symmetric (C = C'). (A' denotes the transpose of the matrix A.) -C A is N-by-N, the right hand side C and the solution X are N-by-N, -C and scale is an output scale factor, set less than or equal to 1 -C to avoid overflow in X. The solution matrix X is overwritten -C onto C. -C -C A must be in Schur canonical form (as returned by LAPACK routines -C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and -C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its -C diagonal elements equal and its off-diagonal elements of opposite -C sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix A, in Schur canonical form. -C The part of A below the first sub-diagonal is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading N-by-N part of this array must -C contain the symmetric matrix C. -C On exit, if INFO >= 0, the leading N-by-N part of this -C array contains the symmetric solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if A and -A have common or very close eigenvalues; -C perturbed values were used to solve the equation -C (but the matrix A is unchanged). -C -C METHOD -C -C Bartels-Stewart algorithm is used. A set of equivalent linear -C algebraic systems of equations of order at most four are formed -C and solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03AY by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DTRLYP by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Continuous-time system, Lyapunov equation, matrix algebra, real -C Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANA - INTEGER INFO, LDA, LDC, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, LUPPER - INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, - $ MINK1N, MINK2N, MINL1N, MINL2N - DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN, - $ SMLNUM, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT, DLAMCH, DLANHS - EXTERNAL DDOT, DLAMCH, DLANHS, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, SB03MW, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - LUPPER = .TRUE. -C - INFO = 0 - IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03MY', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( N*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DUM ) ) -C - IF( NOTRNA ) THEN -C -C Solve A'*X + X*A = scale*C. -C -C The (K,L)th block of X is determined starting from -C upper-left corner column by column by -C -C A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L), -C -C where -C K-1 L-1 -C R(K,L) = SUM [A(I,K)'*X(I,L)] + SUM [X(K,J)*A(J,L)]. -C I=1 J=1 -C -C Start column loop (index = L). -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 60 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 60 - L1 = L - L2 = L - IF( L.LT.N ) THEN - IF( A( L+1, L ).NE.ZERO ) - $ L2 = L2 + 1 - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K). -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = L -C - DO 50 K = L, N - IF( K.LT.KNEXT ) - $ GO TO 50 - K1 = K - K2 = K - IF( K.LT.N ) THEN - IF( A( K+1, K ).NE.ZERO ) - $ K2 = K2 + 1 - KNEXT = K2 + 1 - END IF -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 ) + A( 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), - $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 20 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( L1, L1 ), - $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + - $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + - $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + - $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MW( .FALSE., LUPPER, A( K1, K1 ), LDA, - $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL DLASY2( .TRUE., .FALSE., 1, 2, 2, A( K1, K1 ), - $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, - $ X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 40 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE -C - 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 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 50 CONTINUE -C - 60 CONTINUE -C - ELSE -C -C Solve A*X + X*A' = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-right corner column by column by -C -C A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L), -C -C where -C N N -C R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)']. -C I=K+1 J=L+1 -C -C Start column loop (index = L). -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = N -C - DO 120 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 120 - L1 = L - L2 = L - IF( L.GT.1 ) THEN - IF( A( L, L-1 ).NE.ZERO ) - $ L1 = L1 - 1 - LNEXT = L1 - 1 - END IF - MINL1N = MIN( L1+1, N ) - MINL2N = MIN( L2+1, N ) -C -C Start row loop (index = K). -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = L -C - DO 110 K = L, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 110 - K1 = K - K2 = K - IF( K.GT.1 ) THEN - IF( A( K, K-1 ).NE.ZERO ) - $ K1 = K1 - 1 - KNEXT = K1 - 1 - END IF - MINK1N = MIN( K1+1, N ) - MINK2N = MIN( K2+1, N ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 ) + - $ DDOT( N-L1, C( K1, MINL1N ), LDC, - $ A( L1, MINL1N ), LDA ) ) - SCALOC = ONE -C - A11 = A( K1, K1 ) + A( 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - END IF -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), - $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 80 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 80 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L1, K2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L1 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 2, 1 ) = C( K1, L2 ) - - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, - $ C( MINK1N, L2 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( L1, L1 ), - $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 90 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 90 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - VEC( 1, 1 ) = C( K1, L1 ) - - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 1, 2 ) = C( K1, L2 ) - - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) + - $ DDOT( N-L2, C( K1, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) ) -C - VEC( 2, 1 ) = C( K2, L1 ) - - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L1 ), 1 ) + - $ DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L1, MINL2N ), LDA ) ) -C - VEC( 2, 2 ) = C( K2, L2 ) - - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, - $ C( MINK2N, L2 ), 1 ) + - $ DDOT( N-L2, C( K2, MINL2N ), LDC, - $ A( L2, MINL2N ), LDA ) ) -C - IF( K1.EQ.L1 ) THEN - CALL SB03MW( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, - $ 2, SCALOC, X, 2, XNORM, IERR ) - IF( LUPPER ) THEN - X( 2, 1 ) = X( 1, 2 ) - ELSE - X( 1, 2 ) = X( 2, 1 ) - END IF - ELSE - CALL DLASY2( .FALSE., .TRUE., 1, 2, 2, A( K1, K1 ), - $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, - $ X, 2, XNORM, IERR ) - END IF - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE -C - 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 ) - IF( K1.NE.L1 ) THEN - C( L1, K1 ) = X( 1, 1 ) - C( L2, K1 ) = X( 1, 2 ) - C( L1, K2 ) = X( 2, 1 ) - C( L2, K2 ) = X( 2, 2 ) - END IF - END IF -C - 110 CONTINUE -C - 120 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB03MY *** - END diff --git a/slycot/src/SB03OD.f b/slycot/src/SB03OD.f deleted file mode 100644 index 0b93c747..00000000 --- a/slycot/src/SB03OD.f +++ /dev/null @@ -1,662 +0,0 @@ - SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, - $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)'*op(U) either the stable non-negative -C definite continuous-time Lyapunov equation -C 2 -C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) -C -C or the convergent non-negative definite discrete-time Lyapunov -C equation -C 2 -C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), A is -C an N-by-N matrix, op(B) is an M-by-N matrix, U is an upper -C triangular matrix containing the Cholesky factor of the solution -C matrix X, X = op(U)'*op(U), and scale is an output scale factor, -C set less than or equal to 1 to avoid overflow in X. If matrix B -C has full rank then the solution matrix X will be positive-definite -C and hence the Cholesky factor U will be nonsingular, but if B is -C rank deficient then X may be only positive semi-definite and U -C will be singular. -C -C In the case of equation (1) the matrix A must be stable (that -C is, all the eigenvalues of A must have negative real parts), -C and for equation (2) the matrix A must be convergent (that is, -C all the eigenvalues of A must lie inside the unit circle). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Lyapunov equation to be solved as -C follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and Q contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and Q. -C -C TRANS CHARACTER*1 -C Specifies the form of op(K) to be used, as follows: -C = 'N': op(K) = K (No transpose); -C = 'T': op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and the number of columns in -C matrix op(B). N >= 0. -C -C M (input) INTEGER -C The number of rows in matrix op(B). M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix S in Schur canonical -C form; the elements below the upper Hessenberg part of the -C array A are not referenced. -C On exit, the leading N-by-N upper Hessenberg part of this -C array contains the upper quasi-triangular matrix S in -C Schur canonical form from the Shur factorization of A. -C The contents of array A is not modified if FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C Q (input or output) DOUBLE PRECISION array, dimension -C (LDQ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Q of the -C Schur factorization of A. -C Otherwise, Q need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Q of the Schur factorization of A. -C The contents of array Q is not modified if FACT = 'F'. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C if TRANS = 'N', and dimension (LDB,max(M,N)), if -C TRANS = 'T'. -C On entry, if TRANS = 'N', the leading M-by-N part of this -C array must contain the coefficient matrix B of the -C equation. -C On entry, if TRANS = 'T', the leading N-by-M part of this -C array must contain the coefficient matrix B of the -C equation. -C On exit, the leading N-by-N part of this array contains -C the upper triangular Cholesky factor U of the solution -C matrix X of the problem, X = op(U)'*op(U). -C If M = 0 and N > 0, then U is set to zero. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N,M), if TRANS = 'N'; -C LDB >= MAX(1,N), if TRANS = 'T'. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO >= 0 and INFO <= 2, WR and WI -C contain the real and imaginary parts, respectively, of -C the eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If M > 0, LDWORK >= MAX(1,4*N + MIN(M,N)); -C If M = 0, LDWORK >= 1. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DICO = 'C' this means that while the matrix A -C (or the factor S) has computed eigenvalues with -C negative real parts, it is only just stable in the -C sense that small perturbations in A can make one or -C more of the eigenvalues have a non-negative real -C part; -C if DICO = 'D' this means that while the matrix A -C (or the factor S) has computed eigenvalues inside -C the unit circle, it is nevertheless only just -C convergent, in the sense that small perturbations -C in A can make one or more of the eigenvalues lie -C outside the unit circle; -C perturbed values were used to solve the equation; -C = 2: if FACT = 'N' and DICO = 'C', but the matrix A is -C not stable (that is, one or more of the eigenvalues -C of A has a non-negative real part), or DICO = 'D', -C but the matrix A is not convergent (that is, one or -C more of the eigenvalues of A lies outside the unit -C circle); however, A will still have been factored -C and the eigenvalues of A returned in WR and WI. -C = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S -C supplied in the array A is not stable (that is, one -C or more of the eigenvalues of S has a non-negative -C real part), or DICO = 'D', but the Schur factor S -C supplied in the array A is not convergent (that is, -C one or more of the eigenvalues of S lies outside the -C unit circle); -C = 4: if FACT = 'F' and the Schur factor S supplied in -C the array A has two or more consecutive non-zero -C elements on the first sub-diagonal, so that there is -C a block larger than 2-by-2 on the diagonal; -C = 5: if FACT = 'F' and the Schur factor S supplied in -C the array A has a 2-by-2 diagonal block with real -C eigenvalues instead of a complex conjugate pair; -C = 6: if FACT = 'N' and the LAPACK Library routine DGEES -C has failed to converge. This failure is not likely -C to occur. The matrix B will be unaltered but A will -C be destroyed. -C -C METHOD -C -C The method used by the routine is based on the Bartels and Stewart -C method [1], except that it finds the upper triangular matrix U -C directly without first finding X and without the need to form the -C normal matrix op(B)'*op(B). -C -C The Schur factorization of a square matrix A is given by -C -C A = QSQ', -C -C where Q is orthogonal and S is an N-by-N block upper triangular -C matrix with 1-by-1 and 2-by-2 blocks on its diagonal (which -C correspond to the eigenvalues of A). If A has already been -C factored prior to calling the routine however, then the factors -C Q and S may be supplied and the initial factorization omitted. -C -C If TRANS = 'N', the matrix B is factored as (QR factorization) -C _ _ _ _ _ -C B = P ( R ), M >= N, B = P ( R Z ), M < N, -C ( 0 ) -C _ _ -C where P is an M-by-M orthogonal matrix and R is a square upper -C _ _ _ _ _ -C triangular matrix. Then, the matrix B = RQ, or B = ( R Z )Q (if -C M < N) is factored as -C _ _ -C B = P ( R ), M >= N, B = P ( R Z ), M < N. -C -C If TRANS = 'T', the matrix B is factored as (RQ factorization) -C _ -C _ _ ( Z ) _ -C B = ( 0 R ) P, M >= N, B = ( _ ) P, M < N, -C ( R ) -C _ _ -C where P is an M-by-M orthogonal matrix and R is a square upper -C _ _ _ _ _ -C triangular matrix. Then, the matrix B = Q'R, or B = Q'( Z' R' )' -C (if M < N) is factored as -C _ _ -C B = ( R ) P, M >= N, B = ( Z ) P, M < N. -C ( R ) -C -C These factorizations are utilised to either transform the -C continuous-time Lyapunov equation to the canonical form -C 2 -C op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F), -C -C or the discrete-time Lyapunov equation to the canonical form -C 2 -C op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F), -C -C where V and F are upper triangular, and -C -C F = R, M >= N, F = ( R Z ), M < N, if TRANS = 'N'; -C ( 0 0 ) -C -C F = R, M >= N, F = ( 0 Z ), M < N, if TRANS = 'T'. -C ( 0 R ) -C -C The transformed equation is then solved for V, from which U is -C obtained via the QR factorization of V*Q', if TRANS = 'N', or -C via the RQ factorization of Q*V, if TRANS = 'T'. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. -C Solution of the matrix equation A'X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if A is only just stable (or convergent) then the Lyapunov -C equation will be ill-conditioned. A symptom of ill-conditioning -C is "large" elements in U relative to those of A and B, or a -C "small" value for scale. A condition estimate can be computed -C using SLICOT Library routine SB03MD. -C -C SB03OD routine can be also used for solving "unstable" Lyapunov -C equations, i.e., when matrix A has all eigenvalues with positive -C real parts, if DICO = 'C', or with moduli greater than one, -C if DICO = 'D'. Specifically, one may solve for X = op(U)'*op(U) -C either the continuous-time Lyapunov equation -C 2 -C op(A)'*X + X*op(A) = scale *op(B)'*op(B), (3) -C -C or the discrete-time Lyapunov equation -C 2 -C op(A)'*X*op(A) - X = scale *op(B)'*op(B), (4) -C -C provided, for equation (3), the given matrix A is replaced by -A, -C or, for equation (4), the given matrices A and B are replaced by -C inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'T'), -C respectively. Although the inversion generally can rise numerical -C problems, in case of equation (4) it is expected that the matrix A -C is enough well-conditioned, having only eigenvalues with moduli -C greater than 1. However, if A is ill-conditioned, it could be -C preferable to use the more general SLICOT Lyapunov solver SB03MD. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB03CD by Sven Hammarling, -C NAG Ltd, United Kingdom. -C -C REVISIONS -C -C Dec. 1997, April 1998, May 1998, May 1999, Oct. 2001 (V. Sima). -C March 2002 (A. Varga). -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, TRANS - INTEGER INFO, LDA, LDB, LDQ, LDWORK, M, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), Q(LDQ,*), WI(*), - $ WR(*) -C .. Local Scalars .. - LOGICAL CONT, LTRANS, NOFACT - INTEGER I, IFAIL, INFORM, ITAU, J, JWORK, K, L, MINMN, - $ NE, SDIM, WRKOPT - DOUBLE PRECISION EMAX, TEMP -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAPY2 - EXTERNAL DLAPY2, LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DGEQRF, DGERQF, - $ DLACPY, DLASET, DTRMM, SB03OU, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - CONT = LSAME( DICO, 'C' ) - NOFACT = LSAME( FACT, 'N' ) - LTRANS = LSAME( TRANS, 'T' ) - MINMN = MIN( M, N ) -C - INFO = 0 - IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( ( LDB.LT.MAX( 1, N ) ) .OR. - $ ( LDB.LT.MAX( 1, N, M ) .AND. .NOT.LTRANS ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.1 .OR. ( M.GT.0 .AND. LDWORK.LT.4*N + MINMN ) ) - $ THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MINMN.EQ.0 ) THEN - IF( M.EQ.0 ) - $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) - SCALE = ONE - DWORK(1) = ONE - RETURN - END IF -C -C Start the solution. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( NOFACT ) THEN -C -C Find the Schur factorization of A, A = Q*S*Q'. -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, Q, LDQ, DWORK, LDWORK, BWORK, INFORM ) - IF ( INFORM.NE.0 ) THEN - INFO = 6 - RETURN - END IF - WRKOPT = DWORK(1) -C -C Check the eigenvalues for stability. -C - IF ( CONT ) THEN - EMAX = WR(1) -C - DO 20 J = 2, N - IF ( WR(J).GT.EMAX ) - $ EMAX = WR(J) - 20 CONTINUE -C - ELSE - EMAX = DLAPY2( WR(1), WI(1) ) -C - DO 40 J = 2, N - TEMP = DLAPY2( WR(J), WI(J) ) - IF ( TEMP.GT.EMAX ) - $ EMAX = TEMP - 40 CONTINUE -C - END IF -C - IF ( ( CONT ) .AND. ( EMAX.GE.ZERO ) .OR. - $ ( .NOT.CONT ) .AND. ( EMAX.GE.ONE ) ) THEN - INFO = 2 - RETURN - END IF - ELSE - WRKOPT = 0 - END IF -C -C Perform the QR or RQ factorization of B, -C _ _ _ _ _ -C B = P ( R ), or B = P ( R Z ), if TRANS = 'N', or -C ( 0 ) -C _ -C _ _ ( Z ) _ -C B = ( 0 R ) P, or B = ( _ ) P, if TRANS = 'T'. -C ( R ) -C Workspace: need MIN(M,N) + N; -C prefer MIN(M,N) + N*NB. -C - ITAU = 1 - JWORK = ITAU + MINMN - IF ( LTRANS ) THEN - CALL DGERQF( N, M, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) - JWORK = ITAU -C -C Form in B -C _ _ _ _ _ _ -C B := Q'R, m >= n, B := Q'*( Z' R' )', m < n, with B an -C n-by-min(m,n) matrix. -C Use a BLAS 3 operation if enough workspace, and BLAS 2, -C _ -C otherwise: B is formed column by column. -C - IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN - K = JWORK -C - DO 60 I = 1, MINMN - CALL DCOPY( N, Q(N-MINMN+I,1), LDQ, DWORK(K), 1 ) - K = K + N - 60 CONTINUE -C - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', - $ N, MINMN, ONE, B(N-MINMN+1,M-MINMN+1), LDB, - $ DWORK(JWORK), N ) - IF ( M.LT.N ) - $ CALL DGEMM( 'Transpose', 'No transpose', N, M, N-M, - $ ONE, Q, LDQ, B, LDB, ONE, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, MINMN, DWORK(JWORK), N, B, LDB ) - ELSE - NE = N - MINMN -C - DO 80 J = 1, MINMN - NE = NE + 1 - CALL DCOPY( NE, B(1,M-MINMN+J), 1, DWORK(JWORK), 1 ) - CALL DGEMV( 'Transpose', NE, N, ONE, Q, LDQ, - $ DWORK(JWORK), 1, ZERO, B(1,J), 1 ) - 80 CONTINUE -C - END IF - ELSE - CALL DGEQRF( M, N, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) - JWORK = ITAU -C -C Form in B -C _ _ _ _ _ _ -C B := RQ, m >= n, B := ( R Z )*Q, m < n, with B an -C min(m,n)-by-n matrix. -C Use a BLAS 3 operation if enough workspace, and BLAS 2, -C _ -C otherwise: B is formed row by row. -C - IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN - CALL DLACPY( 'Full', MINMN, N, Q, LDQ, DWORK(JWORK), MINMN ) - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', - $ MINMN, N, ONE, B, LDB, DWORK(JWORK), MINMN ) - IF ( M.LT.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', M, N, N-M, - $ ONE, B(1,M+1), LDB, Q(M+1,1), LDQ, ONE, - $ DWORK(JWORK), MINMN ) - CALL DLACPY( 'Full', MINMN, N, DWORK(JWORK), MINMN, B, LDB ) - ELSE - NE = MINMN + MAX( 0, N-M ) -C - DO 100 J = 1, MINMN - CALL DCOPY( NE, B(J,J), LDB, DWORK(JWORK), 1 ) - CALL DGEMV( 'Transpose', NE, N, ONE, Q(J,1), LDQ, - $ DWORK(JWORK), 1, ZERO, B(J,1), LDB ) - NE = NE - 1 - 100 CONTINUE -C - END IF - END IF - JWORK = ITAU + MINMN -C -C Solve for U the transformed Lyapunov equation -C 2 _ _ -C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(B)'*op(B), -C -C or -C 2 _ _ -C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(B)'*op(B) -C -C Workspace: need MIN(M,N) + 4*N; -C prefer larger. -C - CALL SB03OU( .NOT.CONT, LTRANS, N, MINMN, A, LDA, B, LDB, - $ DWORK(ITAU), B, LDB, SCALE, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - IF ( INFO.GT.1 ) THEN - INFO = INFO + 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = ITAU -C -C Form U := U*Q' or U := Q*U in the array B. -C Use a BLAS 3 operation if enough workspace, and BLAS 2, otherwise. -C Workspace: need N; -C prefer N*N; -C - IF ( LDWORK.GE.JWORK+N*N-1 ) THEN - IF ( LTRANS ) THEN - CALL DLACPY( 'Full', N, N, Q, LDQ, DWORK(JWORK), N ) - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, - $ N, ONE, B, LDB, DWORK(JWORK), N ) - ELSE - K = JWORK -C - DO 120 I = 1, N - CALL DCOPY( N, Q(1,I), 1, DWORK(K), N ) - K = K + 1 - 120 CONTINUE -C - CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ N, ONE, B, LDB, DWORK(JWORK), N ) - END IF - CALL DLACPY( 'Full', N, N, DWORK(JWORK), N, B, LDB ) - WRKOPT = MAX( WRKOPT, JWORK + N*N - 1 ) - ELSE - IF ( LTRANS ) THEN -C -C U is formed column by column ( U := Q*U ). -C - DO 140 I = 1, N - CALL DCOPY( I, B(1,I), 1, DWORK(JWORK), 1 ) - CALL DGEMV( 'No transpose', N, I, ONE, Q, LDQ, - $ DWORK(JWORK), 1, ZERO, B(1,I), 1 ) - 140 CONTINUE - ELSE -C -C U is formed row by row ( U' := Q*U' ). -C - DO 160 I = 1, N - CALL DCOPY( N-I+1, B(I,I), LDB, DWORK(JWORK), 1 ) - CALL DGEMV( 'No transpose', N, N-I+1, ONE, Q(1,I), LDQ, - $ DWORK(JWORK), 1, ZERO, B(I,1), LDB ) - 160 CONTINUE - END IF - END IF -C -C Lastly find the QR or RQ factorization of U, overwriting on B, -C to give the required Cholesky factor. -C Workspace: need 2*N; -C prefer N + N*NB; -C - JWORK = ITAU + N - IF ( LTRANS ) THEN - CALL DGERQF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - ELSE - CALL DGEQRF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Make the diagonal elements of U non-negative. -C - IF ( LTRANS ) THEN -C - DO 200 J = 1, N - IF ( B(J,J).LT.ZERO ) THEN -C - DO 180 I = 1, J - B(I,J) = -B(I,J) - 180 CONTINUE -C - END IF - 200 CONTINUE -C - ELSE - K = JWORK -C - DO 240 J = 1, N - DWORK(K) = B(J,J) - L = JWORK -C - DO 220 I = 1, J - IF ( DWORK(L).LT.ZERO ) B(I,J) = -B(I,J) - L = L + 1 - 220 CONTINUE -C - K = K + 1 - 240 CONTINUE - END IF -C - IF( N.GT.1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) -C -C Set the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB03OD *** - END diff --git a/slycot/src/SB03OR.f b/slycot/src/SB03OR.f deleted file mode 100644 index 1094f26f..00000000 --- a/slycot/src/SB03OR.f +++ /dev/null @@ -1,429 +0,0 @@ - SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the solution of the Sylvester equations -C -C op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE. or -C -C op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE. -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), S is -C an N-by-N block upper triangular matrix with one-by-one and -C two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or -C M = 2), X and C are each N-by-M matrices, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C The solution X is overwritten on C. -C -C SB03OR is a service routine for the Lyapunov solver SB03OT. -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the equation to be solved: -C = .FALSE.: op(S)'*X + X*op(A) = scale*C; -C = .TRUE. : op(S)'*X*op(A) - X = scale*C. -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix S and also the number of rows of -C matrices X and C. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A and also the number of columns -C of matrices X and C. M = 1 or M = 2. -C -C S (input) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper Hessenberg part of the array S -C must contain the block upper triangular matrix. The -C elements below the upper Hessenberg part of the array S -C are not referenced. The array S must not contain -C diagonal blocks larger than two-by-two and the two-by-two -C blocks must only correspond to complex conjugate pairs of -C eigenvalues, not to real eigenvalues. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C A (input) DOUBLE PRECISION array, dimension (LDS,M) -C The leading M-by-M part of this array must contain a -C given matrix, where M = 1 or M = 2. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= M. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, C must contain an N-by-M matrix, where M = 1 or -C M = 2. -C On exit, C contains the N-by-M matrix X, the solution of -C the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if DISCR = .FALSE., and S and -A have common -C eigenvalues, or if DISCR = .TRUE., and S and A have -C eigenvalues whose product is equal to unity; -C a solution has been computed using slightly -C perturbed values. -C -C METHOD -C -C The LAPACK scheme for solving Sylvester equations is adapted. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 2 -C The algorithm requires 0(N M) operations and is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routines SB03CW and SB03CX by -C Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986. -C Partly based on routine PLYAP4 by A. Varga, University of Bochum, -C May 1992. -C -C REVISIONS -C -C December 1997, April 1998, May 1999, April 2000. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, LDA, LDS, LDC, M, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( LDS, * ) -C .. Local Scalars .. - LOGICAL TBYT - INTEGER DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT - DOUBLE PRECISION G11, G12, G21, G22, SCALOC, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. -C .. External Subroutines .. - EXTERNAL DLASY2, DSCAL, SB04PX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN - INFO = -4 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.M ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OR', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N.EQ.0 ) - $ RETURN -C - ISGN = 1 - TBYT = M.EQ.2 - INFOM = 0 -C -C Construct A'. -C - AT(1,1) = A(1,1) - IF ( TBYT ) THEN - AT(1,2) = A(2,1) - AT(2,1) = A(1,2) - AT(2,2) = A(2,2) - END IF -C - IF ( LTRANS ) THEN -C -C Start row loop (index = L). -C L1 (L2) : row index of the first (last) row of X(L). -C - LNEXT = N -C - DO 20 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 20 - L1 = L - L2 = L - IF( L.GT.1 ) THEN - IF( S( L, L-1 ).NE.ZERO ) - $ L1 = L1 - 1 - LNEXT = L1 - 1 - END IF - DL = L2 - L1 + 1 - L2P1 = MIN( L2+1, N ) -C - IF ( DISCR ) THEN -C -C Solve S*X*A' - X = scale*C. -C -C The L-th block of X is determined from -C -C S(L,L)*X(L)*A' - X(L) = C(L) - R(L), -C -C where -C -C N -C R(L) = SUM [S(L,J)*X(J)] * A' . -C J=L+1 -C - G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 ) - IF ( TBYT ) THEN - G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ), - $ 1 ) - VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1) - VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2) - ELSE - VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1) - END IF - IF ( DL.NE.1 ) THEN - G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ), - $ 1 ) - IF ( TBYT ) THEN - G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS, - $ C( L2P1, 2 ), 1 ) - VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + - $ G22*AT(2,1) - VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) + - $ G22*AT(2,2) - ELSE - VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) - END IF - END IF - CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ), - $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, - $ INFO ) - ELSE -C -C Solve S*X + X*A' = scale*C. -C -C The L-th block of X is determined from -C -C S(L,L)*X(L) + X(L)*A' = C(L) - R(L), -C -C where -C N -C R(L) = SUM S(L,J)*X(J) . -C J=L+1 -C - VEC( 1, 1 ) = C( L1, 1 ) - - $ DDOT( N-L2, S( L1, L2P1 ), LDS, - $ C( L2P1, 1 ), 1 ) - IF ( TBYT ) - $ VEC( 1, 2 ) = C( L1, 2 ) - - $ DDOT( N-L2, S( L1, L2P1 ), LDS, - $ C( L2P1, 2 ), 1 ) -C - IF ( DL.NE.1 ) THEN - VEC( 2, 1 ) = C( L2, 1 ) - - $ DDOT( N-L2, S( L2, L2P1 ), LDS, - $ C( L2P1, 1 ), 1 ) - IF ( TBYT ) - $ VEC( 2, 2 ) = C( L2, 2 ) - - $ DDOT( N-L2, S( L2, L2P1 ), LDS, - $ C( L2P1, 2 ), 1 ) - END IF - CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ), - $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, - $ INFO ) - END IF - INFOM = MAX( INFO, INFOM ) - IF ( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, M - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( L1, 1 ) = X( 1, 1 ) - IF ( TBYT ) C( L1, 2 ) = X( 1, 2 ) - IF ( DL.NE.1 ) THEN - C( L2, 1 ) = X( 2, 1 ) - IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) - END IF - 20 CONTINUE -C - ELSE -C -C Start row loop (index = L). -C L1 (L2) : row index of the first (last) row of X(L). -C - LNEXT = 1 -C - DO 40 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 40 - L1 = L - L2 = L - IF( L.LT.N ) THEN - IF( S( L+1, L ).NE.ZERO ) - $ L2 = L2 + 1 - LNEXT = L2 + 1 - END IF - DL = L2 - L1 + 1 -C - IF ( DISCR ) THEN -C -C Solve A'*X'*S - X' = scale*C'. -C -C The L-th block of X is determined from -C -C A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L), -C -C where -C -C L-1 -C R(L) = A' * SUM [X(J)'*S(J,L)] . -C J=1 -C - G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) - IF ( TBYT ) THEN - G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 ) - VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21 - VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21 - ELSE - VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 - END IF - IF ( DL .NE. 1 ) THEN - G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) - IF ( TBYT ) THEN - G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 ) - VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + - $ AT(1,2)*G22 - VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 + - $ AT(2,2)*G22 - ELSE - VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 - END IF - END IF - CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2, - $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, - $ XNORM, INFO ) - ELSE -C -C Solve A'*X' + X'*S = scale*C'. -C -C The L-th block of X is determined from -C -C A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L), -C -C where -C L-1 -C R(L) = SUM [X(J)'*S(J,L)]. -C J=1 -C - VEC( 1, 1 ) = C( L1, 1 ) - - $ DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) - IF ( TBYT ) - $ VEC( 2, 1 ) = C( L1, 2 ) - - $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1) -C - IF ( DL.NE.1 ) THEN - VEC( 1, 2 ) = C( L2, 1 ) - - $ DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) - IF ( TBYT ) - $ VEC( 2, 2 ) = C( L2, 2 ) - - $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1) - END IF - CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2, - $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, - $ XNORM, INFO ) - END IF - INFOM = MAX( INFO, INFOM ) - IF ( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, M - CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - C( L1, 1 ) = X( 1, 1 ) - IF ( TBYT ) C( L1, 2 ) = X( 2, 1 ) - IF ( DL.NE.1 ) THEN - C( L2, 1 ) = X( 1, 2 ) - IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) - END IF - 40 CONTINUE - END IF -C - INFO = INFOM - RETURN -C *** Last line of SB03OR *** - END diff --git a/slycot/src/SB03OT.f b/slycot/src/SB03OT.f deleted file mode 100644 index 92550bf5..00000000 --- a/slycot/src/SB03OT.f +++ /dev/null @@ -1,984 +0,0 @@ - SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)'*op(U) either the stable non-negative -C definite continuous-time Lyapunov equation -C 2 -C op(S)'*X + X*op(S) = -scale *op(R)'*op(R) (1) -C -C or the convergent non-negative definite discrete-time Lyapunov -C equation -C 2 -C op(S)'*X*op(S) - X = -scale *op(R)'*op(R) (2) -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), S is -C an N-by-N block upper triangular matrix with one-by-one or -C two-by-two blocks on the diagonal, R is an N-by-N upper triangular -C matrix, and scale is an output scale factor, set less than or -C equal to 1 to avoid overflow in X. -C -C In the case of equation (1) the matrix S must be stable (that -C is, all the eigenvalues of S must have negative real parts), -C and for equation (2) the matrix S must be convergent (that is, -C all the eigenvalues of S must lie inside the unit circle). -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the type of Lyapunov equation to be solved as -C follows: -C = .TRUE. : Equation (2), discrete-time case; -C = .FALSE.: Equation (1), continuous-time case. -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices S and R. N >= 0. -C -C S (input) DOUBLE PRECISION array of dimension (LDS,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the block upper triangular matrix. -C The elements below the upper Hessenberg part of the array -C S are not referenced. The 2-by-2 blocks must only -C correspond to complex conjugate pairs of eigenvalues (not -C to real eigenvalues). -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N). -C -C R (input/output) DOUBLE PRECISION array of dimension (LDR,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the upper triangular matrix R. -C On exit, the leading N-by-N upper triangular part of this -C array contains the upper triangular matrix U. -C The strict lower triangle of R is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (4*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DISCR = .FALSE., this means that while the -C matrix S has computed eigenvalues with negative real -C parts, it is only just stable in the sense that -C small perturbations in S can make one or more of the -C eigenvalues have a non-negative real part; -C if DISCR = .TRUE., this means that while the -C matrix S has computed eigenvalues inside the unit -C circle, it is nevertheless only just convergent, in -C the sense that small perturbations in S can make one -C or more of the eigenvalues lie outside the unit -C circle; -C perturbed values were used to solve the equation -C (but the matrix S is unchanged); -C = 2: if the matrix S is not stable (that is, one or more -C of the eigenvalues of S has a non-negative real -C part), if DISCR = .FALSE., or not convergent (that -C is, one or more of the eigenvalues of S lies outside -C the unit circle), if DISCR = .TRUE.; -C = 3: if the matrix S has two or more consecutive non-zero -C elements on the first sub-diagonal, so that there is -C a block larger than 2-by-2 on the diagonal; -C = 4: if the matrix S has a 2-by-2 diagonal block with -C real eigenvalues instead of a complex conjugate -C pair. -C -C METHOD -C -C The method used by the routine is based on a variant of the -C Bartels and Stewart backward substitution method [1], that finds -C the Cholesky factor op(U) directly without first finding X and -C without the need to form the normal matrix op(R)'*op(R) [2]. -C -C The continuous-time Lyapunov equation in the canonical form -C 2 -C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R), -C -C or the discrete-time Lyapunov equation in the canonical form -C 2 -C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R), -C -C where U and R are upper triangular, is solved for U. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. -C Solution of the matrix equation A'X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular -C if S is only just stable (or convergent) then the Lyapunov -C equation will be ill-conditioned. "Large" elements in U relative -C to those of S and R, or a "small" value for scale, is a symptom -C of ill-conditioning. A condition estimate can be computed using -C SLICOT Library routine SB03MD. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, -C NAG Ltd, United Kingdom, Oct. 1986. -C Partly based on SB03CZ and PLYAP1 by A. Varga, University of -C Bochum, May 1992. -C -C REVISIONS -C -C Dec. 1997, April 1998, May 1999, Feb. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, LDR, LDS, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL CONT, TBYT - INTEGER INFOM, ISGN, J, J1, J2, J3, K, K1, K2, K3, - $ KOUNT, KSIZE - DOUBLE PRECISION ABSSKK, ALPHA, BIGNUM, D1, D2, DR, EPS, SCALOC, - $ SMIN, SMLNUM, SUM, T1, T2, T3, T4, TAU1, TAU2, - $ TEMP, V1, V2, V3, V4 -C .. Local Arrays .. - DOUBLE PRECISION A(2,2), B(2,2), U(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLABAD, DLARFG, DSCAL, DSWAP, - $ DTRMM, DTRMV, MB04ND, MB04OD, SB03OR, SB03OY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OT', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF (N.EQ.0) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( N*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, S, LDS, DWORK ) ) - INFOM = 0 -C -C Start the solution. Most of the comments refer to notation and -C equations in sections 5 and 10 of the second reference above. -C -C Determine whether or not the current block is two-by-two. -C K gives the position of the start of the current block and -C TBYT is true if the block is two-by-two. -C - CONT = .NOT.DISCR - ISGN = 1 - IF ( .NOT.LTRANS ) THEN -C -C Case op(M) = M. -C - KOUNT = 1 -C - 10 CONTINUE -C WHILE( KOUNT.LE.N )LOOP - IF ( KOUNT.LE.N ) THEN - K = KOUNT - IF ( KOUNT.GE.N ) THEN - TBYT = .FALSE. - KOUNT = KOUNT + 1 - ELSE IF ( S(K+1,K).EQ.ZERO ) THEN - TBYT = .FALSE. - KOUNT = KOUNT + 1 - ELSE - TBYT = .TRUE. - IF ( (K+1).LT.N ) THEN - IF ( S(K+2,K+1).NE.ZERO ) THEN - INFO = 3 - RETURN - END IF - END IF - KOUNT = KOUNT + 2 - END IF - IF ( TBYT ) THEN -C -C Solve the two-by-two Lyapunov equation (6.1) or (10.19), -C using the routine SB03OY. -C - B(1,1) = S(K,K) - B(2,1) = S(K+1,K) - B(1,2) = S(K,K+1) - B(2,2) = S(K+1,K+1) - U(1,1) = R(K,K) - U(1,2) = R(K,K+1) - U(2,2) = R(K+1,K+1) -C - CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, - $ SCALOC, INFO ) - IF ( INFO.GT.1 ) - $ RETURN - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 20 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - R(K,K) = U(1,1) - R(K,K+1) = U(1,2) - R(K+1,K+1) = U(2,2) -C -C If we are not at the end of S then set up and solve -C equation (6.2) or (10.20). -C -C Note that SB03OY returns ( u11*s11*inv( u11 ) ) in B -C and returns scaled alpha in A. ksize is the order of -C the remainder of S. k1, k2 and k3 point to the start -C of vectors in DWORK. -C - IF ( KOUNT.LE.N ) THEN - KSIZE = N - K - 1 - K1 = KSIZE + 1 - K2 = KSIZE + K1 - K3 = KSIZE + K2 -C -C Form the right-hand side of (6.2) or (10.20), the -C first column in DWORK( 1 ) ,..., DWORK( n - k - 1 ) -C the second in DWORK( n - k ) ,..., -C DWORK( 2*( n - k - 1 ) ). -C - CALL DCOPY( KSIZE, R(K,K+2), LDR, DWORK, 1 ) - CALL DCOPY( KSIZE, R(K+1,K+2), LDR, DWORK(K1), 1 ) - CALL DTRMM( 'Right', 'Upper', 'No transpose', - $ 'Non-unit', KSIZE, 2, -ONE, A, 2, DWORK, - $ KSIZE ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(K,K+2), LDS, DWORK, - $ 1 ) - CALL DAXPY( KSIZE, -R(K,K+1), S(K+1,K+2), LDS, - $ DWORK, 1) - CALL DAXPY( KSIZE, -R(K+1,K+1), S(K+1,K+2), LDS, - $ DWORK(K1), 1 ) - ELSE - CALL DAXPY( KSIZE, -R(K,K)*B(1,1), S(K,K+2), LDS, - $ DWORK, 1 ) - CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,1) + R(K+1,K+1) - $ *B(2,1) ), S(K+1,K+2), LDS, DWORK, 1 ) - CALL DAXPY( KSIZE, -R(K,K)*B(1,2), S(K,K+2), LDS, - $ DWORK(K1), 1 ) - CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,2) + R(K+1,K+1) - $ *B(2,2) ), S(K+1,K+2), LDS, DWORK(K1), - $ 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution -C is overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S(K+2,K+2), LDS, - $ B, 2, DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 30 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next 2*( n - k - 1 ) -C elements of DWORK. -C - CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) -C -C Now form the matrix Rhat of equation (6.4) or -C (10.22). Note that (10.22) is incorrect, so here we -C implement a corrected version of (10.22). -C - IF ( CONT ) THEN -C -C Swap the two rows of R with DWORK. -C - CALL DSWAP( KSIZE, DWORK, 1, R(K,K+2), LDR ) - CALL DSWAP( KSIZE, DWORK(K1), 1, R(K+1,K+2), LDR ) -C -C 1st column: -C - CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, - $ 1 ) - CALL DAXPY( KSIZE, -A(1,2), DWORK(K3), 1, DWORK, - $ 1 ) -C -C 2nd column: -C - CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, - $ DWORK(K1), 1 ) - ELSE -C -C Form v = S1'*u + s*u11', overwriting v on DWORK. -C -C Compute S1'*u, first multiplying by the -C triangular part of S1. -C - CALL DTRMM( 'Left', 'Upper', 'Transpose', - $ 'Non-unit', KSIZE, 2, ONE, S(K+2,K+2), - $ LDS, DWORK, KSIZE ) -C -C Then multiply by the subdiagonal of S1 and add in -C to the above result. -C - J1 = K1 - J2 = K + 2 -C - DO 40 J = 1, KSIZE-1 - IF ( S(J2+1,J2).NE.ZERO ) THEN - DWORK(J) = S(J2+1,J2)*DWORK(K2+J) + DWORK(J) - DWORK(J1) = S(J2+1,J2)*DWORK(K3+J) + - $ DWORK(J1) - END IF - J1 = J1 + 1 - J2 = J2 + 1 - 40 CONTINUE -C -C Add in s*u11'. -C - CALL DAXPY( KSIZE, R(K,K), S(K,K+2), LDS, DWORK, - $ 1 ) - CALL DAXPY( KSIZE, R(K,K+1), S(K+1,K+2), LDS, - $ DWORK, 1 ) - CALL DAXPY( KSIZE, R(K+1,K+1), S(K+1,K+2), LDS, - $ DWORK(K1), 1 ) -C -C Next recover r from R, swapping r with u. -C - CALL DSWAP( KSIZE, DWORK(K2), 1, R(K,K+2), LDR ) - CALL DSWAP( KSIZE, DWORK(K3), 1, R(K+1,K+2), LDR ) -C -C Now we perform the QR factorization. -C -C ( a ) = Q*( t ), -C ( b ) -C -C and form -C -C ( p' ) = Q'*( r' ). -C ( y' ) ( v' ) -C -C y is then the correct vector to use in (10.22). -C Note that a is upper triangular and that t and -C p are not required. -C - CALL DLARFG( 3, A(1,1), B(1,1), 1, TAU1 ) - V1 = B(1,1) - T1 = TAU1*V1 - V2 = B(2,1) - T2 = TAU1*V2 - SUM = A(1,2) + V1*B(1,2) + V2*B(2,2) - B(1,2) = B(1,2) - SUM*T1 - B(2,2) = B(2,2) - SUM*T2 - CALL DLARFG( 3, A(2,2), B(1,2), 1, TAU2 ) - V3 = B(1,2) - T3 = TAU2*V3 - V4 = B(2,2) - T4 = TAU2*V4 - J1 = K1 - J2 = K2 - J3 = K3 -C - DO 50 J = 1, KSIZE - SUM = DWORK(J2) + V1*DWORK(J) + V2*DWORK(J1) - D1 = DWORK(J) - SUM*T1 - D2 = DWORK(J1) - SUM*T2 - SUM = DWORK(J3) + V3*D1 + V4*D2 - DWORK(J) = D1 - SUM*T3 - DWORK(J1) = D2 - SUM*T4 - J1 = J1 + 1 - J2 = J2 + 1 - J3 = J3 + 1 - 50 CONTINUE -C - END IF -C -C Now update R1 to give Rhat. -C - CALL DCOPY( KSIZE, DWORK, 1, DWORK(K2), 1 ) - CALL DCOPY( KSIZE, DWORK(K1), 1, DWORK(K3), 1 ) - CALL DCOPY( KSIZE, DWORK(K3), 1, DWORK(2), 2 ) - CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 ) - CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR, - $ DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K3) ) - END IF - ELSE -C -C 1-by-1 block. -C -C Make sure S is stable or convergent and find u11 in -C equation (5.13) or (10.15). -C - IF ( DISCR ) THEN - ABSSKK = ABS( S(K,K) ) - IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) - ELSE - IF ( S(K,K).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ABS( TWO*S(K,K) ) ) - END IF -C - SCALOC = ONE - IF( TEMP.LT.SMIN ) THEN - TEMP = SMIN - INFOM = 1 - END IF - DR = ABS( R(K,K) ) - IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN - IF( DR.GT.BIGNUM*TEMP ) - $ SCALOC = ONE / DR - END IF - ALPHA = SIGN( TEMP, R(K,K) ) - R(K,K) = R(K,K)/ALPHA - IF( SCALOC.NE.ONE ) THEN -C - DO 60 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 60 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C If we are not at the end of S then set up and solve -C equation (5.14) or (10.16). ksize is the order of the -C remainder of S. k1 and k2 point to the start of vectors -C in DWORK. -C - IF ( KOUNT.LE.N ) THEN - KSIZE = N - K - K1 = KSIZE + 1 - K2 = KSIZE + K1 -C -C Form the right-hand side in DWORK( 1 ),..., -C DWORK( n - k ). -C - CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 ) - CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK, - $ 1 ) - ELSE - CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS, - $ DWORK, 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution is -C overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS, - $ S(K,K), 1, DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 70 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next ( n - k ) elements -C of DWORK, copy the solution back into R and copy -C the row of R back into DWORK. -C - CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) - CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR ) -C -C Now form the matrix Rhat of equation (5.15) or -C (10.17), first computing y in DWORK, and then -C updating R1. -C - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) - ELSE -C -C First form lambda( 1 )*r and then add in -C alpha*u11*s. -C - CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) - CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS, - $ DWORK, 1 ) -C -C Now form alpha*S1'*u, first multiplying by the -C sub-diagonal of S1 and then the triangular part -C of S1, and add the result in DWORK. -C - J1 = K + 1 -C - DO 80 J = 1, KSIZE-1 - IF ( S(J1+1,J1).NE.ZERO ) DWORK(J) - $ = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J) - J1 = J1 + 1 - 80 CONTINUE -C - CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', - $ KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 ) - CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) - END IF - CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR, - $ DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K1) ) - END IF - END IF - GO TO 10 - END IF -C END WHILE 10 -C - ELSE -C -C Case op(M) = M'. -C - KOUNT = N -C - 90 CONTINUE -C WHILE( KOUNT.GE.1 )LOOP - IF ( KOUNT.GE.1 ) THEN - K = KOUNT - IF ( KOUNT.EQ.1 ) THEN - TBYT = .FALSE. - KOUNT = KOUNT - 1 - ELSE IF ( S(K,K-1).EQ.ZERO ) THEN - TBYT = .FALSE. - KOUNT = KOUNT - 1 - ELSE - TBYT = .TRUE. - K = K - 1 - IF ( K.GT.1 ) THEN - IF ( S(K,K-1).NE.ZERO ) THEN - INFO = 3 - RETURN - END IF - END IF - KOUNT = KOUNT - 2 - END IF - IF ( TBYT ) THEN -C -C Solve the two-by-two Lyapunov equation corresponding to -C (6.1) or (10.19), using the routine SB03OY. -C - B(1,1) = S(K,K) - B(2,1) = S(K+1,K) - B(1,2) = S(K,K+1) - B(2,2) = S(K+1,K+1) - U(1,1) = R(K,K) - U(1,2) = R(K,K+1) - U(2,2) = R(K+1,K+1) -C - CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, - $ SCALOC, INFO ) - IF ( INFO.GT.1 ) - $ RETURN - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 100 CONTINUE -C - SCALE = SCALE*SCALOC - END IF - R(K,K) = U(1,1) - R(K,K+1) = U(1,2) - R(K+1,K+1) = U(2,2) -C -C If we are not at the front of S then set up and solve -C equation corresponding to (6.2) or (10.20). -C -C Note that SB03OY returns ( inv( u11 )*s11*u11 ) in B -C and returns scaled alpha, alpha = inv( u11 )*r11, in A. -C ksize is the order of the remainder leading part of S. -C k1, k2 and k3 point to the start of vectors in DWORK. -C - IF ( KOUNT.GE.1 ) THEN - KSIZE = K - 1 - K1 = KSIZE + 1 - K2 = KSIZE + K1 - K3 = KSIZE + K2 -C -C Form the right-hand side of equations corresponding to -C (6.2) or (10.20), the first column in DWORK( 1 ) ,..., -C DWORK( k - 1 ) the second in DWORK( k ) ,..., -C DWORK( 2*( k - 1 ) ). -C - CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) - CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ KSIZE, 2, -ONE, A, 2, DWORK, KSIZE ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) - CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1), - $ 1 ) - CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1, - $ DWORK(K1), 1 ) - ELSE - CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1) - $ *B(1,2) ), S(1,K), 1, DWORK, 1 ) - CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1, - $ DWORK, 1 ) - CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1) - $ *B(2,2) ), S(1,K), 1, DWORK(K1), 1 ) - CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1, - $ DWORK(K1), 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution -C is overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2, - $ DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 110 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 110 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next 2*( k - 1 ) elements -C of DWORK. -C - CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) -C -C Now form the matrix Rhat of equation corresponding -C to (6.4) or (10.22) (corrected version). -C - IF ( CONT ) THEN -C -C Swap the two columns of R with DWORK. -C - CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) - CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 ) -C -C 1st column: -C - CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, - $ 1 ) -C -C 2nd column: -C - CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1, - $ DWORK(K1), 1 ) - CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, - $ DWORK(K1), 1 ) - ELSE -C -C Form v = S1*u + s*u11, overwriting v on DWORK. -C -C Compute S1*u, first multiplying by the triangular -C part of S1. -C - CALL DTRMM( 'Left', 'Upper', 'No transpose', - $ 'Non-unit', KSIZE, 2, ONE, S, LDS, - $ DWORK, KSIZE ) -C -C Then multiply by the subdiagonal of S1 and add in -C to the above result. -C - J1 = K1 -C - DO 120 J = 2, KSIZE - J1 = J1 + 1 - IF ( S(J,J-1).NE.ZERO ) THEN - DWORK(J) = S(J,J-1)*DWORK(K2+J-2) + DWORK(J) - DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) + - $ DWORK(J1) - END IF - 120 CONTINUE -C -C Add in s*u11. -C - CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 ) - CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1), - $ 1 ) - CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1, - $ DWORK(K1), 1 ) -C -C Next recover r from R, swapping r with u. -C - CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 ) - CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 ) -C -C Now we perform the QL factorization. -C -C ( a' ) = Q*( t ), -C ( b' ) -C -C and form -C -C ( p' ) = Q'*( r' ). -C ( y' ) ( v' ) -C -C y is then the correct vector to use in the -C relation corresponding to (10.22). -C Note that a is upper triangular and that t and -C p are not required. -C - CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 ) - V1 = B(2,1) - T1 = TAU1*V1 - V2 = B(2,2) - T2 = TAU1*V2 - SUM = A(1,2) + V1*B(1,1) + V2*B(1,2) - B(1,1) = B(1,1) - SUM*T1 - B(1,2) = B(1,2) - SUM*T2 - CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 ) - V3 = B(1,1) - T3 = TAU2*V3 - V4 = B(1,2) - T4 = TAU2*V4 - J1 = K1 - J2 = K2 - J3 = K3 -C - DO 130 J = 1, KSIZE - SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1) - D1 = DWORK(J) - SUM*T1 - D2 = DWORK(J1) - SUM*T2 - SUM = DWORK(J2) + V3*D1 + V4*D2 - DWORK(J) = D1 - SUM*T3 - DWORK(J1) = D2 - SUM*T4 - J1 = J1 + 1 - J2 = J2 + 1 - J3 = J3 + 1 - 130 CONTINUE -C - END IF -C -C Now update R1 to give Rhat. -C - CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK, - $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K3) ) - END IF - ELSE -C -C 1-by-1 block. -C -C Make sure S is stable or convergent and find u11 in -C equation corresponding to (5.13) or (10.15). -C - IF ( DISCR ) THEN - ABSSKK = ABS( S(K,K) ) - IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) - ELSE - IF ( S(K,K).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - TEMP = SQRT( ABS( TWO*S(K,K) ) ) - END IF -C - SCALOC = ONE - IF( TEMP.LT.SMIN ) THEN - TEMP = SMIN - INFOM = 1 - END IF - DR = ABS( R(K,K) ) - IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN - IF( DR.GT.BIGNUM*TEMP ) - $ SCALOC = ONE / DR - END IF - ALPHA = SIGN( TEMP, R(K,K) ) - R(K,K) = R(K,K)/ALPHA - IF( SCALOC.NE.ONE ) THEN -C - DO 140 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 140 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C If we are not at the front of S then set up and solve -C equation corresponding to (5.14) or (10.16). ksize is -C the order of the remainder leading part of S. k1 and k2 -C point to the start of vectors in DWORK. -C - IF ( KOUNT.GE.1 ) THEN - KSIZE = K - 1 - K1 = KSIZE + 1 - K2 = KSIZE + K1 -C -C Form the right-hand side in DWORK( 1 ),..., -C DWORK( k - 1 ). -C - CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) - CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) - ELSE - CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1, - $ DWORK, 1 ) - END IF -C -C SB03OR solves the Sylvester equations. The solution is -C overwritten on DWORK. -C - CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K), - $ 1, DWORK, KSIZE, SCALOC, INFO ) - INFOM = MAX( INFO, INFOM ) - IF( SCALOC.NE.ONE ) THEN -C - DO 150 J = 1, N - CALL DSCAL( J, SCALOC, R(1,J), 1 ) - 150 CONTINUE -C - SCALE = SCALE*SCALOC - END IF -C -C Copy the solution into the next ( k - 1 ) elements -C of DWORK, copy the solution back into R and copy -C the column of R back into DWORK. -C - CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) - CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) -C -C Now form the matrix Rhat of equation corresponding -C to (5.15) or (10.17), first computing y in DWORK, -C and then updating R1. -C - IF ( CONT ) THEN - CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) - ELSE -C -C First form lambda( 1 )*r and then add in -C alpha*u11*s. -C - CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) - CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK, - $ 1 ) -C -C Now form alpha*S1*u, first multiplying by the -C sub-diagonal of S1 and then the triangular part -C of S1, and add the result in DWORK. -C - DO 160 J = 2, KSIZE - IF ( S(J,J-1).NE.ZERO ) DWORK(J) - $ = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J) - 160 CONTINUE -C - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', - $ KSIZE, S, LDS, DWORK(K1), 1 ) - CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) - END IF - CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK, - $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), - $ DWORK(K1) ) - END IF - END IF - GO TO 90 - END IF -C END WHILE 90 -C - END IF - INFO = INFOM - RETURN -C *** Last line of SB03OT *** - END diff --git a/slycot/src/SB03OU.f b/slycot/src/SB03OU.f deleted file mode 100644 index d9ae8cb1..00000000 --- a/slycot/src/SB03OU.f +++ /dev/null @@ -1,410 +0,0 @@ - SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U, - $ LDU, SCALE, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)'*op(U) either the stable non-negative -C definite continuous-time Lyapunov equation -C 2 -C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) -C -C or the convergent non-negative definite discrete-time Lyapunov -C equation -C 2 -C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) -C -C where op(K) = K or K' (i.e., the transpose of the matrix K), A is -C an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix, -C U is an upper triangular matrix containing the Cholesky factor of -C the solution matrix X, X = op(U)'*op(U), and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C If matrix B has full rank then the solution matrix X will be -C positive-definite and hence the Cholesky factor U will be -C nonsingular, but if B is rank deficient then X may only be -C positive semi-definite and U will be singular. -C -C In the case of equation (1) the matrix A must be stable (that -C is, all the eigenvalues of A must have negative real parts), -C and for equation (2) the matrix A must be convergent (that is, -C all the eigenvalues of A must lie inside the unit circle). -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the type of Lyapunov equation to be solved as -C follows: -C = .TRUE. : Equation (2), discrete-time case; -C = .FALSE.: Equation (1), continuous-time case. -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A and the number of columns in -C matrix op(B). N >= 0. -C -C M (input) INTEGER -C The number of rows in matrix op(B). M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain a real Schur form matrix S. The elements -C below the upper Hessenberg part of the array A are not -C referenced. The 2-by-2 blocks must only correspond to -C complex conjugate pairs of eigenvalues (not to real -C eigenvalues). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C if LTRANS = .FALSE., and dimension (LDB,M), if -C LTRANS = .TRUE.. -C On entry, if LTRANS = .FALSE., the leading M-by-N part of -C this array must contain the coefficient matrix B of the -C equation. -C On entry, if LTRANS = .TRUE., the leading N-by-M part of -C this array must contain the coefficient matrix B of the -C equation. -C On exit, if LTRANS = .FALSE., the leading -C MIN(M,N)-by-MIN(M,N) upper triangular part of this array -C contains the upper triangular matrix R (as defined in -C METHOD), and the M-by-MIN(M,N) strictly lower triangular -C part together with the elements of the array TAU are -C overwritten by details of the matrix P (also defined in -C METHOD). When M < N, columns (M+1),...,N of the array B -C are overwritten by the matrix Z (see METHOD). -C On exit, if LTRANS = .TRUE., the leading -C MIN(M,N)-by-MIN(M,N) upper triangular part of -C B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N, -C contains the upper triangular matrix R (as defined in -C METHOD), and the remaining elements (below the diagonal -C of R) together with the elements of the array TAU are -C overwritten by details of the matrix P (also defined in -C METHOD). When M < N, rows 1,...,(N-M) of the array B -C are overwritten by the matrix Z (see METHOD). -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,M), if LTRANS = .FALSE., -C LDB >= MAX(1,N), if LTRANS = .TRUE.. -C -C TAU (output) DOUBLE PRECISION array of dimension (MIN(N,M)) -C This array contains the scalar factors of the elementary -C reflectors defining the matrix P. -C -C U (output) DOUBLE PRECISION array of dimension (LDU,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor of the solution matrix X of -C the problem, X = op(U)'*op(U). -C The array U may be identified with B in the calling -C statement, if B is properly dimensioned, and the -C intermediate results returned in B are not needed. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,4*N). -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DISCR = .FALSE., this means that while the matrix -C A has computed eigenvalues with negative real parts, -C it is only just stable in the sense that small -C perturbations in A can make one or more of the -C eigenvalues have a non-negative real part; -C if DISCR = .TRUE., this means that while the matrix -C A has computed eigenvalues inside the unit circle, -C it is nevertheless only just convergent, in the -C sense that small perturbations in A can make one or -C more of the eigenvalues lie outside the unit circle; -C perturbed values were used to solve the equation -C (but the matrix A is unchanged); -C = 2: if matrix A is not stable (that is, one or more of -C the eigenvalues of A has a non-negative real part), -C if DISCR = .FALSE., or not convergent (that is, one -C or more of the eigenvalues of A lies outside the -C unit circle), if DISCR = .TRUE.; -C = 3: if matrix A has two or more consecutive non-zero -C elements on the first sub-diagonal, so that there is -C a block larger than 2-by-2 on the diagonal; -C = 4: if matrix A has a 2-by-2 diagonal block with real -C eigenvalues instead of a complex conjugate pair. -C -C METHOD -C -C The method used by the routine is based on the Bartels and -C Stewart method [1], except that it finds the upper triangular -C matrix U directly without first finding X and without the need -C to form the normal matrix op(B)'*op(B) [2]. -C -C If LTRANS = .FALSE., the matrix B is factored as -C -C B = P ( R ), M >= N, B = P ( R Z ), M < N, -C ( 0 ) -C -C (QR factorization), where P is an M-by-M orthogonal matrix and -C R is a square upper triangular matrix. -C -C If LTRANS = .TRUE., the matrix B is factored as -C -C B = ( 0 R ) P, M >= N, B = ( Z ) P, M < N, -C ( R ) -C -C (RQ factorization), where P is an M-by-M orthogonal matrix and -C R is a square upper triangular matrix. -C -C These factorizations are used to solve the continuous-time -C Lyapunov equation in the canonical form -C 2 -C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), -C -C or the discrete-time Lyapunov equation in the canonical form -C 2 -C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F), -C -C where U and F are N-by-N upper triangular matrices, and -C -C F = R, if M >= N, or -C -C F = ( R ), if LTRANS = .FALSE., or -C ( 0 ) -C -C F = ( 0 Z ), if LTRANS = .TRUE., if M < N. -C ( 0 R ) -C -C The canonical equation is solved for U. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. -C Solution of the matrix equation A'X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if A is only just stable (or convergent) then the Lyapunov -C equation will be ill-conditioned. "Large" elements in U relative -C to those of A and B, or a "small" value for scale, are symptoms -C of ill-conditioning. A condition estimate can be computed using -C SLICOT Library routine SB03MD. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, -C NAG Ltd, United Kingdom. -C Partly based on routine PLYAPS by A. Varga, University of Bochum, -C May 1992. -C -C REVISIONS -C -C Dec. 1997, April 1998, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, LDA, LDB, LDU, LDWORK, M, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), U(LDU,*) -C .. Local Scalars .. - INTEGER I, J, K, L, MN, WRKOPT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLASET, SB03OT, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( ( LDB.LT.MAX( 1, M ) .AND. .NOT.LTRANS ) .OR. - $ ( LDB.LT.MAX( 1, N ) .AND. LTRANS ) ) THEN - INFO = -8 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB03OU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - MN = MIN( N, M ) - IF ( MN.EQ.0 ) THEN - SCALE = ONE - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( LTRANS ) THEN -C -C Case op(K) = K'. -C -C Perform the RQ factorization of B. -C Workspace: need N; -C prefer N*NB. -C - CALL DGERQF( N, M, B, LDB, TAU, DWORK, LDWORK, INFO ) -C -C The triangular matrix F is constructed in the array U so that -C U can share the same memory as B. -C - IF ( M.GE.N ) THEN - CALL DLACPY( 'Upper', MN, N, B(1,M-N+1), LDB, U, LDU ) - ELSE -C - DO 10 I = M, 1, -1 - CALL DCOPY( N-M+I, B(1,I), 1, U(1,N-M+I), 1 ) - 10 CONTINUE -C - CALL DLASET( 'Full', N, N-M, ZERO, ZERO, U, LDU ) - END IF - ELSE -C -C Case op(K) = K. -C -C Perform the QR factorization of B. -C Workspace: need N; -C prefer N*NB. -C - CALL DGEQRF( M, N, B, LDB, TAU, DWORK, LDWORK, INFO ) - CALL DLACPY( 'Upper', MN, N, B, LDB, U, LDU ) - IF ( M.LT.N ) - $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, U(M+1,M+1), - $ LDU ) - END IF - WRKOPT = DWORK(1) -C -C Solve the canonical Lyapunov equation -C 2 -C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), -C -C or -C 2 -C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F) -C -C for U. -C - CALL SB03OT( DISCR, LTRANS, N, A, LDA, U, LDU, SCALE, DWORK, - $ INFO ) - IF ( INFO.NE.0 .AND. INFO.NE.1 ) - $ RETURN -C -C Make the diagonal elements of U non-negative. -C - IF ( LTRANS ) THEN -C - DO 30 J = 1, N - IF ( U(J,J).LT.ZERO ) THEN -C - DO 20 I = 1, J - U(I,J) = -U(I,J) - 20 CONTINUE -C - END IF - 30 CONTINUE -C - ELSE - K = 1 -C - DO 50 J = 1, N - DWORK(K) = U(J,J) - L = 1 -C - DO 40 I = 1, J - IF ( DWORK(L).LT.ZERO ) U(I,J) = -U(I,J) - L = L + 1 - 40 CONTINUE -C - K = K + 1 - 50 CONTINUE -C - END IF -C - DWORK(1) = MAX( WRKOPT, 4*N ) - RETURN -C *** Last line of SB03OU *** - END diff --git a/slycot/src/SB03OV.f b/slycot/src/SB03OV.f deleted file mode 100644 index bd92699b..00000000 --- a/slycot/src/SB03OV.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE SB03OV( A, B, C, S ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct a complex plane rotation such that, for a complex -C number a and a real number b, -C -C ( conjg( c ) s )*( a ) = ( d ), -C ( -s c ) ( b ) ( 0 ) -C -C where d is always real and is overwritten on a, so that on -C return the imaginary part of a is zero. b is unaltered. -C -C This routine has A and C declared as REAL, because it is intended -C for use within a real Lyapunov solver and the REAL declarations -C mean that a standard Fortran DOUBLE PRECISION version may be -C readily constructed. However A and C could safely be declared -C COMPLEX in the calling program, although some systems may give a -C type mismatch warning. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C A (input/output) DOUBLE PRECISION array, dimension (2) -C On entry, A(1) and A(2) must contain the real and -C imaginary part, respectively, of the complex number a. -C On exit, A(1) contains the real part of d, and A(2) is -C set to zero. -C -C B (input) DOUBLE PRECISION -C The real number b. -C -C C (output) DOUBLE PRECISION array, dimension (2) -C C(1) and C(2) contain the real and imaginary part, -C respectively, of the complex number c, the cosines of -C the plane rotation. -C -C S (output) DOUBLE PRECISION -C The real number s, the sines of the plane rotation. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB03CV by Sven Hammarling, -C NAG Ltd., United Kingdom, May 1985. -C -C REVISIONS -C -C Dec. 1997. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation. -C -C ***************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION B, S -C .. Array Arguments .. - DOUBLE PRECISION A(2), C(2) -C .. Local Scalars .. - DOUBLE PRECISION D -C .. External Functions .. - DOUBLE PRECISION DLAPY3 - EXTERNAL DLAPY3 -C .. Executable Statements .. -C - D = DLAPY3( A(1), A(2), B ) - IF ( D.EQ.ZERO ) THEN - C(1) = ONE - C(2) = ZERO - S = ZERO - ELSE - C(1) = A(1)/D - C(2) = A(2)/D - S = B/D - A(1) = D - A(2) = ZERO - END IF -C - RETURN -C *** Last line of SB03OV *** - END diff --git a/slycot/src/SB03OY.f b/slycot/src/SB03OY.f deleted file mode 100644 index 44a94b97..00000000 --- a/slycot/src/SB03OY.f +++ /dev/null @@ -1,693 +0,0 @@ - SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the Cholesky factor U of X, -C -C op(U)'*op(U) = X, -C -C where U is a two-by-two upper triangular matrix, either the -C continuous-time two-by-two Lyapunov equation -C 2 -C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R), -C -C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov -C equation -C 2 -C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R), -C -C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of -C the matrix K), S is a two-by-two matrix with complex conjugate -C eigenvalues, R is a two-by-two upper triangular matrix, -C ISGN = -1 or 1, and scale is an output scale factor, set less -C than or equal to 1 to avoid overflow in X. The routine also -C computes two matrices, B and A, so that -C 2 -C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or -C 2 -C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE., -C which are used by the general Lyapunov solver. -C In the continuous-time case ISGN*S must be stable, so that its -C eigenvalues must have strictly negative real parts. -C In the discrete-time case S must be convergent if ISGN = 1, that -C is, its eigenvalues must have moduli less than unity, or S must -C be completely divergent if ISGN = -1, that is, its eigenvalues -C must have moduli greater than unity. -C -C ARGUMENTS -C -C Mode Parameters -C -C DISCR LOGICAL -C Specifies the equation to be solved: 2 -C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R); -C 2 -C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R). -C -C LTRANS LOGICAL -C Specifies the form of op(K) to be used, as follows: -C = .FALSE.: op(K) = K (No transpose); -C = .TRUE. : op(K) = K**T (Transpose). -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C S (input/output) DOUBLE PRECISION array, dimension (LDS,2) -C On entry, S must contain a 2-by-2 matrix. -C On exit, S contains a 2-by-2 matrix B such that B*U = U*S, -C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE.. -C Notice that if U is nonsingular then -C B = U*S*inv( U ), if LTRANS = .FALSE. -C B = inv( U )*S*U, if LTRANS = .TRUE.. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= 2. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,2) -C On entry, R must contain a 2-by-2 upper triangular matrix. -C The element R( 2, 1 ) is not referenced. -C On exit, R contains U, the 2-by-2 upper triangular -C Cholesky factor of the solution X, X = op(U)'*op(U). -C -C LDR INTEGER -C The leading dimension of array R. LDR >= 2. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,2) -C A contains a 2-by-2 upper triangular matrix A satisfying -C A*U/scale = scale*R, if LTRANS = .FALSE., or -C U*A/scale = scale*R, if LTRANS = .TRUE.. -C Notice that if U is nonsingular then -C A = scale*scale*R*inv( U ), if LTRANS = .FALSE. -C A = scale*scale*inv( U )*R, if LTRANS = .TRUE.. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Lyapunov equation is (nearly) singular -C (warning indicator); -C if DISCR = .FALSE., this means that while the -C matrix S has computed eigenvalues with negative real -C parts, it is only just stable in the sense that -C small perturbations in S can make one or more of the -C eigenvalues have a non-negative real part; -C if DISCR = .TRUE., this means that while the -C matrix S has computed eigenvalues inside the unit -C circle, it is nevertheless only just convergent, in -C the sense that small perturbations in S can make one -C or more of the eigenvalues lie outside the unit -C circle; -C perturbed values were used to solve the equation -C (but the matrix S is unchanged); -C = 2: if DISCR = .FALSE., and ISGN*S is not stable or -C if DISCR = .TRUE., ISGN = 1 and S is not convergent -C or if DISCR = .TRUE., ISGN = -1 and S is not -C completely divergent; -C = 4: if S has real eigenvalues. -C -C NOTE: In the interests of speed, this routine does not check all -C inputs for errors. -C -C METHOD -C -C The LAPACK scheme for solving 2-by-2 Sylvester equations is -C adapted for 2-by-2 Lyapunov equations, but directly computing the -C Cholesky factor of the solution. -C -C REFERENCES -C -C [1] Hammarling S. J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-325, 1982. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB03CY by Sven Hammarling, -C NAG Ltd., United Kingdom, November 1986. -C Partly based on SB03CY and PLYAP2 by A. Varga, University of -C Bochum, May 1992. -C -C REVISIONS -C -C Dec. 1997, April 1998. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ***************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ FOUR = 4.0D0 ) -C .. Scalar Arguments .. - LOGICAL DISCR, LTRANS - INTEGER INFO, ISGN, LDA, LDR, LDS - DOUBLE PRECISION SCALE -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS, - $ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22, - $ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI, - $ TEMPR, V1, V3 -C .. Local Arrays .. - DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2), - $ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2), - $ X11(2), X12(2), X21(2), X22(2), Y(2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 - EXTERNAL DLAMCH, DLAPY2, DLAPY3 -C .. External Subroutines .. - EXTERNAL DLABAD, DLANV2, SB03OV -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Executable Statements .. -C -C The comments in this routine refer to notation and equation -C numbers in sections 6 and 10 of [1]. -C -C Find the eigenvalue lambda = E1 - i*E2 of s11. -C - INFO = 0 - SGN = ISGN - S11 = S(1,1) - S12 = S(1,2) - S21 = S(2,1) - S22 = S(2,2) -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*FOUR / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*MAX( ABS( S11 ), ABS( S12 ), - $ ABS( S21 ), ABS( S22 ) ) ) - SCALE = ONE -C - CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ ) - IF ( TEMPI.EQ.ZERO ) THEN - INFO = 4 - RETURN - END IF - ABSB = DLAPY2( E1, E2 ) - IF ( DISCR ) THEN - IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - ELSE - IF ( SGN*E1.GE.ZERO ) THEN - INFO = 2 - RETURN - END IF - END IF -C -C Compute the cos and sine that define Qhat. The sine is real. -C - TEMP(1) = S(1,1) - E1 - TEMP(2) = E2 - IF ( LTRANS ) TEMP(2) = -E2 - CALL SB03OV( TEMP, S(2,1), CSQ, SNQ ) -C -C beta in (6.9) is given by beta = E1 + i*E2, compute t. -C - TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1) - TEMP(2) = CSQ(2)*S(1,2) - TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1) - TEMPI = CSQ(2)*S(2,2) - T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR - T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI -C - IF ( LTRANS ) THEN -C ( -- ) -C Case op(M) = M'. Note that the modified R is ( p3 p2 ). -C ( 0 p1 ) -C -C Compute the cos and sine that define Phat. -C - TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2) - TEMP(2) = -CSQ(2)*R(2,2) - CALL SB03OV( TEMP, -SNQ*R(1,1), CSP, SNP ) -C -C Compute p1, p2 and p3 of the relation corresponding to (6.11). -C - P1 = TEMP(1) - TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2) - TEMP(2) = -CSQ(2)*R(1,2) - TEMPR = CSQ(1)*R(1,1) - TEMPI = -CSQ(2)*R(1,1) - P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR - P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI - P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) - P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2) - ELSE -C -C Case op(M) = M. -C -C Compute the cos and sine that define Phat. -C - TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2) - TEMP(2) = CSQ(2)*R(1,1) - CALL SB03OV( TEMP, SNQ*R(2,2), CSP, SNP ) -C -C Compute p1, p2 and p3 of (6.11). -C - P1 = TEMP(1) - TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1) - TEMP(2) = CSQ(2)*R(1,2) - TEMPR = CSQ(1)*R(2,2) - TEMPI = CSQ(2)*R(2,2) - P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR - P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI - P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) - P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2) - END IF -C -C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give -C -C p3 := abs( p3 ). -C - IF ( P3I.EQ.ZERO ) THEN - P3 = ABS( P3R ) - DP(1) = SIGN( ONE, P3R ) - DP(2) = ZERO - ELSE - P3 = DLAPY2( P3R, P3I ) - DP(1) = P3R/P3 - DP(2) = -P3I/P3 - END IF -C -C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15), -C or (10.23) - (10.25). Care is taken to avoid overflows. -C - IF ( DISCR ) THEN - ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) ) - ELSE - ALPHA = SQRT( ABS( TWO*E1 ) ) - END IF -C - SCALOC = ONE - IF( ALPHA.LT.SMIN ) THEN - ALPHA = SMIN - INFO = 1 - END IF - ABST = ABS( P1 ) - IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ALPHA ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - P1 = SCALOC*P1 - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V1 = P1/ALPHA -C - IF ( DISCR ) THEN - G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2 - G(2) = -TWO*E1*E2 - ABSG = DLAPY2( G(1), G(2) ) - SCALOC = ONE - IF( ABSG.LT.SMIN ) THEN - ABSG = SMIN - INFO = 1 - END IF - TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) ) - TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) ) - ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - TEMP(1) = SCALOC*TEMP(1) - TEMP(2) = SCALOC*TEMP(2) - P1 = SCALOC*P1 - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - TEMP(1) = TEMP(1)/ABSG - TEMP(2) = TEMP(2)/ABSG -C - SCALOC = ONE - V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2) - V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1) - ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P1 = SCALOC*P1 - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V2(1) = V2(1)/ABSG - V2(2) = V2(2)/ABSG -C - SCALOC = ONE - TEMP(1) = P1*T(1) - TWO*E2*P2(2) - TEMP(2) = P1*T(2) + TWO*E2*P2(1) - ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - TEMP(1) = SCALOC*TEMP(1) - TEMP(2) = SCALOC*TEMP(2) - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - TEMP(1) = TEMP(1)/ABSG - TEMP(2) = TEMP(2)/ABSG -C - SCALOC = ONE - Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) ) - Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) ) - ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) ) - IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSG ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - Y(1) = SCALOC*Y(1) - Y(2) = SCALOC*Y(2) - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - Y(1) = Y(1)/ABSG - Y(2) = Y(2)/ABSG - ELSE -C - SCALOC = ONE - IF( ABSB.LT.SMIN ) THEN - ABSB = SMIN - INFO = 1 - END IF - TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1) - TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2) - ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) - IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSB ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - TEMP(1) = SCALOC*TEMP(1) - TEMP(2) = SCALOC*TEMP(2) - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - TEMP(1) = TEMP(1)/( TWO*ABSB ) - TEMP(2) = TEMP(2)/( TWO*ABSB ) - SCALOC = ONE - V2(1) = -( E1*TEMP(1) + E2*TEMP(2) ) - V2(2) = -( E1*TEMP(2) - E2*TEMP(1) ) - ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) - IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN - IF( ABST.GT.BIGNUM*ABSB ) - $ SCALOC = ONE / ABST - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - P2(1) = SCALOC*P2(1) - P2(2) = SCALOC*P2(2) - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V2(1) = V2(1)/ABSB - V2(2) = V2(2)/ABSB - Y(1) = P2(1) - ALPHA*V2(1) - Y(2) = P2(2) - ALPHA*V2(2) - END IF -C - SCALOC = ONE - V3 = DLAPY3( P3, Y(1), Y(2) ) - IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN - IF( V3.GT.BIGNUM*ALPHA ) - $ SCALOC = ONE / V3 - END IF - IF( SCALOC.NE.ONE ) THEN - V1 = SCALOC*V1 - V2(1) = SCALOC*V2(1) - V2(2) = SCALOC*V2(2) - V3 = SCALOC*V3 - P3 = SCALOC*P3 - SCALE = SCALOC*SCALE - END IF - V3 = V3/ALPHA -C - IF ( LTRANS ) THEN -C -C Case op(M) = M'. -C -C Form X = conjg( Qhat' )*v11. -C - X11(1) = CSQ(1)*V3 - X11(2) = CSQ(2)*V3 - X21(1) = SNQ*V3 - X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1 - X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) - X22(1) = CSQ(1)*V1 + SNQ*V2(1) - X22(2) = -CSQ(2)*V1 - SNQ*V2(2) -C -C Obtain u11 from the RQ-factorization of X. The conjugate of -C X22 should be taken. -C - X22(2) = -X22(2) - CALL SB03OV( X22, X21(1), CST, SNT ) - R(2,2) = X22(1) - R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) - TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) - TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2) - IF ( TEMPI.EQ.ZERO ) THEN - R(1,1) = ABS( TEMPR ) - DT(1) = SIGN( ONE, TEMPR ) - DT(2) = ZERO - ELSE - R(1,1) = DLAPY2( TEMPR, TEMPI ) - DT(1) = TEMPR/R(1,1) - DT(2) = -TEMPI/R(1,1) - END IF - ELSE -C -C Case op(M) = M. -C -C Now form X = v11*conjg( Qhat' ). -C - X11(1) = CSQ(1)*V1 - SNQ*V2(1) - X11(2) = -CSQ(2)*V1 + SNQ*V2(2) - X21(1) = -SNQ*V3 - X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1 - X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) - X22(1) = CSQ(1)*V3 - X22(2) = CSQ(2)*V3 -C -C Obtain u11 from the QR-factorization of X. -C - CALL SB03OV( X11, X21(1), CST, SNT ) - R(1,1) = X11(1) - R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1) - TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1) - TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2) - IF ( TEMPI.EQ.ZERO ) THEN - R(2,2) = ABS( TEMPR ) - DT(1) = SIGN( ONE, TEMPR ) - DT(2) = ZERO - ELSE - R(2,2) = DLAPY2( TEMPR, TEMPI ) - DT(1) = TEMPR/R(2,2) - DT(2) = -TEMPI/R(2,2) - END IF - END IF -C -C The computations below are not needed when B and A are not -C useful. Compute delta, eta and gamma as in (6.21) or (10.26). -C - IF ( ( Y(1).EQ.ZERO ).AND.( Y(2).EQ.ZERO ) ) THEN - DELTA(1) = ZERO - DELTA(2) = ZERO - GAMMA(1) = ZERO - GAMMA(2) = ZERO - ETA = ALPHA - ELSE - DELTA(1) = Y(1)/V3 - DELTA(2) = Y(2)/V3 - GAMMA(1) = -ALPHA*DELTA(1) - GAMMA(2) = -ALPHA*DELTA(2) - ETA = P3/V3 - IF ( DISCR ) THEN - TEMPR = E1*DELTA(1) - E2*DELTA(2) - DELTA(2) = E1*DELTA(2) + E2*DELTA(1) - DELTA(1) = TEMPR - END IF - END IF -C - IF ( LTRANS ) THEN -C -C Case op(M) = M'. -C -C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ). -C ( Defer the scaling.) -C - X11(1) = CST(1)*E1 + CST(2)*E2 - X11(2) = -CST(1)*E2 + CST(2)*E1 - X21(1) = SNT*E1 - X21(2) = -SNT*E2 - X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1 - X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2 - X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1) - X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2) -C -C Now find B = X*That. ( Include the scaling here.) -C - S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) - TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1) - TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2) - S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI - TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) - TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2) - S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI - S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1) -C -C Form X = ( inv( v11 )*p11 )*conjg( Phat' ). -C - TEMPR = DP(1)*ETA - TEMPI = -DP(2)*ETA - X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1) - X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2) - X21(1) = SNP*ALPHA - X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2) - X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1) - X22(1) = CSP(1)*ALPHA - X22(2) = -CSP(2)*ALPHA -C -C Finally form A = conjg( That' )*X. -C - TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1) - TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI - TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1) - TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1) - A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI - A(2,1) = ZERO - A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1) - ELSE -C -C Case op(M) = M. -C -C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.) -C - X11(1) = CST(1)*E1 + CST(2)*E2 - X11(2) = CST(1)*E2 - CST(2)*E1 - X21(1) = -SNT*E1 - X21(2) = -SNT*E2 - X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1 - X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2 - X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1) - X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2) -C -C Now find B = X*conjg( That' ). ( Include the scaling here.) -C - S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) - TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1) - TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2) - S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI - TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) - TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2) - S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI - S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) -C -C Form X = Phat*( p11*inv( v11 ) ). -C - TEMPR = DP(1)*ETA - TEMPI = -DP(2)*ETA - X11(1) = CSP(1)*ALPHA - X11(2) = CSP(2)*ALPHA - X21(1) = SNP*ALPHA - X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR - X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI - X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1) - X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2) -C -C Finally form A = X*conjg( That' ). -C - A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) - A(2,1) = ZERO - A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) - TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) - TEMPI = CST(1)*X22(2) - CST(2)*X22(1) - A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI - END IF -C - IF( SCALE.NE.ONE ) THEN - A(1,1) = SCALE*A(1,1) - A(1,2) = SCALE*A(1,2) - A(2,2) = SCALE*A(2,2) - END IF -C - RETURN -C *** Last line of SB03OY *** - END diff --git a/slycot/src/SB03PD.f b/slycot/src/SB03PD.f deleted file mode 100644 index 8cef1572..00000000 --- a/slycot/src/SB03PD.f +++ /dev/null @@ -1,410 +0,0 @@ - SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, - $ SCALE, SEPD, FERR, WR, WI, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real discrete Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C -C -C and/or estimate the quantity, called separation, -C -C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C'). -C (A' denotes the transpose of the matrix A.) A is N-by-N, the right -C hand side C and the solution X are N-by-N, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'B': Compute both the solution and the separation. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix in Schur canonical form. -C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N -C part of this array contains the upper quasi-triangular -C matrix in Schur canonical form from the Shur factorization -C of A. The contents of array A is not modified if -C FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If FACT = 'F', then U is an input argument and on entry -C it must contain the orthogonal matrix U from the real -C Schur factorization of A. -C If FACT = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO = N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with JOB = 'X' or 'B', the leading N-by-N part of -C this array must contain the symmetric matrix C. -C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, -C the leading N-by-N part of C has been overwritten by the -C symmetric solution matrix X. -C If JOB = 'S', C is not referenced. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, -C SEPD contains the estimate in the 1-norm of -C sepd(op(A),op(A)'). -C If JOB = 'X' or N = 0, SEPD is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains -C an estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the relative -C error in the computed solution, measured in the Frobenius -C norm: norm(X - XTRUE)/norm(XTRUE). -C If JOB = 'X' or JOB = 'S', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1 and -C If JOB = 'X' then -C If FACT = 'F', LDWORK >= MAX(N*N,2*N); -C If FACT = 'N', LDWORK >= MAX(N*N,3*N). -C If JOB = 'S' or JOB = 'B' then -C LDWORK >= 2*N*N + 2*N. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues (see LAPACK Library routine DGEES); -C elements i+1:n of WR and WI contain eigenvalues -C which have converged, and A contains the partially -C converged Schur form; -C = N+1: if matrix A has almost reciprocal eigenvalues; -C perturbed values were used to solve the equation -C (but the matrix A is unchanged). -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C a discrete-time version of the Bartels-Stewart algorithm is used. -C A set of equivalent linear algebraic systems of equations of order -C at most four are formed and solved using Gaussian elimination with -C complete pivoting. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C SEPD is defined as -C -C sepd( op(A), op(A)' ) = sigma_min( T ) -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( op(A)', op(A)' ) - I(N**2). -C -C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the -C Kronecker product. The program estimates sigma_min(T) by the -C reciprocal of an estimate of the 1-norm of inverse(T). The true -C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by -C more than a factor of N. -C -C When SEPD is small, small changes in A, C can cause large changes -C in the solution of the equation. An approximate bound on the -C maximum relative error in the computed solution is -C -C EPS * norm(A)**2 / SEPD -C -C where EPS is the machine precision. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine MB03AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DGELPD by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, TRANA - INTEGER INFO, LDA, LDC, LDU, LDWORK, N - DOUBLE PRECISION FERR, SCALE, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ U( LDU, * ), WI( * ), WR( * ) -C .. -C .. Local Scalars .. - LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX - CHARACTER NOTRA, UPLO - INTEGER I, IERR, KASE, LWA, MINWRK, SDIM - DOUBLE PRECISION EST, SCALEF -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTA = LSAME( TRANA, 'N' ) -C - INFO = 0 - IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( WANTSP .AND. LDC.LT.1 .OR. - $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Compute workspace. -C - IF( WANTX ) THEN - IF( NOFACT ) THEN - MINWRK = MAX( N*N, 3*N ) - ELSE - MINWRK = MAX( N*N, 2*N ) - END IF - ELSE - MINWRK = 2*N*N + 2*N - END IF - IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -18 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - SCALE = ONE - IF( WANTBH ) - $ FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - LWA = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LWA = INT( DWORK( 1 ) ) - END IF -C - IF( .NOT.WANTSP ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - UPLO = 'U' - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 10 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 10 CONTINUE -C -C Solve the transformed equation. -C Workspace: 2*N. -C - CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C -C Transform back the solution. -C - CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 20 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 20 CONTINUE -C - END IF -C - IF( .NOT.WANTX ) THEN -C -C Estimate sepd(op(A),op(A)'). -C Workspace: 2*N*N + 2*N. -C - IF( NOTA ) THEN - NOTRA = 'T' - ELSE - NOTRA = 'N' - END IF -C - EST = ZERO - KASE = 0 -C REPEAT - 30 CONTINUE - CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN - CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK( 2*N*N + 1 ), IERR ) - ELSE - CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, - $ DWORK( 2*N*N + 1 ), IERR ) - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - SEPD = SCALEF / EST -C - IF( WANTBH ) THEN -C -C Compute the estimate of the relative error. -C - FERR = DLAMCH( 'Precision' )* - $ DLANHS( 'Frobenius', N, A, LDA, DWORK )**2 / SEPD - END IF - END IF -C - DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) -C - RETURN -C *** Last line of SB03PD *** - END diff --git a/slycot/src/SB03QD.f b/slycot/src/SB03QD.f deleted file mode 100644 index 5f8ccf88..00000000 --- a/slycot/src/SB03QD.f +++ /dev/null @@ -1,676 +0,0 @@ - SUBROUTINE SB03QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real continuous-time Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A is N-by-N, the right hand side C and the solution X are -C N-by-N symmetric matrices, and scale is a given scale factor. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X and C. N >= 0. -C -C SCALE (input) DOUBLE PRECISION -C The scale factor, scale, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the original matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sep(op(A),-op(A)'). -C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the continuous-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C If JOB = 'C', then -C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; -C LDWORK >= MAX(1,2*N*N,5*N), if FACT = 'N'. -C If JOB = 'E', or JOB = 'B', and LYAPUN = 'O', then -C LDWORK >= MAX(1,3*N*N), if FACT = 'F'; -C LDWORK >= MAX(1,3*N*N,5*N), if FACT = 'N'. -C If JOB = 'E', or JOB = 'B', and LYAPUN = 'R', then -C LDWORK >= MAX(1,3*N*N+N-1), if FACT = 'F'; -C LDWORK >= MAX(1,3*N*N+N-1,5*N), if FACT = 'N'. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations, but the matrix T, if given -C (for FACT = 'F'), is unchanged. -C -C METHOD -C -C The condition number of the continuous-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W + W*op(A), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). -C -C The routine estimates the quantities -C -C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEP is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C CONTRIBUTORS -C -C P. Petkov, Tech. University of Sofia, December 1998. -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D0, - $ THREE = 3.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, - $ UPDATE - CHARACTER SJOB, TRANAT - INTEGER I, IABS, IRES, IWRK, IXBS, J, JJ, JX, LDW, NN, - $ SDIM, WRKOPT - DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, - $ TMAX, XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DGEES, DLACPY, DLASET, DSYR2K, MB01UD, - $ MB01UW, SB03QX, SB03QY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - IF( JOBC ) THEN - LDW = 2*NN - ELSE - LDW = 3*NN - END IF - IF( .NOT.( JOBC .OR. UPDATE ) ) - $ LDW = LDW + N - 1 -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.1 .OR. - $ ( LDWORK.LT.LDW .AND. .NOT.NOFACT ) .OR. - $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. NOFACT ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Compute the 1-norm of A or T. -C - IF( NOFACT .OR. UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C For the special case A = 0, set SEP and RCOND to 0. -C For the special case A = I, set SEP to 2 and RCOND to 1. -C A quick test is used in general. -C - IF( ANORM.EQ.ONE ) THEN - IF( NOFACT .OR. UPDATE ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - ELSE - CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) - IF( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), - $ N ) - END IF - DWORK( NN+1 ) = ONE - CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) - IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEP = TWO - RCOND = ONE - END IF - IF( JOBC ) THEN - DWORK( 1 ) = DBLE( NN + 1 ) - RETURN - ELSE -C -C Set FERR for the special case A = I. -C - CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) -C - IF( LOWER ) THEN - DO 10 J = 1, N - CALL DAXPY( N-J+1, -SCALE/TWO, C( J, J ), 1, - $ DWORK( (J-1)*N+J ), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, N - CALL DAXPY( J, -SCALE/TWO, C( 1, J ), 1, - $ DWORK( (J-1)*N+1 ), 1 ) - 20 CONTINUE - END IF -C - FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, - $ DWORK( NN+1 ) ) / XNORM ) - DWORK( 1 ) = DBLE( NN + N ) - RETURN - END IF - END IF -C - ELSE IF( ANORM.EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEP = ZERO - RCOND = ZERO - END IF - IF( .NOT.JOBC ) - $ FERR = ONE - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C General case. -C - CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) -C -C Workspace usage. -C - IABS = 0 - IXBS = IABS + NN - IRES = IXBS + NN - IWRK = IRES + NN - WRKOPT = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A, A = U*T*U'. -C Workspace: need 5*N; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), - $ LDWORK-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sep(op(A),-op(A)') = sep(op(T),-op(T)') and -C norm(Theta). -C Workspace 2*N*N. -C - CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C - WRKOPT = MAX( WRKOPT, 2*NN ) -C -C Return if the equation is singular. -C - IF( SEP.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEP, XNORM, ANORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEP*XNORM - DENOM = ( SCALE*CNORM ) + ( SEP*ANORM )*THNORM - ELSE - TEMP = ( SEP / TMAX )*( XNORM / TMAX ) - DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + - $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = op(A)'*X + X*op(A) - scale*C, or -C R = op(T)'*X + X*op(T) - scale*C, -C exploiting the symmetry. -C Workspace 3*N*N. -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( UPDATE ) THEN -C - CALL DLACPY( UPLO, N, N, C, LDC, DWORK( IRES+1 ), N ) - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, - $ -SCALE, DWORK( IRES+1 ), N ) - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IRES+1 ), N, INFO ) - JJ = IRES + 1 - IF( LOWER ) THEN - DO 30 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( N-J+1, -SCALE, C( J, J ), 1, DWORK( JJ ), - $ 1 ) - JJ = JJ + N + 1 - 30 CONTINUE - ELSE - DO 40 J = 1, N - CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), - $ 1 ) - CALL DAXPY( J, -SCALE, C( 1, J ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - 40 CONTINUE - END IF - END IF -C - WRKOPT = MAX( WRKOPT, 3*NN ) -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( N + 3 ) - TEMP = EPS*THREE*SCALE -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + -C (n+3)*(abs(op(A))'*abs(X) + abs(X)*abs(op(A)))), or -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + -C (n+3)*(abs(op(T))'*abs(X) + abs(X)*abs(op(T)))), -C where EPS is the machine precision. -C - DO 60 J = 1, N - DO 50 I = 1, N - DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) - 50 CONTINUE - 60 CONTINUE -C - IF( LOWER ) THEN - DO 80 J = 1, N - DO 70 I = J, N - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 70 CONTINUE - 80 CONTINUE - ELSE - DO 100 J = 1, N - DO 90 I = 1, J - DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + - $ ABS( DWORK( IRES+(J-1)*N+I ) ) - 90 CONTINUE - 100 CONTINUE - END IF -C - IF( UPDATE ) THEN -C -C Workspace 3*N*N. -C - DO 120 J = 1, N - DO 110 I = 1, N - DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) - 110 CONTINUE - 120 CONTINUE -C - CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, - $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) - ELSE -C -C Workspace 3*N*N + N - 1. -C - DO 140 J = 1, N - DO 130 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 130 CONTINUE - 140 CONTINUE -C - CALL MB01UW( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), - $ N, DWORK( IXBS+1), N, DWORK( IWRK+1 ), - $ LDWORK-IWRK, INFO ) - JJ = IRES + 1 - JX = IXBS + 1 - IF( LOWER ) THEN - DO 150 J = 1, N - CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), - $ 1 ) - JJ = JJ + N + 1 - JX = JX + N + 1 - 150 CONTINUE - ELSE - DO 160 J = 1, N - CALL DAXPY( J, ONE, DWORK( IXBS+J ), N, DWORK( JX ), - $ 1 ) - CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) - JJ = JJ + N - JX = JX + N - 160 CONTINUE - END IF -C - WRKOPT = MAX( WRKOPT, 3*NN + N - 1 ) - END IF -C -C Compute forward error bound, using matrix norm estimator. -C Workspace 3*N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, - $ INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB03QD *** - END diff --git a/slycot/src/SB03QX.f b/slycot/src/SB03QX.f deleted file mode 100644 index 255ca13a..00000000 --- a/slycot/src/SB03QX.f +++ /dev/null @@ -1,394 +0,0 @@ - SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate a forward error bound for the solution X of a real -C continuous-time Lyapunov matrix equation, -C -C op(A)'*X + X*op(A) = C, -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A, the right hand side C, and the solution X are N-by-N. -C An absolute residual matrix, which takes into account the rounding -C errors in forming it, is given in the array R. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix R is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and R. N >= 0. -C -C XANORM (input) DOUBLE PRECISION -C The absolute (maximal) norm of the symmetric solution -C matrix X of the Lyapunov equation. XANORM >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On exit, the leading N-by-N part of this array contains -C the symmetric absolute residual matrix R (with bounds on -C rounding errors added), fully stored. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C FERR (output) DOUBLE PRECISION -C An estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the magnitude -C of the largest entry in (X - XTRUE) divided by the -C magnitude of the largest entry in X. -C If N = 0 or XANORM = 0, FERR is set to 0, without any -C calculations. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 2*N*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations (but the matrix T is -C unchanged). -C -C METHOD -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1], based on the 1-norm estimator -C in [2]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [2] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C The routine can be also used as a final step in estimating a -C forward error bound for the solution of a continuous-time -C algebraic matrix Riccati equation. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER LYAPUN, TRANA, UPLO - INTEGER INFO, LDR, LDT, LDU, LDWORK, N - DOUBLE PRECISION FERR, XANORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), - $ U( LDU, * ) -C .. -C .. Local Scalars .. - LOGICAL LOWER, NOTRNA, UPDATE - CHARACTER TRANAT, UPLOW - INTEGER I, IJ, INFO2, ITMP, J, KASE, NN - DOUBLE PRECISION EST, SCALE, TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DSCAL, MA02ED, MB01RU, SB03MY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( XANORM.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -9 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.2*NN ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03QX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - FERR = ZERO - IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C -C Fill in the remaining triangle of the symmetric residual matrix. -C - CALL MA02ED( UPLO, N, R, LDR ) -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLOW = 'U' - LOWER = .FALSE. - ELSE - UPLOW = 'L' - LOWER = .TRUE. - END IF -C - IF( KASE.EQ.2 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 30 J = 1, N - DO 20 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 20 CONTINUE - IJ = IJ + J - 30 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 50 J = 1, N - DO 40 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 40 CONTINUE - IJ = IJ + N - J - 50 CONTINUE - END IF - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, - $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLOW, N, DWORK, N ) -C - IF( KASE.EQ.2 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C - IF( KASE.EQ.1 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 70 J = 1, N - DO 60 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 60 CONTINUE - IJ = IJ + J - 70 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 90 J = 1, N - DO 80 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 80 CONTINUE - IJ = IJ + N - J - 90 CONTINUE - END IF - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLOW, N, DWORK, N ) - GO TO 10 - END IF -C -C UNTIL KASE = 0 -C -C Compute the estimate of the relative error. -C - TEMP = XANORM*SCALE - IF( TEMP.GT.EST ) THEN - FERR = EST / TEMP - ELSE - FERR = ONE - END IF -C - RETURN -C -C *** Last line of SB03QX *** - END diff --git a/slycot/src/SB03QY.f b/slycot/src/SB03QY.f deleted file mode 100644 index 63f41f5b..00000000 --- a/slycot/src/SB03QY.f +++ /dev/null @@ -1,443 +0,0 @@ - SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the separation between the matrices op(A) and -op(A)', -C -C sep(op(A),-op(A)') = min norm(op(A)'*X + X*op(A))/norm(X) -C = 1 / norm(inv(Omega)) -C -C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and -C Omega and Theta are linear operators associated to the real -C continuous-time Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = C, -C -C defined by -C -C Omega(W) = op(A)'*W + W*op(A), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). -C -C The 1-norm condition estimators are used. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'S': Compute the separation only; -C = 'T': Compute the norm of Theta only; -C = 'B': Compute both the separation and the norm of Theta. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C solution matrix X of the Lyapunov equation (reduced -C Lyapunov equation if LYAPUN = 'R'). -C If JOB = 'S', the array X is not referenced. -C -C LDX INTEGER -C The leading dimension of array X. -C LDX >= 1, if JOB = 'S'; -C LDX >= MAX(1,N), if JOB = 'T' or 'B'. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEP contains the -C estimated separation of the matrices op(A) and -op(A)'. -C If JOB = 'T' or N = 0, SEP is not referenced. -C -C THNORM (output) DOUBLE PRECISION -C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains -C the estimated 1-norm of operator Theta. -C If JOB = 'S' or N = 0, THNORM is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 2*N*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations (but the matrix T is -C unchanged). -C -C METHOD -C -C SEP is defined as the separation of op(A) and -op(A)': -C -C sep( op(A), -op(A)' ) = sigma_min( K ) -C -C where sigma_min(K) is the smallest singular value of the -C N*N-by-N*N matrix -C -C K = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). -C -C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker -C product. The routine estimates sigma_min(K) by the reciprocal of -C an estimate of the 1-norm of inverse(K), computed as suggested in -C [1]. This involves the solution of several continuous-time -C Lyapunov equations, either direct or transposed. The true -C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by -C more than a factor of N. -C The 1-norm of Theta is estimated similarly. -C -C REFERENCES -C -C [1] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C When SEP is zero, the routine returns immediately, with THNORM -C (if requested) not set. In this case, the equation is singular. -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 13, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB, LYAPUN, TRANA - INTEGER INFO, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION SEP, THNORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, UPDATE, WANTS, WANTT - CHARACTER TRANAT, UPLO - INTEGER INFO2, ITMP, KASE, NN - DOUBLE PRECISION BIGNUM, EST, SCALE -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, - $ SB03MY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTS = LSAME( JOB, 'S' ) - WANTT = LSAME( JOB, 'T' ) - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDX.LT.1 .OR. ( .NOT.WANTS .AND. LDX.LT.N ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.2*NN ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03QY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( .NOT.WANTT ) THEN -C -C Estimate sep(op(A),-op(A)'). -C Workspace: 2*N*N. -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 10 - END IF -C UNTIL KASE = 0 -C - IF( EST.GT.SCALE ) THEN - SEP = SCALE / EST - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( SCALE.LT.EST*BIGNUM ) THEN - SEP = SCALE / EST - ELSE - SEP = BIGNUM - END IF - END IF -C -C Return if the equation is singular. -C - IF( SEP.EQ.ZERO ) - $ RETURN - END IF -C - IF( .NOT.WANTS ) THEN -C -C Estimate norm(Theta). -C Workspace: 2*N*N. -C - KASE = 0 -C -C REPEAT - 20 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) -C -C Compute RHS = op(W)'*X + X*op(W). -C - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, X, LDX, - $ ZERO, DWORK( ITMP ), N ) - CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y + Y*op(T) = scale*RHS. -C - CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) - ELSE -C -C Solve op(T)*W + W*op(T)' = scale*RHS. -C - CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 20 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - THNORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - THNORM = EST / SCALE - ELSE - THNORM = BIGNUM - END IF - END IF - END IF -C - RETURN -C *** Last line of SB03QY *** - END diff --git a/slycot/src/SB03RD.f b/slycot/src/SB03RD.f deleted file mode 100644 index 0398a3ab..00000000 --- a/slycot/src/SB03RD.f +++ /dev/null @@ -1,404 +0,0 @@ - SUBROUTINE SB03RD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, - $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C -C -C and/or estimate the separation between the matrices op(A) and -C -op(A)', where op(A) = A or A' (A**T) and C is symmetric (C = C'). -C (A' denotes the transpose of the matrix A.) A is N-by-N, the right -C hand side C and the solution X are N-by-N, and scale is an output -C scale factor, set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'B': Compute both the solution and the separation. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix A. If FACT = 'F', then A contains -C an upper quasi-triangular matrix in Schur canonical form. -C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N -C part of this array contains the upper quasi-triangular -C matrix in Schur canonical form from the Shur factorization -C of A. The contents of array A is not modified if -C FACT = 'F'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If FACT = 'F', then U is an input argument and on entry -C it must contain the orthogonal matrix U from the real -C Schur factorization of A. -C If FACT = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO = N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry with JOB = 'X' or 'B', the leading N-by-N part of -C this array must contain the symmetric matrix C. -C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, -C the leading N-by-N part of C has been overwritten by the -C symmetric solution matrix X. -C If JOB = 'S', C is not referenced. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP -C contains the estimated separation of the matrices op(A) -C and -op(A)'. -C If JOB = 'X' or N = 0, SEP is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains -C an estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the relative -C error in the computed solution, measured in the Frobenius -C norm: norm(X - XTRUE)/norm(XTRUE). -C If JOB = 'X' or JOB = 'S', FERR is not referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 1 and -C If JOB = 'X' then -C If FACT = 'F', LDWORK >= N*N; -C If FACT = 'N', LDWORK >= MAX(N*N,3*N). -C If JOB = 'S' or JOB = 'B' then -C If FACT = 'F', LDWORK >= 2*N*N; -C If FACT = 'N', LDWORK >= MAX(2*N*N,3*N). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute all -C the eigenvalues (see LAPACK Library routine DGEES); -C elements i+1:n of WR and WI contain eigenvalues -C which have converged, and A contains the partially -C converged Schur form; -C = N+1: if the matrices A and -A' have common or very -C close eigenvalues; perturbed values were used to -C solve the equation (but the matrix A is unchanged). -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C the Bartels-Stewart algorithm is used. A set of equivalent linear -C algebraic systems of equations of order at most four are formed -C and solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C SEP is defined as the separation of op(A) and -op(A)': -C -C sep( op(A), -op(A)' ) = sigma_min( T ) -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( I(N), op(A)' ) + kprod( op(A), I(N) ). -C -C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker -C product. The program estimates sigma_min(T) by the reciprocal of -C an estimate of the 1-norm of inverse(T). The true reciprocal -C 1-norm of inverse(T) cannot differ from sigma_min(T) by more -C than a factor of N. -C -C When SEP is small, small changes in A, C can cause large changes -C in the solution of the equation. An approximate bound on the -C maximum relative error in the computed solution is -C -C EPS * norm(A) / SEP -C -C where EPS is the machine precision. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. -C Supersedes Release 2.0 routine MB03AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, October 1982. -C Based on DGELYP by P. Petkov, Tech. University of Sofia, September -C 1993. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, TRANA - INTEGER INFO, LDA, LDC, LDU, LDWORK, N - DOUBLE PRECISION FERR, SCALE, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ U( LDU, * ), WI( * ), WR( * ) -C .. -C .. Local Scalars .. - LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX - CHARACTER NOTRA, UPLO - INTEGER I, IERR, KASE, LWA, MINWRK, SDIM - DOUBLE PRECISION EST, SCALEF -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANHS - EXTERNAL DLAMCH, DLANHS, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTA = LSAME( TRANA, 'N' ) -C - INFO = 0 - IF( .NOT.WANTSP .AND. .NOT.WANTBH .AND. .NOT.WANTX ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( WANTSP .AND. LDC.LT.1 .OR. - $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C -C Compute workspace. -C - IF( WANTX ) THEN - IF( NOFACT ) THEN - MINWRK = MAX( N*N, 3*N ) - ELSE - MINWRK = N*N - END IF - ELSE - IF( NOFACT ) THEN - MINWRK = MAX( 2*N*N, 3*N ) - ELSE - MINWRK = 2*N*N - END IF - END IF - IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN - INFO = -18 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - SCALE = ONE - IF( WANTBH ) - $ FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - LWA = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LWA = INT( DWORK( 1 ) ) - END IF -C - IF( .NOT.WANTSP ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - UPLO = 'U' - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 10 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 10 CONTINUE -C -C Solve the transformed equation. -C - CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C -C Transform back the solution. -C - CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, - $ LDU, C, LDC, DWORK, LDWORK, INFO ) -C - DO 20 I = 2, N - CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) - 20 CONTINUE -C - END IF -C - IF( .NOT.WANTX ) THEN -C -C Estimate sep(op(A),-op(A)'). -C Workspace: 2*N*N. -C - IF( NOTA ) THEN - NOTRA = 'T' - ELSE - NOTRA = 'N' - END IF -C - EST = ZERO - KASE = 0 -C REPEAT - 30 CONTINUE - CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN - CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, IERR ) - ELSE - CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, IERR ) - END IF - GO TO 30 - END IF -C UNTIL KASE = 0 -C - SEP = SCALEF / EST -C - IF( WANTBH ) THEN -C -C Compute the estimate of the relative error. -C - FERR = DLAMCH( 'Precision' )* - $ DLANHS( 'Frobenius', N, A, LDA, DWORK ) / SEP - END IF - END IF -C - DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) -C - RETURN -C *** Last line of SB03RD *** - END diff --git a/slycot/src/SB03SD.f b/slycot/src/SB03SD.f deleted file mode 100644 index bcf12295..00000000 --- a/slycot/src/SB03SD.f +++ /dev/null @@ -1,674 +0,0 @@ - SUBROUTINE SB03SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, - $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the conditioning and compute an error bound on the -C solution of the real discrete-time Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A is N-by-N, the right hand side C and the solution X are -C N-by-N symmetric matrices, and scale is a given scale factor. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'B': Compute both the reciprocal condition number and -C the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved in the iterative estimation process, -C as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X and C. N >= 0. -C -C SCALE (input) DOUBLE PRECISION -C The scale factor, scale, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of -C this array must contain the original matrix A. -C If FACT = 'F' and LYAPUN = 'R', A is not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; -C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If UPLO = 'U', the leading N-by-N upper triangular part of -C this array must contain the upper triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C If UPLO = 'L', the leading N-by-N lower triangular part of -C this array must contain the lower triangular part of the -C matrix C of the original Lyapunov equation (with -C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov -C equation (with matrix T), if LYAPUN = 'R'. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,N). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C The array X is modified internally, but restored on exit. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', the estimated quantity -C sepd(op(A),op(A)'). -C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal -C condition number of the discrete-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'E', RCOND is not referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'B', an estimated forward error -C bound for the solution X. If XTRUE is the true solution, -C FERR bounds the magnitude of the largest entry in -C (X - XTRUE) divided by the magnitude of the largest entry -C in X. -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'C', FERR is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 1, if N = 0; else, -C LDWORK >= MAX(3,2*N*N) + N*N, if JOB = 'C', -C FACT = 'F'; -C LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB = 'C', -C FACT = 'N'; -C LDWORK >= MAX(3,2*N*N) + N*N + 2*N, if JOB = 'E', or -C JOB = 'B'. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrix T has almost reciprocal eigenvalues; -C perturbed values were used to solve Lyapunov -C equations, but the matrix T, if given (for -C FACT = 'F'), is unchanged. -C -C METHOD -C -C The condition number of the discrete-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W*op(A) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). -C -C The routine estimates the quantities -C -C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C When SEPD is computed and it is zero, the routine returns -C immediately, with RCOND and FERR (if requested) set to 0 and 1, -C respectively. In this case, the equation is singular. -C -C CONTRIBUTORS -C -C P. Petkov, Tech. University of Sofia, December 1998. -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, THREE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, THREE = 3.0D0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, - $ UPDATE - CHARACTER SJOB, TRANAT - INTEGER I, IABS, IRES, IWRK, IXMA, J, LDW, NN, SDIM, - $ WRKOPT - DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, - $ TMAX, XANORM, XNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DLACPY, DLASET, - $ MA02ED, MB01RU, MB01RX, MB01RY, MB01UD, SB03SX, - $ SB03SY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBB = LSAME( JOB, 'B' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - LDW = MAX( 3, 2*NN ) + NN -C - INFO = 0 - IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.1 .OR. - $ ( LDWORK.LT.LDW .AND. JOBC .AND. .NOT.NOFACT ) .OR. - $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. JOBC .AND. NOFACT ) .OR. - $ ( LDWORK.LT.( LDW + 2*N ) .AND. .NOT.JOBC ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( .NOT.JOBE ) - $ RCOND = ONE - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C -C Compute the 1-norm of the matrix X. -C - XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) - IF( XNORM.EQ.ZERO ) THEN -C -C The solution is zero. -C - IF( .NOT.JOBE ) - $ RCOND = ZERO - IF( .NOT.JOBC ) - $ FERR = ZERO - DWORK( 1 ) = DBLE( N ) - RETURN - END IF -C -C Compute the 1-norm of A or T. -C - IF( NOFACT .OR. UPDATE ) THEN - ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ELSE - ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) - END IF -C -C For the special case A = I, set SEPD and RCOND to 0. -C For the special case A = 0, set SEPD and RCOND to 1. -C A quick test is used in general. -C - IF( ANORM.EQ.ONE ) THEN - IF( NOFACT .OR. UPDATE ) THEN - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - ELSE - CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) - IF( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), - $ N ) - END IF - DWORK( NN+1 ) = ONE - CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) - IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEPD = ZERO - RCOND = ZERO - END IF - IF( .NOT.JOBC ) - $ FERR = ONE - DWORK( 1 ) = DBLE( NN + 1 ) - RETURN - END IF -C - ELSE IF( ANORM.EQ.ZERO ) THEN - IF( .NOT.JOBE ) THEN - SEPD = ONE - RCOND = ONE - END IF - IF( JOBC ) THEN - DWORK( 1 ) = DBLE( N ) - RETURN - ELSE -C -C Set FERR for the special case A = 0. -C - CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) -C - IF( LOWER ) THEN - DO 10 J = 1, N - CALL DAXPY( N-J+1, SCALE, C( J, J ), 1, - $ DWORK( (J-1)*N+J ), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, N - CALL DAXPY( J, SCALE, C( 1, J ), 1, - $ DWORK( (J-1)*N+1 ), 1 ) - 20 CONTINUE - END IF -C - FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, - $ DWORK( NN+1 ) ) / XNORM ) - DWORK( 1 ) = DBLE( NN + N ) - RETURN - END IF - END IF -C -C General case. -C - CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) -C -C Workspace usage. -C - IABS = NN - IXMA = MAX( 3, 2*NN ) - IRES = IXMA - IWRK = IXMA + NN - WRKOPT = 0 -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A, A = U*T*U'. -C Workspace: need 5*N; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, - $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), - $ LDWORK-2*N, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N - END IF -C -C Compute X*op(A) or X*op(T). -C - IF( UPDATE ) THEN - CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, A, LDA, - $ ZERO, DWORK( IXMA+1 ), N ) - ELSE - CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, - $ DWORK( IXMA+1 ), N, INFO ) - END IF -C - IF( .NOT.JOBE ) THEN -C -C Estimate sepd(op(A),op(A)') = sepd(op(T),op(T)') and -C norm(Theta). -C Workspace max(3,2*N*N) + N*N. -C - CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, - $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, - $ IXMA, INFO ) -C - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN ) -C -C Return if the equation is singular. -C - IF( SEPD.EQ.ZERO ) THEN - RCOND = ZERO - IF( JOBB ) - $ FERR = ONE - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN - END IF -C -C Estimate the reciprocal condition number. -C - TMAX = MAX( SEPD, XNORM, ANORM ) - IF( TMAX.LE.ONE ) THEN - TEMP = SEPD*XNORM - DENOM = ( SCALE*CNORM ) + ( SEPD*ANORM )*THNORM - ELSE - TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) - DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + - $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM - END IF - IF( TEMP.GE.DENOM ) THEN - RCOND = ONE - ELSE - RCOND = TEMP / DENOM - END IF - END IF -C - IF( .NOT.JOBC ) THEN -C -C Form a triangle of the residual matrix -C R = scale*C + X - op(A)'*X*op(A), or -C R = scale*C + X - op(T)'*X*op(T), -C exploiting the symmetry. For memory savings, R is formed in the -C leading N-by-N upper/lower triangular part of DWORK, and it is -C finally moved in the location where X*op(A) or X*op(T) was -C stored, freeing workspace for the SB03SX call. -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - CALL DLACPY( UPLO, N, N, C, LDC, DWORK, N ) -C - IF( UPDATE ) THEN - CALL MB01RX( 'Left', UPLO, TRANAT, N, N, SCALE, -ONE, DWORK, - $ N, A, LDA, DWORK( IXMA+1 ), N, INFO ) - ELSE - CALL MB01RY( 'Left', UPLO, TRANAT, N, SCALE, -ONE, DWORK, N, - $ T, LDT, DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), - $ INFO ) - END IF -C - IF( LOWER ) THEN - DO 30 J = 1, N - CALL DAXPY( N-J+1, ONE, X( J, J ), 1, DWORK( (J-1)*N+J ), - $ 1 ) - 30 CONTINUE - ELSE - DO 40 J = 1, N - CALL DAXPY( J, ONE, X( 1, J ), 1, DWORK( (J-1)*N+1 ), 1 ) - 40 CONTINUE - END IF -C - CALL DLACPY( UPLO, N, N, DWORK, N, DWORK( IRES+1 ), N ) -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) - EPSN = EPS*DBLE( 2*N + 2 ) -C -C Add to abs(R) a term that takes account of rounding errors in -C forming R: -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + -C 2*(n+1)*abs(op(A))'*abs(X)*abs(op(A))), or -C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + -C 2*(n+1)*abs(op(T))'*abs(X)*abs(op(T))), -C where EPS is the machine precision. -C Workspace max(3,2*N*N) + N*N + 2*N. -C Note that the lower or upper triangular part of X specified by -C UPLO is used as workspace, but it is finally restored. -C - IF( UPDATE ) THEN - DO 60 J = 1, N - DO 50 I = 1, N - DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - DO 70 I = 1, MIN( J+1, N ) - DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) - 70 CONTINUE - 80 CONTINUE - END IF -C - CALL DCOPY( N, X, LDX+1, DWORK( IWRK+1 ), 1 ) -C - IF( LOWER ) THEN - DO 100 J = 1, N - DO 90 I = J, N - TEMP = ABS( X( I, J ) ) - X( I, J ) = TEMP - DWORK( IRES+(J-1)*N+I ) = - $ ABS( DWORK( IRES+(J-1)*N+I ) ) + - $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) - 90 CONTINUE - 100 CONTINUE - ELSE - DO 120 J = 1, N - DO 110 I = 1, J - TEMP = ABS( X( I, J ) ) - X( I, J ) = TEMP - DWORK( IRES+(J-1)*N+I ) = - $ ABS( DWORK( IRES+(J-1)*N+I ) ) + - $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) - 110 CONTINUE - 120 CONTINUE - END IF -C - IF( UPDATE ) THEN - CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPSN, DWORK( IRES+1 ), - $ N, DWORK( IABS+1 ), N, X, LDX, DWORK, NN, - $ INFO ) - ELSE -C -C Compute W = abs(X)*abs(op(T)), and then premultiply by -C abs(T)' and add in the result. -C - CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, - $ X, LDX, DWORK, N, INFO ) - CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, - $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, DWORK, - $ N, DWORK( IWRK+N+1 ), INFO ) - END IF -C - WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN + 2*N ) -C -C Restore X. -C - CALL DCOPY( N, DWORK( IWRK+1 ), 1, X, LDX+1 ) - IF( LOWER ) THEN - CALL MA02ED( 'Upper', N, X, LDX ) - ELSE - CALL MA02ED( 'Lower', N, X, LDX ) - END IF -C -C Compute forward error bound, using matrix norm estimator. -C Workspace max(3,2*N*N) + N*N. -C - XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) -C - CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, - $ INFO ) - END IF -C - DWORK( 1 ) = DBLE( WRKOPT ) - RETURN -C -C *** Last line of SB03SD *** - END diff --git a/slycot/src/SB03SX.f b/slycot/src/SB03SX.f deleted file mode 100644 index 58078b80..00000000 --- a/slycot/src/SB03SX.f +++ /dev/null @@ -1,398 +0,0 @@ - SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate a forward error bound for the solution X of a real -C discrete-time Lyapunov matrix equation, -C -C op(A)'*X*op(A) - X = C, -C -C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The -C matrix A, the right hand side C, and the solution X are N-by-N. -C An absolute residual matrix, which takes into account the rounding -C errors in forming it, is given in the array R. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix R is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and R. N >= 0. -C -C XANORM (input) DOUBLE PRECISION -C The absolute (maximal) norm of the symmetric solution -C matrix X of the Lyapunov equation. XANORM >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the absolute residual matrix R, with -C bounds on rounding errors added. -C On exit, the leading N-by-N part of this array contains -C the symmetric absolute residual matrix R (with bounds on -C rounding errors added), fully stored. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,N). -C -C FERR (output) DOUBLE PRECISION -C An estimated forward error bound for the solution X. -C If XTRUE is the true solution, FERR bounds the magnitude -C of the largest entry in (X - XTRUE) divided by the -C magnitude of the largest entry in X. -C If N = 0 or XANORM = 0, FERR is set to 0, without any -C calculations. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if N = 0; -C LDWORK >= MAX(3,2*N*N), if N > 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if T has almost reciprocal eigenvalues; perturbed -C values were used to solve Lyapunov equations (but -C the matrix T is unchanged). -C -C METHOD -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [1], based on the 1-norm estimator -C in [2]. -C -C REFERENCES -C -C [1] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C [2] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C The routine can be also used as a final step in estimating a -C forward error bound for the solution of a discrete-time algebraic -C matrix Riccati equation. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER LYAPUN, TRANA, UPLO - INTEGER INFO, LDR, LDT, LDU, LDWORK, N - DOUBLE PRECISION FERR, XANORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), - $ U( LDU, * ) -C .. -C .. Local Scalars .. - LOGICAL LOWER, NOTRNA, UPDATE - CHARACTER TRANAT, UPLOW - INTEGER I, IJ, INFO2, ITMP, J, KASE, NN - DOUBLE PRECISION EST, SCALE, TEMP -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DSCAL, MA02ED, MB01RU, SB03MX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( XANORM.LT.ZERO ) THEN - INFO = -5 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -9 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.0 .OR. - $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03SX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - FERR = ZERO - IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C -C Fill in the remaining triangle of the symmetric residual matrix. -C - CALL MA02ED( UPLO, N, R, LDR ) -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLOW = 'U' - LOWER = .FALSE. - ELSE - UPLOW = 'L' - LOWER = .TRUE. - END IF -C - IF( KASE.EQ.2 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 30 J = 1, N - DO 20 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 20 CONTINUE - IJ = IJ + J - 30 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 50 J = 1, N - DO 40 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 40 CONTINUE - IJ = IJ + N - J - 50 CONTINUE - END IF - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, - $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLOW, N, DWORK, N ) -C - IF( KASE.EQ.2 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF -C - IF( KASE.EQ.1 ) THEN - IJ = 0 - IF( LOWER ) THEN -C -C Scale the lower triangular part of symmetric matrix -C by the residual matrix. -C - DO 70 J = 1, N - DO 60 I = J, N - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 60 CONTINUE - IJ = IJ + J - 70 CONTINUE - ELSE -C -C Scale the upper triangular part of symmetric matrix -C by the residual matrix. -C - DO 90 J = 1, N - DO 80 I = 1, J - IJ = IJ + 1 - DWORK( IJ ) = DWORK( IJ )*R( I, J ) - 80 CONTINUE - IJ = IJ + N - J - 90 CONTINUE - END IF - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLOW, N, DWORK, N ) - GO TO 10 - END IF -C -C UNTIL KASE = 0 -C -C Compute the estimate of the relative error. -C - TEMP = XANORM*SCALE - IF( TEMP.GT.EST ) THEN - FERR = EST / TEMP - ELSE - FERR = ONE - END IF -C - RETURN -C -C *** Last line of SB03SX *** - END diff --git a/slycot/src/SB03SY.f b/slycot/src/SB03SY.f deleted file mode 100644 index 8cdc0c9b..00000000 --- a/slycot/src/SB03SY.f +++ /dev/null @@ -1,451 +0,0 @@ - SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA, - $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To estimate the "separation" between the matrices op(A) and -C op(A)', -C -C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) -C = 1 / norm(inv(Omega)) -C -C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and -C Omega and Theta are linear operators associated to the real -C discrete-time Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = C, -C -C defined by -C -C Omega(W) = op(A)'*W*op(A) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). -C -C The 1-norm condition estimators are used. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'S': Compute the separation only; -C = 'T': Compute the norm of Theta only; -C = 'B': Compute both the separation and the norm of Theta. -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original Lyapunov equations -C should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A and X. N >= 0. -C -C T (input) DOUBLE PRECISION array, dimension (LDT,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,N). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array must contain the -C orthogonal matrix U from a real Schur factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C XA (input) DOUBLE PRECISION array, dimension (LDXA,N) -C The leading N-by-N part of this array must contain the -C matrix product X*op(A), if LYAPUN = 'O', or U'*X*U*op(T), -C if LYAPUN = 'R', in the Lyapunov equation. -C If JOB = 'S', the array XA is not referenced. -C -C LDXA INTEGER -C The leading dimension of array XA. -C LDXA >= 1, if JOB = 'S'; -C LDXA >= MAX(1,N), if JOB = 'T' or 'B'. -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEPD contains -C the estimated quantity sepd(op(A),op(A)'). -C If JOB = 'T' or N = 0, SEPD is not referenced. -C -C THNORM (output) DOUBLE PRECISION -C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains -C the estimated 1-norm of operator Theta. -C If JOB = 'S' or N = 0, THNORM is not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if N = 0; -C LDWORK >= MAX(3,2*N*N), if N > 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = N+1: if T has (almost) reciprocal eigenvalues; -C perturbed values were used to solve Lyapunov -C equations (but the matrix T is unchanged). -C -C METHOD -C -C SEPD is defined as -C -C sepd( op(A), op(A)' ) = sigma_min( K ) -C -C where sigma_min(K) is the smallest singular value of the -C N*N-by-N*N matrix -C -C K = kprod( op(A)', op(A)' ) - I(N**2). -C -C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the -C Kronecker product. The routine estimates sigma_min(K) by the -C reciprocal of an estimate of the 1-norm of inverse(K), computed as -C suggested in [1]. This involves the solution of several discrete- -C time Lyapunov equations, either direct or transposed. The true -C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by -C more than a factor of N. -C The 1-norm of Theta is estimated similarly. -C -C REFERENCES -C -C [1] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or -C complex matrix, with applications to condition estimation. -C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C FURTHER COMMENTS -C -C When SEPD is zero, the routine returns immediately, with THNORM -C (if requested) not set. In this case, the equation is singular. -C The option LYAPUN = 'R' may occasionally produce slightly worse -C or better estimates, and it is much faster than the option 'O'. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, -C Tech. University of Sofia, March 1998 (and December 1998). -C -C REVISIONS -C -C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB, LYAPUN, TRANA - INTEGER INFO, LDT, LDU, LDWORK, LDXA, N - DOUBLE PRECISION SEPD, THNORM -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), - $ XA( LDXA, * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, UPDATE, WANTS, WANTT - CHARACTER TRANAT, UPLO - INTEGER INFO2, ITMP, KASE, NN - DOUBLE PRECISION BIGNUM, EST, SCALE -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, - $ SB03MX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - WANTS = LSAME( JOB, 'S' ) - WANTT = LSAME( JOB, 'T' ) - NOTRNA = LSAME( TRANA, 'N' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C - NN = N*N - INFO = 0 - IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN - INFO = -8 - ELSE IF( LDXA.LT.1 .OR. ( .NOT.WANTS .AND. LDXA.LT.N ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.0 .OR. - $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03SY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C - ITMP = NN + 1 -C - IF( NOTRNA ) THEN - TRANAT = 'T' - ELSE - TRANAT = 'N' - END IF -C - IF( .NOT.WANTT ) THEN -C -C Estimate sepd(op(A),op(A)'). -C Workspace: max(3,2*N*N). -C - KASE = 0 -C -C REPEAT - 10 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 10 - END IF -C UNTIL KASE = 0 -C - IF( EST.GT.SCALE ) THEN - SEPD = SCALE / EST - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( SCALE.LT.EST*BIGNUM ) THEN - SEPD = SCALE / EST - ELSE - SEPD = BIGNUM - END IF - END IF -C -C Return if the equation is singular. -C - IF( SEPD.EQ.ZERO ) - $ RETURN - END IF -C - IF( .NOT.WANTS ) THEN -C -C Estimate norm(Theta). -C Workspace: max(3,2*N*N). -C - KASE = 0 -C -C REPEAT - 20 CONTINUE - CALL DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - IF( KASE.NE.0 ) THEN -C -C Select the triangular part of symmetric matrix to be used. -C - IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) - $ .GE. - $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) - $ ) THEN - UPLO = 'U' - ELSE - UPLO = 'L' - END IF -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) -C -C Compute RHS = op(W)'*X*op(A) + op(A)'*X*op(W). -C - CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, XA, LDXA, - $ ZERO, DWORK( ITMP ), N ) - CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side: RHS := U'*RHS*U. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, - $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, - $ INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) - END IF - CALL MA02ED( UPLO, N, DWORK, N ) -C - IF( KASE.EQ.1 ) THEN -C -C Solve op(T)'*Y*op(T) - Y = scale*RHS. -C - CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - ELSE -C -C Solve op(T)*W*op(T)' - W = scale*RHS. -C - CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, - $ DWORK( ITMP ), INFO2 ) - END IF -C - IF( INFO2.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back to obtain the solution: Z := U*Z*U', with -C Z = Y or Z = W. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, - $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), - $ NN, INFO2 ) - CALL DSCAL( N, HALF, DWORK, N+1 ) -C -C Fill in the remaining triangle of the symmetric matrix. -C - CALL MA02ED( UPLO, N, DWORK, N ) - END IF -C - GO TO 20 - END IF -C UNTIL KASE = 0 -C - IF( EST.LT.SCALE ) THEN - THNORM = EST / SCALE - ELSE - BIGNUM = ONE / DLAMCH( 'Safe minimum' ) - IF( EST.LT.SCALE*BIGNUM ) THEN - THNORM = EST / SCALE - ELSE - THNORM = BIGNUM - END IF - END IF - END IF -C - RETURN -C *** Last line of SB03SY *** - END diff --git a/slycot/src/SB03TD.f b/slycot/src/SB03TD.f deleted file mode 100644 index a1a81961..00000000 --- a/slycot/src/SB03TD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, - $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real continuous-time Lyapunov matrix equation -C -C op(A)'*X + X*op(A) = scale*C, -C -C estimate the conditioning, and compute an error bound on the -C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, -C the right hand side C and the solution X are N-by-N symmetric -C matrices (C = C', X = X'), and scale is an output scale factor, -C set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'A': Compute all: the solution, separation, reciprocal -C condition number, and the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original or "reduced" -C Lyapunov equations should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C This means that a real Schur form T of A appears -C in the equation, instead of A. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C SCALE (input or output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'E', SCALE is an input argument: -C the scale factor, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C If JOB = 'X' or JOB = 'A', SCALE is an output argument: -C the scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C If JOB = 'S', this argument is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the -C leading N-by-N part of this array must contain the -C original matrix A. -C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and -C JOB <> 'X'; -C LDA >= 1, otherwise. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C The contents of array T is not modified if FACT = 'F'. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C The remaining strictly triangular part of this array is -C used as workspace. -C If JOB = 'X', then this array may be identified with X -C in the call of this routine. -C If JOB = 'S', the array C is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C X (input or output) DOUBLE PRECISION array, dimension -C (LDX,N) -C If JOB = 'C' or 'E', then X is an input argument and on -C entry, the leading N-by-N part of this array must contain -C the symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB = 'X' or 'A', then X is an output argument and on -C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part -C of this array contains the symmetric solution matrix X of -C of the original Lyapunov equation (with matrix A), if -C LYAPUN = 'O', or of the reduced Lyapunov equation (with -C matrix T), if LYAPUN = 'R'. -C If JOB = 'S', the array X is not referenced. -C -C LDX INTEGER -C The leading dimension of the array X. -C LDX >= 1, if JOB = 'S'; -C LDX >= MAX(1,N), otherwise. -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or -C INFO = N+1, SEP contains the estimated separation of the -C matrices op(A) and -op(A)', sep(op(A),-op(A)'). -C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not -C referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal -C condition number of the continuous-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not -C referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, -C FERR contains an estimated forward error bound for the -C solution X. If XTRUE is the true solution, FERR bounds the -C relative error in the computed solution, measured in the -C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not -C referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If JOB = 'X', then -C LDWORK >= MAX(1,N*N), if FACT = 'F'; -C LDWORK >= MAX(1,MAX(N*N,3*N)), if FACT = 'N'. -C If JOB = 'S' or JOB = 'C', then -C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; -C LDWORK >= MAX(1,2*N*N,3*N), if FACT = 'N'. -C If JOB = 'E', or JOB = 'A', and LYAPUN = 'O', then -C LDWORK >= MAX(1,3*N*N); -C If JOB = 'E', or JOB = 'A', and LYAPUN = 'R', then -C LDWORK >= MAX(1,3*N*N+N-1). -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and the elements i+1:n of WR and WI -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrices T and -T' have common or very -C close eigenvalues; perturbed values were used to -C solve Lyapunov equations, but the matrix T, if given -C (for FACT = 'F'), is unchanged. -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C the Bartels-Stewart algorithm is used. A set of equivalent linear -C algebraic systems of equations of order at most four are formed -C and solved using Gaussian elimination with complete pivoting. -C -C The condition number of the continuous-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W + W*op(A), -C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). -C -C The routine estimates the quantities -C -C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [2]. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The separation of op(A) and -op(A)' can also be defined as -C -C sep( op(A), -op(A)' ) = sigma_min( T ), -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). -C -C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker -C product. The routine estimates sigma_min(T) by the reciprocal of -C an estimate of the 1-norm of inverse(T). The true reciprocal -C 1-norm of inverse(T) cannot differ from sigma_min(T) by more -C than a factor of N. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C This is an extended and improved version of Release 3.0 routine -C SB03RD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, - $ NOTRNA, UPDATE - CHARACTER CFACT, JOBL, SJOB - INTEGER LDW, NN, SDIM - DOUBLE PRECISION THNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MY, - $ SB03QD, SB03QY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode option parameters. -C - JOBX = LSAME( JOB, 'X' ) - JOBS = LSAME( JOB, 'S' ) - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBA = LSAME( JOB, 'A' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C -C Compute workspace. -C - NN = N*N - IF( JOBX ) THEN - LDW = NN - ELSE IF( JOBS .OR. JOBC ) THEN - LDW = 2*NN - ELSE - LDW = 3*NN - END IF - IF( ( JOBE .OR. JOBA ).AND. .NOT.UPDATE ) - $ LDW = LDW + N - 1 - IF( NOFACT ) - $ LDW = MAX( LDW, 3*N ) -C -C Test the scalar input parameters. -C - INFO = 0 - IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( ( JOBC .OR. JOBE ) .AND. - $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. - $ NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.1 .OR. ( LDWORK.LT.LDW ) ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( JOBX .OR. JOBA ) - $ SCALE = ONE - IF( JOBC .OR. JOBA ) - $ RCOND = ONE - IF( JOBE .OR. JOBA ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, - $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - CFACT = 'F' - ELSE - CFACT = FACT - END IF -C - IF( JOBX .OR. JOBA ) THEN -C -C Copy the right-hand side in X. -C - CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, - $ LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) - END IF -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) -C -C Solve the transformed equation. -C - CALL SB03MY( TRANA, N, T, LDT, X, LDX, SCALE, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back the solution. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, - $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) - END IF - END IF -C - IF( JOBS ) THEN -C -C Estimate sep(op(A),-op(A)'). -C Workspace: 2*N*N. -C - CALL SB03QY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, X, - $ LDX, SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C - ELSE IF( .NOT.JOBX ) THEN -C -C Estimate the reciprocal condition and/or the error bound. -C Workspace: 2*N*N, if JOB = 'C'; -C 3*N*N + a*(N-1), where: -C a = 1, if JOB = 'E' or JOB = 'A', and LYAPUN = 'R'; -C a = 0, otherwise. -C - IF( JOBA ) THEN - JOBL = 'B' - ELSE - JOBL = JOB - END IF - CALL SB03QD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, - $ FERR, IWORK, DWORK, LDWORK, INFO ) - LDW = MAX( LDW, INT( DWORK( 1 ) ) ) - END IF -C - DWORK( 1 ) = DBLE( LDW ) -C - RETURN -C *** Last line of SB03TD *** - END diff --git a/slycot/src/SB03UD.f b/slycot/src/SB03UD.f deleted file mode 100644 index f09443eb..00000000 --- a/slycot/src/SB03UD.f +++ /dev/null @@ -1,554 +0,0 @@ - SUBROUTINE SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, - $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve the real discrete-time Lyapunov matrix equation -C -C op(A)'*X*op(A) - X = scale*C, -C -C estimate the conditioning, and compute an error bound on the -C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, -C the right hand side C and the solution X are N-by-N symmetric -C matrices (C = C', X = X'), and scale is an output scale factor, -C set less than or equal to 1 to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Specifies the computation to be performed, as follows: -C = 'X': Compute the solution only; -C = 'S': Compute the separation only; -C = 'C': Compute the reciprocal condition number only; -C = 'E': Compute the error bound only; -C = 'A': Compute all: the solution, separation, reciprocal -C condition number, and the error bound. -C -C FACT CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, T and U (if LYAPUN = 'O') contain the -C factors from the real Schur factorization of the -C matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in T and U (if -C LYAPUN = 'O'). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C UPLO CHARACTER*1 -C Specifies which part of the symmetric matrix C is to be -C used, as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C -C LYAPUN CHARACTER*1 -C Specifies whether or not the original or "reduced" -C Lyapunov equations should be solved, as follows: -C = 'O': Solve the original Lyapunov equations, updating -C the right-hand sides and solutions with the -C matrix U, e.g., X <-- U'*X*U; -C = 'R': Solve reduced Lyapunov equations only, without -C updating the right-hand sides and solutions. -C This means that a real Schur form T of A appears -C in the equation, instead of A. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, X, and C. N >= 0. -C -C SCALE (input or output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'E', SCALE is an input argument: -C the scale factor, set by a Lyapunov solver. -C 0 <= SCALE <= 1. -C If JOB = 'X' or JOB = 'A', SCALE is an output argument: -C the scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C If JOB = 'S', this argument is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the -C leading N-by-N part of this array must contain the -C original matrix A. -C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is -C not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. -C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and -C JOB <> 'X'; -C LDA >= 1, otherwise. -C -C T (input/output) DOUBLE PRECISION array, dimension -C (LDT,N) -C If FACT = 'F', then on entry the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C quasi-triangular matrix T in Schur canonical form from a -C Schur factorization of A. -C If FACT = 'N', then this array need not be set on input. -C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the -C leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix T in Schur -C canonical form from a Schur factorization of A. -C The contents of array T is not modified if FACT = 'F'. -C -C LDT INTEGER -C The leading dimension of the array T. LDT >= MAX(1,N). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,N) -C If LYAPUN = 'O' and FACT = 'F', then U is an input -C argument and on entry, the leading N-by-N part of this -C array must contain the orthogonal matrix U from a real -C Schur factorization of A. -C If LYAPUN = 'O' and FACT = 'N', then U is an output -C argument and on exit, if INFO = 0 or INFO = N+1, it -C contains the orthogonal N-by-N matrix from a real Schur -C factorization of A. -C If LYAPUN = 'R', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of the array U. -C LDU >= 1, if LYAPUN = 'R'; -C LDU >= MAX(1,N), if LYAPUN = 'O'. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the matrix C of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C The remaining strictly triangular part of this array is -C used as workspace. -C If JOB = 'X', then this array may be identified with X -C in the call of this routine. -C If JOB = 'S', the array C is not referenced. -C -C LDC INTEGER -C The leading dimension of the array C. -C LDC >= 1, if JOB = 'S'; -C LDC >= MAX(1,N), otherwise. -C -C X (input or output) DOUBLE PRECISION array, dimension -C (LDX,N) -C If JOB = 'C' or 'E', then X is an input argument and on -C entry, the leading N-by-N part of this array must contain -C the symmetric solution matrix X of the original Lyapunov -C equation (with matrix A), if LYAPUN = 'O', or of the -C reduced Lyapunov equation (with matrix T), if -C LYAPUN = 'R'. -C If JOB = 'X' or 'A', then X is an output argument and on -C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part -C of this array contains the symmetric solution matrix X of -C of the original Lyapunov equation (with matrix A), if -C LYAPUN = 'O', or of the reduced Lyapunov equation (with -C matrix T), if LYAPUN = 'R'. -C If JOB = 'S', the array X is not referenced. -C -C LDX INTEGER -C The leading dimension of the array X. -C LDX >= 1, if JOB = 'S'; -C LDX >= MAX(1,N), otherwise. -C -C SEPD (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or -C INFO = N+1, SEPD contains the estimated separation of the -C matrices op(A) and op(A)', sepd(op(A),op(A)'). -C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEPD is not -C referenced. -C -C RCOND (output) DOUBLE PRECISION -C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal -C condition number of the continuous-time Lyapunov equation. -C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. -C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not -C referenced. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, -C FERR contains an estimated forward error bound for the -C solution X. If XTRUE is the true solution, FERR bounds the -C relative error in the computed solution, measured in the -C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). -C If N = 0 or X = 0, FERR is set to 0. -C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not -C referenced. -C -C WR (output) DOUBLE PRECISION array, dimension (N) -C WI (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI -C contain the real and imaginary parts, respectively, of the -C eigenvalues of A. -C If FACT = 'F', WR and WI are not referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N*N) -C This array is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the -C optimal value of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If JOB = 'X', then -C LDWORK >= MAX(1,N*N,2*N), if FACT = 'F'; -C LDWORK >= MAX(1,N*N,3*N), if FACT = 'N'. -C If JOB = 'S', then -C LDWORK >= MAX(3,2*N*N). -C If JOB = 'C', then -C LDWORK >= MAX(3,2*N*N) + N*N. -C If JOB = 'E', or JOB = 'A', then -C LDWORK >= MAX(3,2*N*N) + N*N + 2*N. -C For optimum performance LDWORK should sometimes be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, i <= N, the QR algorithm failed to -C complete the reduction to Schur canonical form (see -C LAPACK Library routine DGEES); on exit, the matrix -C T(i+1:N,i+1:N) contains the partially converged -C Schur form, and the elements i+1:n of WR and WI -C contain the real and imaginary parts, respectively, -C of the converged eigenvalues; this error is unlikely -C to appear; -C = N+1: if the matrix T has almost reciprocal eigenvalues; -C perturbed values were used to solve Lyapunov -C equations, but the matrix T, if given (for -C FACT = 'F'), is unchanged. -C -C METHOD -C -C After reducing matrix A to real Schur canonical form (if needed), -C a discrete-time version of the Bartels-Stewart algorithm is used. -C A set of equivalent linear algebraic systems of equations of order -C at most four are formed and solved using Gaussian elimination with -C complete pivoting. -C -C The condition number of the discrete-time Lyapunov equation is -C estimated as -C -C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), -C -C where Omega and Theta are linear operators defined by -C -C Omega(W) = op(A)'*W*op(A) - W, -C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). -C -C The routine estimates the quantities -C -C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) -C -C and norm(Theta) using 1-norm condition estimators. -C -C The forward error bound is estimated using a practical error bound -C similar to the one proposed in [3]. -C -C REFERENCES -C -C [1] Barraud, A.Y. T -C A numerical algorithm to solve A XA - X = Q. -C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. -C -C [2] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [3] Higham, N.J. -C Perturbation theory and backward error for AX-XB=C. -C BIT, vol. 33, pp. 124-136, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C The accuracy of the estimates obtained depends on the solution -C accuracy and on the properties of the 1-norm estimator. -C -C FURTHER COMMENTS -C -C The "separation" sepd of op(A) and op(A)' can also be defined as -C -C sepd( op(A), op(A)' ) = sigma_min( T ), -C -C where sigma_min(T) is the smallest singular value of the -C N*N-by-N*N matrix -C -C T = kprod( op(A)', op(A)' ) - I(N**2). -C -C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the -C Kronecker product. The routine estimates sigma_min(T) by the -C reciprocal of an estimate of the 1-norm of inverse(T). The true -C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by -C more than a factor of N. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. -C This is an extended and improved version of Release 3.0 routine -C SB03PD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. -C -C KEYWORDS -C -C Lyapunov equation, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO - INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N - DOUBLE PRECISION FERR, RCOND, SCALE, SEPD -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), - $ X( LDX, * ) -C .. -C .. Local Scalars .. - LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, - $ NOTRNA, UPDATE - CHARACTER CFACT, JOBL, SJOB - INTEGER LDW, NN, SDIM - DOUBLE PRECISION THNORM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MX, - $ SB03SD, SB03SY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode option parameters. -C - JOBX = LSAME( JOB, 'X' ) - JOBS = LSAME( JOB, 'S' ) - JOBC = LSAME( JOB, 'C' ) - JOBE = LSAME( JOB, 'E' ) - JOBA = LSAME( JOB, 'A' ) - NOFACT = LSAME( FACT, 'N' ) - NOTRNA = LSAME( TRANA, 'N' ) - LOWER = LSAME( UPLO, 'L' ) - UPDATE = LSAME( LYAPUN, 'O' ) -C -C Compute workspace. -C - NN = N*N - IF( JOBX ) THEN - IF( NOFACT ) THEN - LDW = MAX( 1, NN, 3*N ) - ELSE - LDW = MAX( 1, NN, 2*N ) - END IF - ELSE IF( JOBS ) THEN - LDW = MAX( 3, 2*NN ) - ELSE IF( JOBC ) THEN - LDW = MAX( 3, 2*NN ) + NN - ELSE - LDW = MAX( 3, 2*NN ) + NN + 2*N - END IF -C -C Test the scalar input parameters. -C - INFO = 0 - IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN - INFO = -1 - ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. - $ LSAME( TRANA, 'C' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( ( JOBC .OR. JOBE ) .AND. - $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN - INFO = -7 - ELSE IF( LDA.LT.1 .OR. - $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. - $ NOFACT ) ) ) THEN - INFO = -9 - ELSE IF( LDT.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.LDW ) THEN - INFO = -25 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB03UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - IF( JOBX .OR. JOBA ) - $ SCALE = ONE - IF( JOBC .OR. JOBA ) - $ RCOND = ONE - IF( JOBE .OR. JOBA ) - $ FERR = ZERO - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( NOFACT ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 3*N; -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, - $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.GT.0 ) - $ RETURN - LDW = MAX( LDW, INT( DWORK( 1 ) ) ) - CFACT = 'F' - ELSE - CFACT = FACT - END IF -C - IF( JOBX .OR. JOBA ) THEN -C -C Copy the right-hand side in X. -C - CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) -C - IF( UPDATE ) THEN -C -C Transform the right-hand side. -C Workspace: need N*N. -C - CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, - $ LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) - END IF -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) -C -C Solve the transformed equation. -C Workspace: 2*N. -C - CALL SB03MX( TRANA, N, T, LDT, X, LDX, SCALE, DWORK, INFO ) - IF( INFO.GT.0 ) - $ INFO = N + 1 -C - IF( UPDATE ) THEN -C -C Transform back the solution. -C - CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, - $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) - CALL DSCAL( N, HALF, X, LDX+1 ) -C -C Fill in the remaining triangle of X. -C - CALL MA02ED( UPLO, N, X, LDX ) - END IF - END IF -C - IF( JOBS ) THEN -C -C Estimate sepd(op(A),op(A)'). -C Workspace: MAX(3,2*N*N). -C - CALL SB03SY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, - $ DWORK, 1, SEPD, THNORM, IWORK, DWORK, LDWORK, - $ INFO ) -C - ELSE IF( .NOT.JOBX ) THEN -C -C Estimate the reciprocal condition and/or the error bound. -C Workspace: MAX(3,2*N*N) + N*N + a*N, where: -C a = 2, if JOB = 'E' or JOB = 'A'; -C a = 0, otherwise. -C - IF( JOBA ) THEN - JOBL = 'B' - ELSE - JOBL = JOB - END IF - CALL SB03SD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, - $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, - $ FERR, IWORK, DWORK, LDWORK, INFO ) - LDW = MAX( LDW, INT( DWORK( 1 ) ) ) - END IF -C - DWORK( 1 ) = DBLE( LDW ) -C - RETURN -C *** Last line of SB03UD *** - END diff --git a/slycot/src/SB04MD.f b/slycot/src/SB04MD.f deleted file mode 100644 index c618c8ac..00000000 --- a/slycot/src/SB04MD.f +++ /dev/null @@ -1,347 +0,0 @@ - SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the continuous-time Sylvester equation -C -C AX + XB = C -C -C where A, B, C and X are general N-by-N, M-by-M, N-by-M and -C N-by-M matrices respectively. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A of the equation. -C On exit, the leading N-by-N upper Hessenberg part of this -C array contains the matrix H, and the remainder of the -C leading N-by-N part, together with the elements 2,3,...,N -C of array DWORK, contain the orthogonal transformation -C matrix U (stored in factored form). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix B of the equation. -C On exit, the leading M-by-M part of this array contains -C the quasi-triangular Schur factor S of the matrix B'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading N-by-M part of this array contains -C the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) -C The leading M-by-M part of this array contains the -C orthogonal matrix Z used to transform B' to real upper -C Schur form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,M). -C -C Workspace -C -C IWORK INTEGER array, dimension (4*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain -C the scalar factors of the elementary reflectors used to -C reduce A to upper Hessenberg form, as returned by LAPACK -C Library routine DGEHRD. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to -C compute all the eigenvalues (see LAPACK Library -C routine DGEES); -C > M: if a singular matrix was encountered whilst solving -C for the (INFO-M)-th column of matrix X. -C -C METHOD -C -C The matrix A is transformed to upper Hessenberg form H = U'AU by -C the orthogonal transformation matrix U; matrix B' is transformed -C to real upper Schur form S = Z'B'Z using the orthogonal -C transformation matrix Z. The matrix C is also multiplied by the -C transformations, F = U'CZ, and the solution matrix Y of the -C transformed system -C -C HY + YS' = F -C -C is computed by back substitution. Finally, the matrix Y is then -C multiplied by the orthogonal transformation matrices, X = UYZ', in -C order to obtain the solution matrix X to the original problem. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C 3 3 2 2 -C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N -C operations and is backward stable. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, - $ SDIM, WRKOPT -C .. Local Scalars .. - LOGICAL SELECT -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, - $ DORMHR, DSWAP, SB04MU, SB04MY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 8*N, 5*M, N + M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ILO = 1 - IHI = N - WRKOPT = 1 -C -C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper -C triangular. That is, H = U' * A * U (store U in factored -C form) and S = Z' * B' * Z (save Z). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 20 I = 2, M - CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) - 20 CONTINUE -C -C Workspace: need 5*M; -C prefer larger. -C - IEIG = M + 1 - JWORK = IEIG + M - CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, - $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), - $ LDWORK-JWORK+1, BWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need 2*N; -C prefer N + N*NB. -C - ITAU = 2 - JWORK = ITAU + N - 1 - CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN - CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, - $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) - WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M ) - ELSE -C - DO 40 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 40 CONTINUE -C - END IF -C - IND = M - 60 CONTINUE - IF ( IND.GT.1 ) THEN -C -C Step 3 : Solve H * Y + Y * S' = F for Y. -C - IF ( B(IND,IND-1).EQ.ZERO ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N. -C - CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) - IND = IND - 1 - ELSE -C -C Solve a special linear algebraic system of order 2*N. -C Workspace: 2*N*N + 8*N; -C - CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 ) - IND = IND - 2 - END IF - GO TO 60 - ELSE IF ( IND.EQ.1 ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N; -C - CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) - END IF -C -C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN - CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, - $ Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) - ELSE -C - DO 80 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 80 CONTINUE - END IF -C - RETURN -C *** Last line of SB04MD *** - END diff --git a/slycot/src/SB04MR.f b/slycot/src/SB04MR.f deleted file mode 100644 index a8aa560c..00000000 --- a/slycot/src/SB04MR.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE SB04MR( M, D, IPR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a linear algebraic system of order M whose coefficient -C matrix has zeros below the second subdiagonal. The matrix is -C stored compactly, row-wise. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the system. M >= 0. -C Note that parameter M should have twice the value in the -C original problem (see SLICOT Library routine SB04MU). -C -C D (input/output) DOUBLE PRECISION array, dimension -C (M*(M+1)/2+3*M) -C On entry, the first M*(M+1)/2 + 2*M elements of this array -C must contain the coefficient matrix, stored compactly, -C row-wise, and the next M elements must contain the right -C hand side of the linear system, as set by SLICOT Library -C routine SB04MU. -C On exit, the content of this array is updated, the last M -C elements containing the solution with components -C interchanged (see IPR). -C -C IPR (output) INTEGER array, dimension (2*M) -C The leading M elements contain information about the -C row interchanges performed for solving the system. -C Specifically, the i-th component of the solution is -C specified by IPR(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if a singular matrix was encountered. -C -C METHOD -C -C Gaussian elimination with partial pivoting is used. The rows of -C the matrix are not actually permuted, only their indices are -C interchanged in array IPR. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AR by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION D(*) -C .. Local Scalars .. - INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, - $ MPI2 - DOUBLE PRECISION D1, D2, D3, DMAX -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - I2 = ( M*( M + 5 ) )/2 - MPI = M - IPRM = I2 - M1 = M - I1 = 1 -C - DO 20 I = 1, M - MPI = MPI + 1 - IPRM = IPRM + 1 - IPR(MPI) = I1 - IPR(I) = IPRM - I1 = I1 + M1 - IF ( I.GE.3 ) M1 = M1 - 1 - 20 CONTINUE -C - M1 = M - 1 - MPI1 = M + 1 -C -C Reduce to upper triangular form. -C - DO 80 I = 1, M1 - MPI = MPI1 - MPI1 = MPI1 + 1 - IPRM = IPR(MPI) - D1 = D(IPRM) - I1 = 2 - IF ( I.EQ.M1 ) I1 = 1 - MPI2 = MPI + I1 - L = 0 - DMAX = ABS( D1 ) -C - DO 40 J = MPI1, MPI2 - D2 = D(IPR(J)) - D3 = ABS( D2 ) - IF ( D3.GT.DMAX ) THEN - DMAX = D3 - D1 = D2 - L = J - MPI - END IF - 40 CONTINUE -C -C Check singularity. -C - IF ( DMAX.EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C - IF ( L.GT.0 ) THEN -C -C Permute the row indices. -C - K = IPRM - J = MPI + L - IPRM = IPR(J) - IPR(J) = K - IPR(MPI) = IPRM - K = IPR(I) - I2 = I + L - IPR(I) = IPR(I2) - IPR(I2) = K - END IF - IPRM = IPRM + 1 -C -C Annihilate the subdiagonal elements of the matrix. -C - I2 = I - D3 = D(IPR(I)) -C - DO 60 J = MPI1, MPI2 - I2 = I2 + 1 - IPRM1 = IPR(J) - DMAX = -D(IPRM1)/D1 - D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 - CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) - 60 CONTINUE -C - IPR(MPI1) = IPR(MPI1) + 1 - IF ( I.NE.M1 ) IPR(MPI2) = IPR(MPI2) + 1 - 80 CONTINUE -C - MPI = M + M - IPRM = IPR(MPI) -C -C Check singularity. -C - IF ( D(IPRM).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C -C Back substitution. -C - D(IPR(M)) = D(IPR(M))/D(IPRM) -C - DO 120 I = M1, 1, -1 - MPI = MPI - 1 - IPRM = IPR(MPI) - IPRM1 = IPRM - DMAX = ZERO -C - DO 100 K = I+1, M - IPRM1 = IPRM1 + 1 - DMAX = DMAX + D(IPR(K))*D(IPRM1) - 100 CONTINUE -C - D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) - 120 CONTINUE -C - RETURN -C *** Last line of SB04MR *** - END diff --git a/slycot/src/SB04MU.f b/slycot/src/SB04MU.f deleted file mode 100644 index ed3879ec..00000000 --- a/slycot/src/SB04MU.f +++ /dev/null @@ -1,190 +0,0 @@ - SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order 2*M -C whose coefficient matrix has zeros below the second subdiagonal. -C Such systems appear when solving continuous-time Sylvester -C equations using the Hessenberg-Schur method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C IND and IND - 1 specify the indices of the columns in C -C to be computed. IND > 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with columns IND-1 and IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (2*M*M+7*M) -C -C IPR INTEGER array, dimension (4*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order 2*M, whose coefficient -C matrix has zeros below the second subdiagonal is constructed and -C solved. The coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AU by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, IND1, J, K, K1, K2, M2 - DOUBLE PRECISION TEMP -C .. External Subroutines .. - EXTERNAL DAXPY, SB04MR -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - IND1 = IND - 1 -C - DO 20 I = IND + 1, N - CALL DAXPY( M, -B(IND1,I), C(1,I), 1, C(1,IND1), 1 ) - CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) - 20 CONTINUE -C -C Construct the linear algebraic system of order 2*M. -C - K1 = -1 - M2 = 2*M - I2 = M*(M2 + 5) - K = M2 -C - DO 60 I = 1, M -C - DO 40 J = MAX( 1, I - 1 ), M - K1 = K1 + 2 - K2 = K1 + K - TEMP = A(I,J) - IF ( I.NE.J ) THEN - D(K1) = TEMP - D(K1+1) = ZERO - IF ( J.GT.I ) D(K2) = ZERO - D(K2+1) = TEMP - ELSE - D(K1) = TEMP + B(IND1,IND1) - D(K1+1) = B(IND1,IND) - D(K2) = B(IND,IND1) - D(K2+1) = TEMP + B(IND,IND) - END IF - 40 CONTINUE -C - K1 = K2 - K = K - MIN( 2, I ) -C -C Store the right hand side. -C - I2 = I2 + 2 - D(I2) = C(I,IND) - D(I2-1) = C(I,IND1) - 60 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04MR( M2, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE - I2 = 0 -C - DO 80 I = 1, M - I2 = I2 + 2 - C(I,IND1) = D(IPR(I2-1)) - C(I,IND) = D(IPR(I2)) - 80 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04MU *** - END diff --git a/slycot/src/SB04MW.f b/slycot/src/SB04MW.f deleted file mode 100644 index 9a56f465..00000000 --- a/slycot/src/SB04MW.f +++ /dev/null @@ -1,194 +0,0 @@ - SUBROUTINE SB04MW( M, D, IPR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a linear algebraic system of order M whose coefficient -C matrix is in upper Hessenberg form, stored compactly, row-wise. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the system. M >= 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (M*(M+1)/2+2*M) -C On entry, the first M*(M+1)/2 + M elements of this array -C must contain an upper Hessenberg matrix, stored compactly, -C row-wise, and the next M elements must contain the right -C hand side of the linear system, as set by SLICOT Library -C routine SB04MY. -C On exit, the content of this array is updated, the last M -C elements containing the solution with components -C interchanged (see IPR). -C -C IPR (output) INTEGER array, dimension (2*M) -C The leading M elements contain information about the -C row interchanges performed for solving the system. -C Specifically, the i-th component of the solution is -C specified by IPR(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if a singular matrix was encountered. -C -C METHOD -C -C Gaussian elimination with partial pivoting is used. The rows of -C the matrix are not actually permuted, only their indices are -C interchanged in array IPR. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION D(*) -C .. Local Scalars .. - INTEGER I, I1, IPRM, IPRM1, K, M1, M2, MPI - DOUBLE PRECISION D1, D2, MULT -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 - M1 = ( M*( M + 3 ) )/2 - M2 = M + M - MPI = M - IPRM = M1 - M1 = M - I1 = 1 -C - DO 20 I = 1, M - MPI = MPI + 1 - IPRM = IPRM + 1 - IPR(MPI) = I1 - IPR(I) = IPRM - I1 = I1 + M1 - IF ( I.GT.1 ) M1 = M1 - 1 - 20 CONTINUE -C - M1 = M - 1 - MPI = M -C -C Reduce to upper triangular form. -C - DO 40 I = 1, M1 - I1 = I + 1 - MPI = MPI + 1 - IPRM = IPR(MPI) - IPRM1 = IPR(MPI+1) - D1 = D(IPRM) - D2 = D(IPRM1) - IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN -C -C Permute the row indices. -C - K = IPRM - IPR(MPI) = IPRM1 - IPRM = IPRM1 - IPRM1 = K - K = IPR(I) - IPR(I) = IPR(I1) - IPR(I1) = K - D1 = D2 - END IF -C -C Check singularity. -C - IF ( D1.EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C - MULT = -D(IPRM1)/D1 - IPRM1 = IPRM1 + 1 - IPR(MPI+1) = IPRM1 -C -C Annihilate the subdiagonal elements of the matrix. -C - D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I)) - CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 ) - 40 CONTINUE -C -C Check singularity. -C - IF ( D(IPR(M2)).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C -C Back substitution. -C - D(IPR(M)) = D(IPR(M))/D(IPR(M2)) - MPI = M2 -C - DO 80 I = M1, 1, -1 - MPI = MPI - 1 - IPRM = IPR(MPI) - IPRM1 = IPRM - MULT = ZERO -C - DO 60 I1 = I + 1, M - IPRM1 = IPRM1 + 1 - MULT = MULT + D(IPR(I1))*D(IPRM1) - 60 CONTINUE -C - D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM) - 80 CONTINUE -C - RETURN -C *** Last line of SB04MW *** - END diff --git a/slycot/src/SB04MY.f b/slycot/src/SB04MY.f deleted file mode 100644 index d8e568e7..00000000 --- a/slycot/src/SB04MY.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order M whose -C coefficient matrix is in upper Hessenberg form. Such systems -C appear when solving Sylvester equations using the Hessenberg-Schur -C method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C The index of the column in C to be computed. IND >= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with column IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) -C -C IPR INTEGER array, dimension (2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order M, with coefficient -C matrix in upper Hessenberg form is constructed and solved. The -C coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and -C C. Van Loan, Stanford University, California, United States of -C America, January 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, J, K, K1, K2, M1 -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, SB04MW -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - DO 20 I = IND + 1, N - CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) - 20 CONTINUE -C - M1 = M + 1 - I2 = ( M*M1 )/2 + M1 - K2 = 1 - K = M -C -C Construct the linear algebraic system of order M. -C - DO 40 I = 1, M - J = M1 - K - CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) - K1 = K2 - K2 = K2 + K - IF ( I.GT.1 ) THEN - K1 = K1 + 1 - K = K - 1 - END IF - D(K1) = D(K1) + B(IND,IND) -C -C Store the right hand side. -C - D(I2) = C(I,IND) - I2 = I2 + 1 - 40 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04MW( M, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE -C - DO 60 I = 1, M - C(I,IND) = D(IPR(I)) - 60 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04MY *** - END diff --git a/slycot/src/SB04ND.f b/slycot/src/SB04ND.f deleted file mode 100644 index b567088a..00000000 --- a/slycot/src/SB04ND.f +++ /dev/null @@ -1,405 +0,0 @@ - SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, - $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the continuous-time Sylvester equation -C -C AX + XB = C, -C -C with at least one of the matrices A or B in Schur form and the -C other in Hessenberg or Schur form (both either upper or lower); -C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, -C respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHU CHARACTER*1 -C Indicates whether A and/or B is/are in Schur or -C Hessenberg form as follows: -C = 'A': A is in Schur form, B is in Hessenberg form; -C = 'B': B is in Schur form, A is in Hessenberg form; -C = 'S': Both A and B are in Schur form. -C -C ULA CHARACTER*1 -C Indicates whether A is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and -C upper Schur form otherwise; -C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and -C lower Schur form otherwise. -C -C ULB CHARACTER*1 -C Indicates whether B is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and -C upper Schur form otherwise; -C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and -C lower Schur form otherwise. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading M-by-M part of this array must contain the -C coefficient matrix B of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity in -C the Sylvester equation. If the user sets TOL > 0, then the -C given value of TOL is used as a lower bound for the -C reciprocal condition number; a matrix whose estimated -C condition number is less than 1/TOL is considered to be -C nonsingular. If the user sets TOL <= 0, then a default -C tolerance, defined by TOLDEF = EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*MAX(M,N)) -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; -C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if a (numerically) singular matrix T was encountered -C during the computation of the solution matrix X. -C That is, the estimated reciprocal condition number -C of T is less than or equal to TOL. -C -C METHOD -C -C Matrices A and B are assumed to be in (upper or lower) Hessenberg -C or Schur form (with at least one of them in Schur form). The -C solution matrix X is then computed by rows or columns via the back -C substitution scheme proposed by Golub, Nash and Van Loan (see -C [1]), which involves the solution of triangular systems of -C equations that are constructed recursively and which may be nearly -C singular if A and -B have close eigenvalues. If near singularity -C is detected, then the routine returns with the Error Indicator -C (INFO) set to 1. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires approximately 5M N + 0.5MN operations in -C 2 2 -C the worst case and 2.5M N + 0.5MN operations in the best case -C (where M is the order of the matrix in Hessenberg form and N is -C the order of the matrix in Schur form) and is mixed stable (see -C [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHU, ULA, ULB - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) -C .. Local Scalars .. - CHARACTER ABSCHR - LOGICAL LABSCB, LABSCS, LULA, LULB - INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, - $ LDW, MAXMN - DOUBLE PRECISION SCALE, TOL1 -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - MAXMN = MAX( M, N ) - LABSCB = LSAME( ABSCHU, 'B' ) - LABSCS = LSAME( ABSCHU, 'S' ) - LULA = LSAME( ULA, 'U' ) - LULB = LSAME( ULB, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. - $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB ) - $ .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAXMN.EQ.0 ) - $ RETURN -C - IF ( LABSCS .AND. LULA .AND. LULB ) THEN -C -C If both matrices are in a real Schur form, use DTRSYL. -C - CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B, - $ LDB, C, LDC, SCALE, INFO ) - IF ( SCALE.NE.ONE ) - $ INFO = 1 - RETURN - END IF -C - LDW = 2*MAXMN - JWORK = LDW*LDW + 3*LDW + 1 - TOL1 = TOL - IF ( TOL1.LE.ZERO ) - $ TOL1 = DLAMCH( 'Epsilon' ) -C -C Choose the smallest of both matrices as the one in Hessenberg -C form when possible. -C - ABSCHR = ABSCHU - IF ( LABSCS ) THEN - IF ( N.GT.M ) THEN - ABSCHR = 'A' - ELSE - ABSCHR = 'B' - END IF - END IF - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C B is in Schur form: recursion on the columns of B. -C - IF ( LULB ) THEN -C -C B is upper: forward recursion. -C - IBEG = 1 - IEND = M - FWD = 1 - INCR = 0 - ELSE -C -C B is lower: backward recursion. -C - IBEG = M - IEND = 1 - FWD = -1 - INCR = -1 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( B(I+FWD,I).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, - $ DWORK(JWORK) ) - CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) - ELSE - IPINCR = I + INCR - CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, - $ DWORK(JWORK) ) - CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), - $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), - $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) - CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) - END IF - I = I + FWD*ISTEP - GO TO 20 - END IF -C END WHILE 20 - ELSE -C -C A is in Schur form: recursion on the rows of A. -C - IF ( LULA ) THEN -C -C A is upper: backward recursion. -C - IBEG = N - IEND = 1 - FWD = -1 - INCR = -1 - ELSE -C -C A is lower: forward recursion. -C - IBEG = 1 - IEND = N - FWD = 1 - INCR = 0 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( A(I,I+FWD).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, - $ DWORK(JWORK) ) - CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - ELSE - IPINCR = I + INCR - CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, - $ DWORK(JWORK) ) - CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), - $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), - $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) - CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) - END IF - I = I + FWD*ISTEP - GO TO 40 - END IF -C END WHILE 40 - END IF -C - RETURN -C *** Last line of SB04ND *** - END diff --git a/slycot/src/SB04NV.f b/slycot/src/SB04NV.f deleted file mode 100644 index bb09f277..00000000 --- a/slycot/src/SB04NV.f +++ /dev/null @@ -1,165 +0,0 @@ - SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand sides D for a system of equations in -C Hessenberg form solved via SB04NX (case with 2 right-hand sides). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation AX + XB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the first column/row of C to be used in -C the construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C AX + XB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading 2*N or 2*M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side stored as a matrix with two rows. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BV by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the 2 columns of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) - CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, - $ ONE, D(1), 2 ) - CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX+1), - $ 1, ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.LT.M-1 ) THEN - CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX), 1, ONE, D(1), 2 ) - CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX+1), 1, ONE, D(2), 2 ) - END IF - END IF - ELSE -C -C Construct the 2 rows of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) - CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N-1 ) THEN - CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, - $ AB(INDX,INDX+2), LDAB, ONE, D(1), 2 ) - CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, - $ AB(INDX+1,INDX+2), LDAB, ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), - $ LDAB, ONE, D(1), 2 ) - CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX+1,1), - $ LDAB, ONE, D(2), 2 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04NV *** - END diff --git a/slycot/src/SB04NW.f b/slycot/src/SB04NW.f deleted file mode 100644 index a2a52aa8..00000000 --- a/slycot/src/SB04NW.f +++ /dev/null @@ -1,155 +0,0 @@ - SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand side D for a system of equations in -C Hessenberg form solved via SB04NY (case with 1 right-hand side). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation AX + XB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the column/row of C to be used in the -C construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C AX + XB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading N or M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BW by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the column of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, - $ ONE, D, 1 ) - END IF - ELSE - IF ( INDX.LT.M ) THEN - CALL DGEMV( 'N', N, M-INDX, -ONE, C(1,INDX+1), LDC, - $ AB(INDX+1,INDX), 1, ONE, D, 1 ) - END IF - END IF - ELSE -C -C Construct the row of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N ) THEN - CALL DGEMV( 'T', N-INDX, M, -ONE, C(INDX+1,1), LDC, - $ AB(INDX,INDX+1), LDAB, ONE, D, 1 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), - $ LDAB, ONE, D, 1 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04NW *** - END diff --git a/slycot/src/SB04NX.f b/slycot/src/SB04NX.f deleted file mode 100644 index ac9ecf52..00000000 --- a/slycot/src/SB04NX.f +++ /dev/null @@ -1,320 +0,0 @@ - SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, - $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in Hessenberg form with two -C consecutive offdiagonals and two right-hand sides. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBD1, (input) DOUBLE PRECISION -C LAMBD2, These variables must contain the 2-by-2 block to be added -C LAMBD3, to the diagonal blocks of A. -C LAMBD4 -C -C D (input/output) DOUBLE PRECISION array, dimension (2*M) -C On entry, this array must contain the two right-hand -C side vectors of the Hessenberg system, stored row-wise. -C On exit, if INFO = 0, this array contains the two solution -C vectors of the Hessenberg system, stored row-wise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the Hessenberg matrix. A matrix -C whose estimated condition number is less than 1/TOL is -C considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) -C The leading 2*M-by-2*M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the Hessenberg matrix. The remaining 6*M elements are -C used as workspace for the computation of the reciprocal -C condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. -C LDDWOR >= MAX(1,2*M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Hessenberg matrix is (numerically) singular. -C That is, its estimated reciprocal condition number -C is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BX by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M and LDA must be such that the value of the -C LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, 2*M ) ) -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, J2, M2, MJ, ML - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DLASET, DROT, DTRCON, DTRSV -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - M2 = M*2 - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - J2 = J*2 - ML = MIN( M, J + 1 ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 - DWORK(J2,J2-1) = LAMBD3 - DWORK(J2-1,J2) = LAMBD2 - DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J+2,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) - DWORK(J+1,J) = R - DWORK(J+2,J) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, - $ DWORK(J+2,J+1), LDDWOR, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, - $ S, R ) - DWORK(MJ+1,MJ) = R - DWORK(MJ+1,MJ-1) = ZERO - CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, - $ S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J2 = J*2 - J1 = MAX( J - 1, 1 ) - ML = MIN( M - J + 2, M ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 - DWORK(J2,J2-1) = LAMBD3 - DWORK(J2-1,J2) = LAMBD2 - DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, - $ S, R ) - DWORK(MJ,MJ+1) = R - DWORK(MJ-1,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M2 - 1 - MJ = M2 - J - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J,J+2).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) - DWORK(J,J+1) = R - DWORK(J,J+2) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), - $ 1, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, - $ DWORK(1,M2+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04NX *** - END diff --git a/slycot/src/SB04NY.f b/slycot/src/SB04NY.f deleted file mode 100644 index 5a0b9c62..00000000 --- a/slycot/src/SB04NY.f +++ /dev/null @@ -1,260 +0,0 @@ - SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, - $ DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in Hessenberg form with one -C offdiagonal and one right-hand side. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBDA (input) DOUBLE PRECISION -C This variable must contain the value to be added to the -C diagonal elements of A. -C -C D (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the right-hand side -C vector of the Hessenberg system. -C On exit, if INFO = 0, this array contains the solution -C vector of the Hessenberg system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the Hessenberg matrix. A matrix -C whose estimated condition number is less than 1/TOL is -C considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) -C The leading M-by-M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the Hessenberg matrix. The remaining 3*M elements are -C used as workspace for the computation of the reciprocal -C condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Hessenberg matrix is (numerically) singular. -C That is, its estimated reciprocal condition number -C is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04BY by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M and LDA must be such that the value of the -C LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, M ) ) -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBDA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, MJ - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DROT, DTRCON, DTRSV -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + LAMBDA - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J1 = MAX( J - 1, 1 ) - CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + LAMBDA - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) -C - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, - $ DWORK(1,M+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04NY *** - END diff --git a/slycot/src/SB04OD.f b/slycot/src/SB04OD.f deleted file mode 100644 index d4ccfb0d..00000000 --- a/slycot/src/SB04OD.f +++ /dev/null @@ -1,1038 +0,0 @@ - SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, - $ LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, P, - $ LDP, Q, LDQ, U, LDU, V, LDV, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for R and L one of the generalized Sylvester equations -C -C A * R - L * B = scale * C ) -C ) (1) -C D * R - L * E = scale * F ) -C -C or -C -C A' * R + D' * L = scale * C ) -C ) (2) -C R * B' + L * E' = scale * (-F) ) -C -C where A and D are M-by-M matrices, B and E are N-by-N matrices and -C C, F, R and L are M-by-N matrices. -C -C The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an -C output scaling factor chosen to avoid overflow. -C -C The routine also optionally computes a Dif estimate, which -C measures the separation of the spectrum of the matrix pair (A,D) -C from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)]. -C -C ARGUMENTS -C -C MODE PARAMETERS -C -C REDUCE CHARACTER*1 -C Indicates whether the matrix pairs (A,D) and/or (B,E) are -C to be reduced to generalized Schur form as follows: -C = 'R': The matrix pairs (A,D) and (B,E) are to be reduced -C to generalized (real) Schur canonical form; -C = 'A': The matrix pair (A,D) only is to be reduced -C to generalized (real) Schur canonical form, -C and the matrix pair (B,E) already is in this form; -C = 'B': The matrix pair (B,E) only is to be reduced -C to generalized (real) Schur canonical form, -C and the matrix pair (A,D) already is in this form; -C = 'N': The matrix pairs (A,D) and (B,E) are already in -C generalized (real) Schur canonical form, as -C produced by LAPACK routine DGEES. -C -C TRANS CHARACTER*1 -C Indicates which of the equations, (1) or (2), is to be -C solved as follows: -C = 'N': The generalized Sylvester equation (1) is to be -C solved; -C = 'T': The "transposed" generalized Sylvester equation -C (2) is to be solved. -C -C JOBD CHARACTER*1 -C Indicates whether the Dif estimator is to be computed as -C follows: -C = '1': Only the one-norm-based Dif estimate is computed -C and stored in DIF; -C = '2': Only the Frobenius norm-based Dif estimate is -C computed and stored in DIF; -C = 'D': The equation (1) is solved and the one-norm-based -C Dif estimate is computed and stored in DIF; -C = 'F': The equation (1) is solved and the Frobenius norm- -C based Dif estimate is computed and stored in DIF; -C = 'N': The Dif estimator is not required and hence DIF is -C not referenced. (Solve either (1) or (2) only.) -C JOBD is not referenced if TRANS = 'T'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrices A and D and the number of rows -C of the matrices C, F, R and L. M >= 0. -C -C N (input) INTEGER -C The order of the matrices B and E and the number of -C columns of the matrices C, F, R and L. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix A of the equation; A must -C be in upper quasi-triangular form if REDUCE = 'B' or 'N'. -C On exit, the leading M-by-M part of this array contains -C the upper quasi-triangular form of A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix B of the equation; B must -C be in upper quasi-triangular form if REDUCE = 'A' or 'N'. -C On exit, the leading N-by-N part of this array contains -C the upper quasi-triangular form of B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand side matrix C of the first equation -C in (1) or (2). -C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N -C part of this array contains the solution matrix R of the -C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading -C M-by-N part of this array contains the solution matrix R -C achieved during the computation of the Dif estimate. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix D of the equation; D must -C be in upper triangular form if REDUCE = 'B' or 'N'. -C On exit, the leading M-by-M part of this array contains -C the upper triangular form of D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix E of the equation; E must -C be in upper triangular form if REDUCE = 'A' or 'N'. -C On exit, the leading N-by-N part of this array contains -C the upper triangular form of E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand side matrix F of the second -C equation in (1) or (2). -C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N -C part of this array contains the solution matrix L of the -C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading -C M-by-N part of this array contains the solution matrix L -C achieved during the computation of the Dif estimate. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scaling factor in (1) or (2). If 0 < SCALE < 1, C and -C F hold the solutions R and L, respectively, to a slightly -C perturbed system (but the input or computed generalized -C (real) Schur canonical form matrices A, B, D, and E -C have not been changed). If SCALE = 0, C and F hold the -C solutions R and L, respectively, to the homogeneous system -C with C = F = 0. Normally, SCALE = 1. -C -C DIF (output) DOUBLE PRECISION -C If TRANS = 'N' and JOBD <> 'N', then DIF contains the -C value of the Dif estimator, which is an upper bound of -C -1 -C Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z ||, in either the -C one-norm, or Frobenius norm, respectively (see METHOD). -C Otherwise, DIF is not referenced. -C -C P (output) DOUBLE PRECISION array, dimension (LDP,*) -C If REDUCE = 'R' or 'A', then the leading M-by-M part of -C this array contains the (left) transformation matrix used -C to reduce (A,D) to generalized Schur form. -C Otherwise, P is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDP = 1 and declare this -C array to be P(1,1) in the calling program). -C -C LDP INTEGER -C The leading dimension of array P. -C LDP >= MAX(1,M) if REDUCE = 'R' or 'A', -C LDP >= 1 if REDUCE = 'B' or 'N'. -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,*) -C If REDUCE = 'R' or 'A', then the leading M-by-M part of -C this array contains the (right) transformation matrix used -C to reduce (A,D) to generalized Schur form. -C Otherwise, Q is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDQ = 1 and declare this -C array to be Q(1,1) in the calling program). -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,M) if REDUCE = 'R' or 'A', -C LDQ >= 1 if REDUCE = 'B' or 'N'. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,*) -C If REDUCE = 'R' or 'B', then the leading N-by-N part of -C this array contains the (left) transformation matrix used -C to reduce (B,E) to generalized Schur form. -C Otherwise, U is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDU = 1 and declare this -C array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= MAX(1,N) if REDUCE = 'R' or 'B', -C LDU >= 1 if REDUCE = 'A' or 'N'. -C -C V (output) DOUBLE PRECISION array, dimension (LDV,*) -C If REDUCE = 'R' or 'B', then the leading N-by-N part of -C this array contains the (right) transformation matrix used -C to reduce (B,E) to generalized Schur form. -C Otherwise, V is not referenced and can be supplied as a -C dummy array (i.e. set parameter LDV = 1 and declare this -C array to be V(1,1) in the calling program). -C -C LDV INTEGER -C The leading dimension of array V. -C LDV >= MAX(1,N) if REDUCE = 'R' or 'B', -C LDV >= 1 if REDUCE = 'A' or 'N'. -C -C Workspace -C -C IWORK INTEGER array, dimension (M+N+6) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C If TRANS = 'N' and JOBD = 'D' or 'F', then -C LDWORK = MAX(1,7*M,7*N,2*M*N) if REDUCE = 'R'; -C LDWORK = MAX(1,7*M,2*M*N) if REDUCE = 'A'; -C LDWORK = MAX(1,7*N,2*M*N) if REDUCE = 'B'; -C LDWORK = MAX(1,2*M*N) if REDUCE = 'N'. -C Otherwise, the term 2*M*N above should be omitted. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if REDUCE <> 'N' and either (A,D) and/or (B,E) -C cannot be reduced to generalized Schur form; -C = 2: if REDUCE = 'N' and either A or B is not in -C upper quasi-triangular form; -C = 3: if a singular matrix was encountered during the -C computation of the solution matrices R and L, that -C is (A,D) and (B,E) have common or close eigenvalues. -C -C METHOD -C -C For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm -C used by the routine consists of four steps (see [1] and [2]) as -C follows: -C -C (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are -C transformed to generalized Schur form, i.e. orthogonal -C matrices P, Q, U and V are computed such that P' * A * Q -C and U' * B * V are in upper quasi-triangular form and -C P' * D * Q and U' * E * V are in upper triangular form; -C (b) if REDUCE = 'R', then the matrices C and F are transformed -C to give P' * C * V and P' * F * V respectively; -C (c) if REDUCE = 'R', then the transformed system -C -C P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V -C P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V -C -C is solved to give R1 and L1; otherwise, equation (1) is -C solved to give R and L directly. The Dif estimator -C is also computed if JOBD <> 'N'. -C (d) if REDUCE = 'R', then the solution is transformed back -C to give R = Q * R1 * V' and L = P * L1 * U'. -C -C By using Kronecker products, equation (1) can also be written as -C the system of linear equations Z * x = scale*y (see [1]), where -C -C | I*A I*D | -C Z = | |. -C |-B'*I -E'*I | -C -C -1 -C If JOBD <> 'N', then a lower bound on ||Z ||, in either the one- -C norm or Frobenius norm, is computed, which in most cases is -C a reliable estimate of the true value. Notice that since Z is a -C matrix of order 2 * M * N, the exact value of Dif (i.e., in the -C Frobenius norm case, the smallest singular value of Z) may be very -C expensive to compute. -C -C The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but -C only one of the matrix pairs should be reduced and the -C calculations simplify. -C -C For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm -C is similar, but the steps (b), (c), and (d) are as follows: -C -C (b) if REDUCE = 'R', then the matrices C and F are transformed -C to give Q' * C * V and P' * F * U respectively; -C (c) if REDUCE = 'R', then the transformed system -C -C Q' * A' * P * R1 + Q' * D' * P * L1 = scale * Q' * C * V -C R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U -C -C is solved to give R1 and L1; otherwise, equation (2) is -C solved to give R and L directly. -C (d) if REDUCE = 'R', then the solution is transformed back -C to give R = P * R1 * V' and L = P * L1 * V'. -C -C REFERENCES -C -C [1] Kagstrom, B. and Westin, L. -C Generalized Schur Methods with Condition Estimators for -C Solving the Generalized Sylvester Equation. -C IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989. -C [2] Kagstrom, B. and Westin, L. -C GSYLV - Fortran Routines for the Generalized Schur Method with -C Dif Estimators for Solving the Generalized Sylvester -C Equation. -C Report UMINF-132.86, Institute of Information Processing, -C Univ. of Umea, Sweden, July 1987. -C [3] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur Method for the Problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C [4] Kagstrom, B. and Van Dooren, P. -C Additive Decomposition of a Transfer Function with respect to -C a Specified Region. -C In: "Signal Processing, Scattering and Operator Theory, and -C Numerical Methods" (Eds. M.A. Kaashoek et al.). -C Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston -C Inc., 1990. -C [5] Kagstrom, B. and Van Dooren, P. -C A Generalized State-space Approach for the Additive -C Decomposition of a Transfer Matrix. -C Report UMINF-91.12, Institute of Information Processing, Univ. -C of Umea, Sweden, April 1991. -C -C NUMERICAL ASPECTS -C -C The algorithm is backward stable. A reliable estimate for the -C condition number of Z in the Frobenius norm, is (see [1]) -C -C K(Z) = SQRT( ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF. -C -C If mu is an upper bound on the relative error of the elements of -C the matrices A, B, C, D, E and F, then the relative error in the -C actual solution is approximately mu * K(Z). -C -C The relative error in the computed solution (due to rounding -C errors) is approximately EPS * K(Z), where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C -C FURTHER COMMENTS -C -C For applications of the generalized Sylvester equation in control -C theory, see [4] and [5]. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB04CD by Bo Kagstrom and Lars -C Westin. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Dec. 1999, -C May 2009. -C -C KEYWORDS -C -C Generalized eigenvalue problem, orthogonal transformation, real -C Schur form, Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBD, REDUCE, TRANS - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, - $ LDU, LDV, LDWORK, M, N - DOUBLE PRECISION DIF, SCALE -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), E(LDE,*), F(LDF,*), P(LDP,*), - $ Q(LDQ,*), U(LDU,*), V(LDV,*) -C .. Local Scalars .. - LOGICAL ILASCL, ILBSCL, ILDSCL, ILESCL, LJOB1, LJOB2, - $ LJOBD, LJOBDF, LJOBF, LREDRA, LREDRB, LREDUA, - $ LREDUB, LREDUC, LREDUR, LTRANN, SUFWRK - INTEGER I, IERR, IJOB, MINWRK, MN, WRKOPT, SDIM - DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, DNRM, - $ DNRMTO, ENRM, ENRMTO, SAFMAX, SAFMIN, SMLNUM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGGES, DGEMM, DGEMV, DLABAD, DLACPY, - $ DLASCL, DTGSYL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, SQRT -C .. Executable Statements .. -C - INFO = 0 - MN = MAX( M, N ) - LREDUR = LSAME( REDUCE, 'R' ) - LREDUA = LSAME( REDUCE, 'A' ) - LREDUB = LSAME( REDUCE, 'B' ) - LREDRA = LREDUR.OR.LREDUA - LREDRB = LREDUR.OR.LREDUB - LREDUC = LREDRA.OR.LREDUB - IF ( LREDUR ) THEN - MINWRK = MAX( 1, 7*MN ) - ELSE IF ( LREDUA ) THEN - MINWRK = MAX( 1, 7*M ) - ELSE IF ( LREDUB ) THEN - MINWRK = MAX( 1, 7*N ) - ELSE - MINWRK = 1 - END IF - LTRANN = LSAME( TRANS, 'N' ) - IF ( LTRANN ) THEN - LJOB1 = LSAME( JOBD, '1' ) - LJOB2 = LSAME( JOBD, '2' ) - LJOBD = LSAME( JOBD, 'D' ) - LJOBF = LSAME( JOBD, 'F' ) - LJOBDF = LJOB1.OR.LJOB2.OR.LJOBD.OR.LJOBF - IF ( LJOBD.OR.LJOBF ) MINWRK = MAX( MINWRK, 2*M*N ) - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LREDUC .AND. .NOT.LSAME( REDUCE, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LTRANN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( LTRANN ) THEN - IF( .NOT.LJOBDF .AND. .NOT.LSAME( JOBD, 'N' ) ) - $ INFO = -3 - END IF - 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 - ELSE IF( LDD.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -17 - ELSE IF( ( .NOT.LREDRA .AND. LDP.LT.1 ) .OR. - $ ( LREDRA .AND. LDP.LT.MAX( 1, M ) ) ) THEN - INFO = -21 - ELSE IF( ( .NOT.LREDRA .AND. LDQ.LT.1 ) .OR. - $ ( LREDRA .AND. LDQ.LT.MAX( 1, M ) ) ) THEN - INFO = -23 - ELSE IF( ( .NOT.LREDRB .AND. LDU.LT.1 ) .OR. - $ ( LREDRB .AND. LDU.LT.MAX( 1, N ) ) ) THEN - INFO = -25 - ELSE IF( ( .NOT.LREDRB .AND. LDV.LT.1 ) .OR. - $ ( LREDRB .AND. LDV.LT.MAX( 1, N ) ) ) THEN - INFO = -27 - ELSE IF( LDWORK.LT.MINWRK ) THEN - INFO = -30 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) THEN - SCALE = ONE - DWORK(1) = ONE - IF ( LTRANN ) THEN - IF ( LJOBDF ) DIF = ONE - END IF - RETURN - END IF - WRKOPT = 1 - SUFWRK = LDWORK.GE.M*N -C -C STEP 1: Reduce (A,D) and/or (B,E) to generalized Schur form. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - IF ( LREDUC ) THEN -C -C Get machine constants. -C - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFMAX = ONE / SAFMIN - CALL DLABAD( SAFMIN, SAFMAX ) - SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM -C - IF ( .NOT.LREDUB ) THEN -C -C Scale A if max element outside range [SMLNUM,BIGNUM]. -C - ANRM = DLANGE( 'M', M, M, A, LDA, DWORK ) - 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, M, M, A, LDA, - $ IERR ) -C -C Scale D if max element outside range [SMLNUM,BIGNUM] -C - DNRM = DLANGE( 'M', M, M, D, LDD, DWORK ) - ILDSCL = .FALSE. - IF( DNRM.GT.ZERO .AND. DNRM.LT.SMLNUM ) THEN - DNRMTO = SMLNUM - ILDSCL = .TRUE. - ELSE IF( DNRM.GT.BIGNUM ) THEN - DNRMTO = BIGNUM - ILDSCL = .TRUE. - END IF - IF( ILDSCL ) - $ CALL DLASCL( 'G', 0, 0, DNRM, DNRMTO, M, M, D, LDD, - $ IERR ) -C -C Reduce (A,D) to generalized Schur form. -C Workspace: need 7*M; -C prefer 5*M + M*(NB+1). -C -C CALL DGEGS( 'Vectors left', 'Vectors right', M, A, LDA, D, -C $ LDD, DWORK, DWORK(M+1), DWORK(2*M+1), P, LDP, Q, -C $ LDQ, DWORK(3*M+1), LDWORK-3*M, INFO ) - CALL DGGES( 'Vectors left', 'Vectors right', 'N', 0, N, A, LDA, - $ D, LDD, SDIM, DWORK, DWORK(M+1), DWORK(2*M+1), P, - $ LDP, Q, - $ LDQ, DWORK(3*M+1), LDWORK-3*M, 0, INFO ) - -C -C Undo scaling -C - IF( ILASCL ) - $ CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, M, M, A, LDA, - $ IERR ) -C - IF( ILDSCL ) - $ CALL DLASCL( 'U', 0, 0, DNRMTO, DNRM, M, M, D, LDD, - $ IERR ) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(3*M+1) ) + 3*M ) - END IF - IF ( .NOT.LREDUA ) THEN -C -C Scale B if max element outside range [SMLNUM,BIGNUM] -C - BNRM = DLANGE( 'M', N, N, B, LDB, DWORK ) - 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 ) -C -C Scale E if max element outside range [SMLNUM,BIGNUM] -C - ENRM = DLANGE( 'M', N, N, E, LDE, DWORK ) - ILESCL = .FALSE. - IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN - ENRMTO = SMLNUM - ILESCL = .TRUE. - ELSE IF( ENRM.GT.BIGNUM ) THEN - ENRMTO = BIGNUM - ILESCL = .TRUE. - END IF - IF( ILESCL ) - $ CALL DLASCL( 'G', 0, 0, ENRM, ENRMTO, N, N, E, LDE, - $ IERR ) -C -C Reduce (B,E) to generalized Schur form. -C Workspace: need 7*N; -C prefer 5*N + N*(NB+1). -C -C CALL DGEGS( 'Vectors left', 'Vectors right', N, B, LDB, E, -C $ LDE, DWORK, DWORK(N+1), DWORK(2*N+1), U, LDU, V, -C $ LDV, DWORK(3*N+1), LDWORK-3*N, INFO ) - CALL DGGES( 'Vectors left', 'Vectors right', 'N', - $ 0, N, B, LDB, E, - $ LDE, SDIM, DWORK, DWORK(N+1), DWORK(2*N+1), - $ U, LDU, V, - $ LDV, DWORK(3*N+1), LDWORK-3*N, 0, INFO ) -C -C Undo scaling -C - IF( ILBSCL ) - $ CALL DLASCL( 'H', 0, 0, BNRMTO, BNRM, N, N, B, LDB, - $ IERR ) -C - IF( ILESCL ) - $ CALL DLASCL( 'U', 0, 0, ENRMTO, ENRM, N, N, E, LDE, - $ IERR ) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(3*N+1) ) + 3*N ) - END IF - END IF -C - IF (.NOT.LREDUR ) THEN -C -C Set INFO = 2 if A and/or B are/is not in quasi-triangular form. -C - IF (.NOT.LREDUA ) THEN - I = 1 -C - 20 CONTINUE - IF ( I.LE.M-2 ) THEN - IF ( A(I+1,I).NE.ZERO ) THEN - IF ( A(I+2,I+1).NE.ZERO ) THEN - INFO = 2 - RETURN - ELSE - I = I + 1 - END IF - END IF - I = I + 1 - GO TO 20 - END IF - END IF -C - IF (.NOT.LREDUB ) THEN - I = 1 -C - 40 CONTINUE - IF ( I.LE.N-2 ) THEN - IF ( B(I+1,I).NE.ZERO ) THEN - IF ( B(I+2,I+1).NE.ZERO ) THEN - INFO = 2 - RETURN - ELSE - I = I + 1 - END IF - END IF - I = I + 1 - GO TO 40 - END IF - END IF - END IF -C -C STEP 2: Modify right hand sides (C,F). -C - IF ( LREDUC ) THEN - WRKOPT = MAX( WRKOPT, M*N ) - IF ( SUFWRK ) THEN -C -C Enough workspace for a BLAS 3 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ P, LDP, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ Q, LDQ, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, - $ P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, N, - $ ONE, DWORK, M, U, LDU, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - END IF - ELSE -C -C Use a BLAS 2 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN -C - DO 60 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, C(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 60 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 80 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), - $ LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 80 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 100 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 100 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 120 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, F(I,1), - $ LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 120 CONTINUE -C - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN -C - DO 140 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, Q, LDQ, C(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 140 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 160 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), - $ LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 160 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 180 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), - $ 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 180 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 200 I = 1, M - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, F(I,1), - $ LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 200 CONTINUE -C - END IF - END IF - END IF - END IF -C -C STEP 3: Solve the transformed system and compute the Dif -C estimator. -C - IF ( LTRANN ) THEN - IF ( LJOBD ) THEN - IJOB = 1 - ELSE IF ( LJOBF ) THEN - IJOB = 2 - ELSE IF ( LJOB1 ) THEN - IJOB = 3 - ELSE IF ( LJOB2 ) THEN - IJOB = 4 - ELSE - IJOB = 0 - END IF - ELSE - IJOB = 0 - END IF -C -C Workspace: need 2*M*N if TRANS = 'N' and JOBD = 'D' or 'F'; -C 1, otherwise. -C - CALL DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, - $ E, LDE, F, LDF, SCALE, DIF, DWORK, LDWORK, IWORK, - $ INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 3 - RETURN - END IF - IF ( LTRANN ) THEN - IF ( LJOBD.OR.LJOBF ) - $ WRKOPT = MAX( WRKOPT, 2*M*N ) - END IF -C -C STEP 4: Back transformation of the solution. -C - IF ( LREDUC ) THEN - IF (SUFWRK ) THEN -C -C Enough workspace for a BLAS 3 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, Q, LDQ, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, - $ DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, - $ DWORK, M, U, LDU, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, P, LDP, C, LDC, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) - END IF - IF ( .NOT.LREDUB ) THEN - CALL DGEMM( 'No transpose', 'No transpose', M, N, M, - $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) - ELSE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) - END IF - IF ( .NOT.LREDUA ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M, N, N, - $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) - ELSE - CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) - END IF - END IF - ELSE -C -C Use a BLAS 2 calculation. -C - IF ( LTRANN ) THEN -C -C Equation (1). -C - IF ( .NOT.LREDUB ) THEN -C - DO 220 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, Q, LDQ, - $ C(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 220 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 240 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, - $ C(I,1), LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 240 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 260 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, - $ F(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 260 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 280 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, U, LDU, - $ F(I,1), LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 280 CONTINUE -C - END IF - ELSE -C -C Equation (2). -C - IF ( .NOT.LREDUB ) THEN -C - DO 300 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, - $ C(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) - 300 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 320 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, - $ C(I,1), LDC, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) - 320 CONTINUE -C - END IF - IF ( .NOT.LREDUB ) THEN -C - DO 340 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, - $ F(1,I), 1, ZERO, DWORK, 1 ) - CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) - 340 CONTINUE -C - END IF - IF ( .NOT.LREDUA ) THEN -C - DO 360 I = 1, M - CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, - $ F(I,1), LDF, ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) - 360 CONTINUE -C - END IF - END IF - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB04OD *** - END diff --git a/slycot/src/SB04OW.f b/slycot/src/SB04OW.f deleted file mode 100644 index c3d613af..00000000 --- a/slycot/src/SB04OW.f +++ /dev/null @@ -1,568 +0,0 @@ - SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, - $ F, LDF, SCALE, IWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a periodic Sylvester equation -C -C A * R - L * B = scale * C (1) -C D * L - R * E = scale * F, -C -C using Level 1 and 2 BLAS, where R and L are unknown M-by-N -C matrices, (A, D), (B, E) and (C, F) are given matrix pairs of -C size M-by-M, N-by-N and M-by-N, respectively, with real entries. -C (A, D) and (B, E) must be in periodic Schur form, i.e. A, B are -C upper quasi triangular and D, E are upper triangular. The solution -C (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling -C factor chosen to avoid overflow. -C -C This routine is largely based on the LAPACK routine DTGSY2 -C developed by Bo Kagstrom and Peter Poromaa. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of A and D, and the row dimension of C, F, R -C and L. M >= 0. -C -C N (input) INTEGER -C The order of B and E, and the column dimension of C, F, R -C and L. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C On entry, the leading M-by-M part of this array must -C contain the upper quasi triangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the upper quasi triangular matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand-side of the first matrix equation -C in (1). -C On exit, the leading M-by-N part of this array contains -C the solution R. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,M). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading M-by-M part of this array must -C contain the upper triangular matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,M). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the upper triangular matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain the right-hand-side of the second matrix equation -C in (1). -C On exit, the leading M-by-N part of this array contains -C the solution L. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays -C C and F will hold the solutions R and L, respectively, to -C a slightly perturbed system but the input matrices A, B, D -C and E have not been changed. If SCALE = 0, C and F will -C hold solutions to the homogeneous system with C = F = 0. -C Normally, SCALE = 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M+N+2) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: the matrix products A*D and B*E have common or very -C close eigenvalues. -C -C METHOD -C -C In matrix notation solving equation (1) corresponds to solving -C Z*x = scale*b, where Z is defined as -C -C Z = [ kron(In, A) -kron(B', Im) ] (2) -C [ -kron(E', Im) kron(In, D) ], -C -C Ik is the identity matrix of size k and X' is the transpose of X. -C kron(X, Y) is the Kronecker product between the matrices X and Y. -C In the process of solving (1), we solve a number of such systems -C where Dim(Im), Dim(In) = 1 or 2. -C -C REFERENCES -C -C [1] Kagstrom, B. -C A Direct Method for Reordering Eigenvalues in the Generalized -C Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen -C et al (eds.), Linear Algebra for Large Scale and Real-Time -C Applications, Kluwer Academic Publ., pp. 195-218, 1993. -C -C [2] Sreedhar, J. and Van Dooren, P. -C A Schur approach for solving some periodic matrix equations. -C U. Helmke et al (eds.), Systems and Networks: Mathematical -C Theory and Applications, Akademie Verlag, Berlin, vol. 77, -C pp. 339-362, 1994. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine DTGPY2). -C -C KEYWORDS -C -C Matrix equation, periodic Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER LDZ - PARAMETER ( LDZ = 8 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N - DOUBLE PRECISION SCALE -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ E(LDE,*), F(LDF,*) -C .. Local Scalars .. - INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, - $ K, MB, NB, P, Q, ZDIM - DOUBLE PRECISION SCALOC -C .. Local Arrays .. - INTEGER IPIV(LDZ), JPIV(LDZ) - DOUBLE PRECISION RHS(LDZ), Z(LDZ,LDZ) -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, - $ DGETC2, DLASET, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - INFO = 0 - IERR = 0 - IF ( M.LE.0 ) THEN - INFO = -1 - ELSE IF ( N.LE.0 ) THEN - INFO = -2 - ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF ( LDC.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF ( LDD.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF ( LDF.LT.MAX( 1, M ) ) THEN - INFO = -14 - END IF -C -C Return if there were illegal values. -C - IF ( INFO.NE.0 ) THEN - CALL XERBLA( 'SB04OW', -INFO ) - RETURN - END IF -C -C Determine block structure of A. -C - 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 -C -C Determine block structure of B. -C - 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 -C -C Solve (I, J) - subsystem -C A(I,I) * R(I,J) - L(I,J) * B(J,J) = C(I,J) -C D(I,I) * L(I,J) - R(I,J) * E(J,J) = F(I,J) -C for I = P, P - 1, ..., 1; J = 1, 2, ..., Q. -C - 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 -C - IS = IWORK(I) - ISP1 = IS + 1 - IE = IWORK(I+1) - 1 - MB = IE - IS + 1 - ZDIM = MB*NB*2 -C - IF ( ( MB.EQ.1 ).AND.( NB.EQ.1 ) ) THEN -C -C Build a 2-by-2 system Z * x = RHS. -C - Z(1,1) = A(IS,IS) - Z(2,1) = -E(JS,JS) - Z(1,2) = -B(JS,JS) - Z(2,2) = D(IS,IS) -C -C Set up right hand side(s). -C - RHS(1) = C(IS,JS) - RHS(2) = F(IS,JS) -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - 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 -C -C Unpack solution vector(s). -C - C(IS,JS) = RHS(1) - F(IS,JS) = RHS(2) -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - IF ( I.GT.1 ) THEN - CALL DAXPY( IS-1, -RHS(1), A(1,IS), 1, C(1,JS), 1 ) - CALL DAXPY( IS-1, -RHS(2), 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(1), E(JS,JE+1), LDE, F(IS,JE+1), - $ LDF ) - END IF -C - ELSE IF ( ( MB.EQ.1 ).AND.( NB.EQ.2 ) ) THEN -C -C Build a 4-by-4 system Z * x = RHS. -C - Z(1,1) = A(IS,IS) - Z(2,1) = ZERO - Z(3,1) = -E(JS,JS) - Z(4,1) = -E(JS,JSP1) -C - Z(1,2) = ZERO - Z(2,2) = A(IS,IS) - Z(3,2) = ZERO - Z(4,2) = -E(JSP1,JSP1) -C - Z(1,3) = -B(JS,JS) - Z(2,3) = -B(JS,JSP1) - Z(3,3) = D(IS,IS) - Z(4,3) = ZERO -C - Z(1,4) = -B(JSP1,JS) - Z(2,4) = -B(JSP1,JSP1) - Z(3,4) = ZERO - Z(4,4) = D(IS,IS) -C -C Set up right hand side(s). -C - RHS(1) = C(IS,JS) - RHS(2) = C(IS,JSP1) - RHS(3) = F(IS,JS) - RHS(4) = F(IS,JSP1) -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - 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 -C -C Unpack solution vector(s). -C - C(IS,JS) = RHS(1) - C(IS,JSP1) = RHS(2) - F(IS,JS) = RHS(3) - F(IS,JSP1) = RHS(4) -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - 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(3), 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(1), 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(2), E(JSP1,JE+1), LDE, - $ F(IS,JE+1), LDF ) - END IF -C - ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN -C -C Build a 4-by-4 system Z * x = RHS. -C - Z(1,1) = A(IS,IS) - Z(2,1) = A(ISP1,IS) - Z(3,1) = -E(JS,JS) - Z(4,1) = ZERO -C - Z(1,2) = A(IS,ISP1) - Z(2,2) = A(ISP1,ISP1) - Z(3,2) = ZERO - Z(4,2) = -E(JS,JS) -C - Z(1,3) = -B(JS,JS) - Z(2,3) = ZERO - Z(3,3) = D(IS,IS) - Z(4,3) = ZERO -C - Z(1,4) = ZERO - Z(2,4) = -B(JS,JS) - Z(3,4) = D(IS,ISP1) - Z(4,4) = D(ISP1,ISP1) -C -C Set up right hand side(s). -C - RHS(1) = C(IS,JS) - RHS(2) = C(ISP1,JS) - RHS(3) = F(IS,JS) - RHS(4) = F(ISP1,JS) -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - 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 -C -C Unpack solution vector(s). -C - C(IS,JS) = RHS(1) - C(ISP1,JS) = RHS(2) - F(IS,JS) = RHS(3) - F(ISP1,JS) = RHS(4) -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - 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(3), - $ 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(1), 1, E(JS,JE+1), LDE, - $ F(IS,JE+1), LDF ) - END IF -C - ELSE IF ( ( MB.EQ.2 ).AND.( NB.EQ.2 ) ) THEN -C -C Build an 8-by-8 system Z * x = RHS. -C - CALL DLASET( 'All', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) -C - Z(1,1) = A(IS,IS) - Z(2,1) = A(ISP1,IS) - Z(5,1) = -E(JS,JS) - Z(7,1) = -E(JS,JSP1) -C - Z(1,2) = A(IS,ISP1) - Z(2,2) = A(ISP1,ISP1) - Z(6,2) = -E(JS,JS) - Z(8,2) = -E(JS,JSP1) -C - Z(3,3) = A(IS,IS) - Z(4,3) = A(ISP1,IS) - Z(7,3) = -E(JSP1,JSP1) -C - Z(3,4) = A(IS,ISP1) - Z(4,4) = A(ISP1,ISP1) - Z(8,4) = -E(JSP1,JSP1) -C - Z(1,5) = -B(JS,JS) - Z(3,5) = -B(JS,JSP1) - Z(5,5) = D(IS,IS) -C - Z(2,6) = -B(JS,JS) - Z(4,6) = -B(JS,JSP1) - Z(5,6) = D(IS,ISP1) - Z(6,6) = D(ISP1,ISP1) -C - Z(1,7) = -B(JSP1,JS) - Z(3,7) = -B(JSP1,JSP1) - Z(7,7) = D(IS,IS) -C - Z(2,8) = -B(JSP1,JS) - Z(4,8) = -B(JSP1,JSP1) -C - Z(7,8) = D(IS,ISP1) - Z(8,8) = D(ISP1,ISP1) -C -C Set up right hand side(s). -C - 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 -C -C Solve Z * x = RHS. -C - CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) - IF ( IERR.GT.0 ) - $ INFO = IERR -C - 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 -C -C Unpack solution vector(s). -C - 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 -C -C Substitute R(I,J) and L(I,J) into remaining equation. -C - K = MB*NB + 1 - 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(K), MB, ONE, F(1,JS), LDF ) - END IF - IF ( J.LT.Q ) THEN - 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(1), MB, - $ E(JS,JE+1), LDE, ONE, F(IS,JE+1), LDF ) - END IF -C - END IF -C - 110 CONTINUE - 120 CONTINUE - RETURN -C *** Last line of SB04OW *** - END diff --git a/slycot/src/SB04PD.f b/slycot/src/SB04PD.f deleted file mode 100644 index a2e5899a..00000000 --- a/slycot/src/SB04PD.f +++ /dev/null @@ -1,672 +0,0 @@ - SUBROUTINE SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, - $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the real continuous-time Sylvester equation -C -C op(A)*X + ISGN*X*op(B) = scale*C, (1) -C -C or the real discrete-time Sylvester equation -C -C op(A)*X*op(B) + ISGN*X = scale*C, (2) -C -C where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and -C B is N-by-N; the right hand side C and the solution X are M-by-N; -C and scale is an output scale factor, set less than or equal to 1 -C to avoid overflow in X. The solution matrix X is overwritten -C onto C. -C -C If A and/or B are not (upper) quasi-triangular, that is, block -C upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are -C reduced to Schur canonical form, that is, quasi-triangular with -C each 2-by-2 diagonal block having its diagonal elements equal and -C its off-diagonal elements of opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the equation from which X is to be determined -C as follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C FACTA CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix A is supplied on entry, as follows: -C = 'F': On entry, A and U contain the factors from the -C real Schur factorization of the matrix A; -C = 'N': The Schur factorization of A will be computed -C and the factors will be stored in A and U; -C = 'S': The matrix A is quasi-triangular (or Schur). -C -C FACTB CHARACTER*1 -C Specifies whether or not the real Schur factorization -C of the matrix B is supplied on entry, as follows: -C = 'F': On entry, B and V contain the factors from the -C real Schur factorization of the matrix B; -C = 'N': The Schur factorization of B will be computed -C and the factors will be stored in B and V; -C = 'S': The matrix B is quasi-triangular (or Schur). -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C TRANB CHARACTER*1 -C Specifies the form of op(B) to be used, as follows: -C = 'N': op(B) = B (No transpose); -C = 'T': op(B) = B**T (Transpose); -C = 'C': op(B) = B**T (Conjugate transpose = Transpose). -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A, and the number of rows in the -C matrices X and C. M >= 0. -C -C N (input) INTEGER -C The order of the matrix B, and the number of columns in -C the matrices X and C. N >= 0. -C -C A (input or input/output) DOUBLE PRECISION array, -C dimension (LDA,M) -C On entry, the leading M-by-M part of this array must -C contain the matrix A. If FACTA = 'S', then A contains -C a quasi-triangular matrix, and if FACTA = 'F', then A -C is in Schur canonical form; the elements below the upper -C Hessenberg part of the array A are not referenced. -C On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the -C leading M-by-M upper Hessenberg part of this array -C contains the upper quasi-triangular matrix in Schur -C canonical form from the Schur factorization of A. The -C contents of array A is not modified if FACTA = 'F' or 'S'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C U (input or output) DOUBLE PRECISION array, dimension -C (LDU,M) -C If FACTA = 'F', then U is an input argument and on entry -C the leading M-by-M part of this array must contain the -C orthogonal matrix U of the real Schur factorization of A. -C If FACTA = 'N', then U is an output argument and on exit, -C if INFO = 0 or INFO >= M+1, it contains the orthogonal -C M-by-M matrix from the real Schur factorization of A. -C If FACTA = 'S', the array U is not referenced. -C -C LDU INTEGER -C The leading dimension of array U. -C LDU >= MAX(1,M), if FACTA = 'F' or 'N'; -C LDU >= 1, if FACTA = 'S'. -C -C B (input or input/output) DOUBLE PRECISION array, -C dimension (LDB,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix B. If FACTB = 'S', then B contains -C a quasi-triangular matrix, and if FACTB = 'F', then B -C is in Schur canonical form; the elements below the upper -C Hessenberg part of the array B are not referenced. -C On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1, -C the leading N-by-N upper Hessenberg part of this array -C contains the upper quasi-triangular matrix in Schur -C canonical form from the Schur factorization of B. The -C contents of array B is not modified if FACTB = 'F' or 'S'. -C -C LDB (input) INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C V (input or output) DOUBLE PRECISION array, dimension -C (LDV,N) -C If FACTB = 'F', then V is an input argument and on entry -C the leading N-by-N part of this array must contain the -C orthogonal matrix V of the real Schur factorization of B. -C If FACTB = 'N', then V is an output argument and on exit, -C if INFO = 0 or INFO = M+N+1, it contains the orthogonal -C N-by-N matrix from the real Schur factorization of B. -C If FACTB = 'S', the array V is not referenced. -C -C LDV INTEGER -C The leading dimension of array V. -C LDV >= MAX(1,N), if FACTB = 'F' or 'N'; -C LDV >= 1, if FACTB = 'S'. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix C. -C On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N -C part of this array contains the solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the -C optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and -C DWORK(1+M+i), i = 1,...,M, contain the real and imaginary -C parts, respectively, of the eigenvalues of A; and, if -C FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N, -C with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain -C the real and imaginary parts, respectively, of the -C eigenvalues of B. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ), -C where a = 1+2*M, if FACTA = 'N', -C a = 0, if FACTA <> 'N', -C b = 2*N, if FACTB = 'N', FACTA = 'N', -C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', -C b = 0, if FACTB <> 'N', -C c = 3*M, if FACTA = 'N', -C c = M, if FACTA = 'F', -C c = 0, if FACTA = 'S', -C d = 3*N, if FACTB = 'N', -C d = N, if FACTB = 'F', -C d = 0, if FACTB = 'S', -C e = M, if DICO = 'C', FACTA <> 'S', -C e = 0, if DICO = 'C', FACTA = 'S', -C e = 2*M, if DICO = 'D'. -C An upper bound is -C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ). -C For good performance, LDWORK should be larger, e.g., -C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*N ). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = i: if INFO = i, i = 1,...,M, the QR algorithm failed -C to compute all the eigenvalues of the matrix A -C (see LAPACK Library routine DGEES); the elements -C 2+i:1+M and 2+i+M:1+2*M of DWORK contain the real -C and imaginary parts, respectively, of the -C eigenvalues of A which have converged, and the -C array A contains the partially converged Schur form; -C = M+j: if INFO = M+j, j = 1,...,N, the QR algorithm -C failed to compute all the eigenvalues of the matrix -C B (see LAPACK Library routine DGEES); the elements -C 2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the -C real and imaginary parts, respectively, of the -C eigenvalues of B which have converged, and the -C array B contains the partially converged Schur form; -C as defined for the parameter DWORK, -C f = 2*M, if FACTA = 'N', -C f = 0, if FACTA <> 'N'; -C = M+N+1: if DICO = 'C', and the matrices A and -ISGN*B -C have common or very close eigenvalues, or -C if DICO = 'D', and the matrices A and -ISGN*B have -C almost reciprocal eigenvalues (that is, if lambda(i) -C and mu(j) are eigenvalues of A and -ISGN*B, then -C lambda(i) = 1/mu(j) for some i and j); -C perturbed values were used to solve the equation -C (but the matrices A and B are unchanged). -C -C METHOD -C -C An extension and refinement of the algorithms in [1,2] is used. -C If the matrices A and/or B are not quasi-triangular (see PURPOSE), -C they are reduced to Schur canonical form -C -C A = U*S*U', B = V*T*V', -C -C where U, V are orthogonal, and S, T are block upper triangular -C with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand -C side matrix C is updated accordingly, -C -C C = U'*C*V; -C -C then, the solution matrix X of the "reduced" Sylvester equation -C (with A and B in (1) or (2) replaced by S and T, respectively), -C is computed column-wise via a back substitution scheme. A set of -C equivalent linear algebraic systems of equations of order at most -C four are formed and solved using Gaussian elimination with -C complete pivoting. Finally, the solution X of the original -C equation is obtained from the updating formula -C -C X = U*X*V'. -C -C If A and/or B are already quasi-triangular (or in Schur form), the -C initial factorizations and the corresponding updating steps are -C omitted. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since orthogonal -C transformations and Gaussian elimination with complete pivoting -C are used. If INFO = M+N+1, the Sylvester equation is numerically -C singular. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, April 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix algebra, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER DICO, FACTA, FACTB, TRANA, TRANB - INTEGER INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M, - $ N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), U( LDU, * ), V( LDV, * ) -C .. -C .. Local Scalars .. - LOGICAL BLAS3A, BLAS3B, BLOCKA, BLOCKB, CONT, NOFACA, - $ NOFACB, NOTRNA, NOTRNB, SCHURA, SCHURB - INTEGER AVAILW, BL, CHUNKA, CHUNKB, I, IA, IB, IERR, J, - $ JWORK, MAXWRK, MINWRK, SDIM -C .. -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DTRSYL, - $ SB04PY, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters -C - CONT = LSAME( DICO, 'C' ) - NOFACA = LSAME( FACTA, 'N' ) - NOFACB = LSAME( FACTB, 'N' ) - SCHURA = LSAME( FACTA, 'S' ) - SCHURB = LSAME( FACTB, 'S' ) - NOTRNA = LSAME( TRANA, 'N' ) - NOTRNB = LSAME( TRANB, 'N' ) -C - INFO = 0 - IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOFACA .AND. .NOT.LSAME( FACTA, 'F' ) .AND. - $ .NOT.SCHURA ) THEN - INFO = -2 - ELSE IF( .NOT.NOFACB .AND. .NOT.LSAME( FACTB, 'F' ) .AND. - $ .NOT.SCHURB ) THEN - INFO = -3 - ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. - $ .NOT.LSAME( TRANA, 'C' ) ) THEN - INFO = -4 - ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. - $ .NOT.LSAME( TRANB, 'C' ) ) THEN - INFO = -5 - ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN - INFO = -6 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDU.LT.1 .OR. ( .NOT.SCHURA .AND. LDU.LT.M ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDV.LT.1 .OR. ( .NOT.SCHURB .AND. LDV.LT.N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -18 - ELSE - IF ( NOFACA ) THEN - IA = 1 + 2*M - MINWRK = 3*M - ELSE - IA = 0 - END IF - IF ( SCHURA ) THEN - MINWRK = 0 - ELSE IF ( .NOT.NOFACA ) THEN - MINWRK = M - END IF - IB = 0 - IF ( NOFACB ) THEN - IB = 2*N - IF ( .NOT.NOFACA ) - $ IB = IB + 1 - MINWRK = MAX( MINWRK, IB + 3*N ) - ELSE IF ( .NOT.SCHURB ) THEN - MINWRK = MAX( MINWRK, N ) - END IF - IF ( CONT ) THEN - IF ( .NOT.SCHURA ) - $ MINWRK = MAX( MINWRK, IB + M ) - ELSE - MINWRK = MAX( MINWRK, IB + 2*M ) - END IF - MINWRK = MAX( 1, IA + MINWRK ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -21 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB04PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - SCALE = ONE - DWORK( 1 ) = ONE - RETURN - END IF - MAXWRK = MINWRK -C - IF( NOFACA ) THEN -C -C Compute the Schur factorization of A. -C Workspace: need 1+5*M; -C prefer larger. -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - JWORK = 2*M + 2 - IA = JWORK - AVAILW = LDWORK - JWORK + 1 - CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, A, LDA, SDIM, - $ DWORK( 2 ), DWORK( M+2 ), U, LDU, DWORK( JWORK ), - $ AVAILW, BWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) - ELSE - JWORK = 1 - IA = 2 - AVAILW = LDWORK - END IF -C - IF( .NOT.SCHURA ) THEN -C -C Transform the right-hand side: C <-- U'*C. -C Workspace: need a+M, -C prefer a+M*N, -C where a = 1+2*M, if FACTA = 'N', -C a = 0, if FACTA <> 'N'. -C - CHUNKA = AVAILW / M - BLOCKA = MIN( CHUNKA, N ).GT.1 - BLAS3A = CHUNKA.GE.N .AND. BLOCKA -C - IF ( BLAS3A ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) - ELSE IF ( BLOCKA ) THEN -C -C Use as many columns of C as possible. -C - DO 10 J = 1, N, CHUNKA - BL = MIN( N-J+1, CHUNKA ) - CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, - $ DWORK( JWORK ), M ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, BL, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), - $ LDC ) - 10 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 20 J = 1, N - CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) - CALL DGEMV( 'Transpose', M, M, ONE, U, LDU, - $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) - 20 CONTINUE -C - END IF - MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) - END IF -C - IF( NOFACB ) THEN -C -C Compute the Schur factorization of B. -C Workspace: need 1+MAX(a-1,0)+5*N, -C prefer larger. -C - JWORK = IA + 2*N - AVAILW = LDWORK - JWORK + 1 - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, B, LDB, SDIM, - $ DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ), - $ AVAILW, BWORK, IERR ) - IF( IERR.GT.0 ) THEN - INFO = IERR + M - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) -C - IF( .NOT.SCHURA ) THEN -C -C Recompute the blocking parameters. -C - CHUNKA = AVAILW / M - BLOCKA = MIN( CHUNKA, N ).GT.1 - BLAS3A = CHUNKA.GE.N .AND. BLOCKA - END IF - END IF -C - IF( .NOT.SCHURB ) THEN -C -C Transform the right-hand side: C <-- C*V. -C Workspace: need a+b+N, -C prefer a+b+M*N, -C where b = 2*N, if FACTB = 'N', FACTA = 'N', -C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', -C b = 0, if FACTB <> 'N'. -C - CHUNKB = AVAILW / N - BLOCKB = MIN( CHUNKB, M ).GT.1 - BLAS3B = CHUNKB.GE.M .AND. BLOCKB -C - IF ( BLAS3B ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, - $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) - ELSE IF ( BLOCKB ) THEN -C -C Use as many rows of C as possible. -C - DO 30 I = 1, M, CHUNKB - BL = MIN( M-I+1, CHUNKB ) - CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, - $ DWORK( JWORK ), BL ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, - $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), - $ LDC ) - 30 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 40 I = 1, M - CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, - $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) - 40 CONTINUE -C - END IF - MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) - END IF -C -C Solve the (transformed) equation. -C Workspace for DICO = 'D': a+b+2*M. -C - IF ( CONT ) THEN - CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, - $ SCALE, IERR ) - ELSE - CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, - $ SCALE, DWORK( JWORK ), IERR ) - MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 ) - END IF - IF( IERR.GT.0 ) - $ INFO = M + N + 1 -C -C Transform back the solution, if needed. -C - IF( .NOT.SCHURA ) THEN -C -C Transform the right-hand side: C <-- U*C. -C Workspace: need a+b+M; -C prefer a+b+M*N. -C - IF ( BLAS3A ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) - ELSE IF ( BLOCKA ) THEN -C -C Use as many columns of C as possible. -C - DO 50 J = 1, N, CHUNKA - BL = MIN( N-J+1, CHUNKA ) - CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, - $ DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, - $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), - $ LDC ) - 50 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 60 J = 1, N - CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) - CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU, - $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) - 60 CONTINUE -C - END IF - END IF -C - IF( .NOT.SCHURB ) THEN -C -C Transform the right-hand side: C <-- C*V'. -C Workspace: need a+b+N; -C prefer a+b+M*N. -C - IF ( BLAS3B ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) - CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE, - $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) - ELSE IF ( BLOCKB ) THEN -C -C Use as many rows of C as possible. -C - DO 70 I = 1, M, CHUNKB - BL = MIN( M-I+1, CHUNKB ) - CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, - $ DWORK( JWORK ), BL ) - CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE, - $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), - $ LDC ) - 70 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. -C - DO 80 I = 1, M - CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) - CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, - $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) - 80 CONTINUE -C - END IF - END IF -C - DWORK( 1 ) = DBLE( MAXWRK ) -C - RETURN -C *** Last line of SB04PD *** - END diff --git a/slycot/src/SB04PX.f b/slycot/src/SB04PX.f deleted file mode 100644 index 99bd63d3..00000000 --- a/slycot/src/SB04PX.f +++ /dev/null @@ -1,468 +0,0 @@ - SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, - $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in -C -C op(TL)*X*op(TR) + ISGN*X = SCALE*B, -C -C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 -C or -1. op(T) = T or T', where T' denotes the transpose of T. -C -C ARGUMENTS -C -C Mode Parameters -C -C LTRANL LOGICAL -C Specifies the form of op(TL) to be used, as follows: -C = .FALSE.: op(TL) = TL, -C = .TRUE. : op(TL) = TL'. -C -C LTRANR LOGICAL -C Specifies the form of op(TR) to be used, as follows: -C = .FALSE.: op(TR) = TR, -C = .TRUE. : op(TR) = TR'. -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C N1 (input) INTEGER -C The order of matrix TL. N1 may only be 0, 1 or 2. -C -C N2 (input) INTEGER -C The order of matrix TR. N2 may only be 0, 1 or 2. -C -C TL (input) DOUBLE PRECISION array, dimension (LDTL,N1) -C The leading N1-by-N1 part of this array must contain the -C matrix TL. -C -C LDTL INTEGER -C The leading dimension of array TL. LDTL >= MAX(1,N1). -C -C TR (input) DOUBLE PRECISION array, dimension (LDTR,N2) -C The leading N2-by-N2 part of this array must contain the -C matrix TR. -C -C LDTR INTEGER -C The leading dimension of array TR. LDTR >= MAX(1,N2). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N2) -C The leading N1-by-N2 part of this array must contain the -C right-hand side of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N1). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor. SCALE is chosen less than or equal to 1 -C to prevent the solution overflowing. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N2) -C The leading N1-by-N2 part of this array contains the -C solution of the equation. -C Note that X may be identified with B in the calling -C statement. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N1). -C -C XNORM (output) DOUBLE PRECISION -C The infinity-norm of the solution. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if TL and -ISGN*TR have almost reciprocal -C eigenvalues, so TL or TR is perturbed to get a -C nonsingular equation. -C -C NOTE: In the interests of speed, this routine does not -C check the inputs for errors. -C -C METHOD -C -C The equivalent linear algebraic system of equations is formed and -C solved using Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 2000. -C This is a modification and slightly more efficient version of -C SLICOT Library routine SB03MU. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, Sylvester equation, matrix algebra. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, - $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) -C .. -C .. Scalar Arguments .. - LOGICAL LTRANL, LTRANR - INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 - DOUBLE PRECISION SCALE, XNORM -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), - $ X( LDX, * ) -C .. -C .. 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 -C .. -C .. 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 ) -C .. -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. -C .. External Subroutines .. - EXTERNAL DSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. 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. / -C .. -C .. Executable Statements .. -C -C Do not check the input parameters for errors. -C - INFO = 0 - SCALE = ONE -C -C Quick return if possible. -C - IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN - XNORM = ZERO - RETURN - END IF -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' ) / EPS - SGN = ISGN -C - K = N1 + N1 + N2 - 2 - GO TO ( 10, 20, 30, 50 )K -C -C 1-by-1: TL11*X*TR11 + ISGN*X = B11. -C - 10 CONTINUE - TAU1 = TL( 1, 1 )*TR( 1, 1 ) + SGN - BET = ABS( TAU1 ) - IF( BET.LE.SMLNUM ) THEN - TAU1 = SMLNUM - BET = SMLNUM - INFO = 1 - END IF -C - GAM = ABS( B( 1, 1 ) ) - IF( SMLNUM*GAM.GT.BET ) - $ SCALE = ONE / GAM -C - X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 - XNORM = ABS( X( 1, 1 ) ) - RETURN -C -C 1-by-2: -C TL11*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12]. -C [TR21 TR22] -C - 20 CONTINUE -C - SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - $ *ABS( TL( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN - TMP( 4 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN - IF( LTRANR ) THEN - TMP( 2 ) = TL( 1, 1 )*TR( 2, 1 ) - TMP( 3 ) = TL( 1, 1 )*TR( 1, 2 ) - ELSE - TMP( 2 ) = TL( 1, 1 )*TR( 1, 2 ) - TMP( 3 ) = TL( 1, 1 )*TR( 2, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 1, 2 ) - GO TO 40 -C -C 2-by-1: -C op[TL11 TL12]*[X11]*TR11 + ISGN*[X11] = [B11]. -C [TL21 TL22] [X21] [X21] [B21] -C - 30 CONTINUE - SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) - $ *ABS( TR( 1, 1 ) )*EPS, - $ SMLNUM ) - TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN - TMP( 4 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN - IF( LTRANL ) THEN - TMP( 2 ) = TL( 1, 2 )*TR( 1, 1 ) - TMP( 3 ) = TL( 2, 1 )*TR( 1, 1 ) - ELSE - TMP( 2 ) = TL( 2, 1 )*TR( 1, 1 ) - TMP( 3 ) = TL( 1, 2 )*TR( 1, 1 ) - END IF - BTMP( 1 ) = B( 1, 1 ) - BTMP( 2 ) = B( 2, 1 ) - 40 CONTINUE -C -C Solve 2-by-2 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - 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 - 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( X2( 1 ) ) + ABS( X2( 2 ) ) - ELSE - X( 2, 1 ) = X2( 2 ) - XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) - END IF - RETURN -C -C 2-by-2: -C op[TL11 TL12]*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12] -C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] -C -C Solve equivalent 4-by-4 system using complete pivoting. -C Set pivots less than SMIN to SMIN. -C - 50 CONTINUE - SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), - $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) - SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), - $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN - SMIN = MAX( EPS*SMIN, SMLNUM ) - T16( 1, 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN - T16( 2, 2 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN - T16( 3, 3 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN - T16( 4, 4 ) = TL( 2, 2 )*TR( 2, 2 ) + SGN - IF( LTRANL ) THEN - T16( 1, 2 ) = TL( 2, 1 )*TR( 1, 1 ) - T16( 2, 1 ) = TL( 1, 2 )*TR( 1, 1 ) - T16( 3, 4 ) = TL( 2, 1 )*TR( 2, 2 ) - T16( 4, 3 ) = TL( 1, 2 )*TR( 2, 2 ) - ELSE - T16( 1, 2 ) = TL( 1, 2 )*TR( 1, 1 ) - T16( 2, 1 ) = TL( 2, 1 )*TR( 1, 1 ) - T16( 3, 4 ) = TL( 1, 2 )*TR( 2, 2 ) - T16( 4, 3 ) = TL( 2, 1 )*TR( 2, 2 ) - END IF - IF( LTRANR ) THEN - T16( 1, 3 ) = TL( 1, 1 )*TR( 1, 2 ) - T16( 2, 4 ) = TL( 2, 2 )*TR( 1, 2 ) - T16( 3, 1 ) = TL( 1, 1 )*TR( 2, 1 ) - T16( 4, 2 ) = TL( 2, 2 )*TR( 2, 1 ) - ELSE - T16( 1, 3 ) = TL( 1, 1 )*TR( 2, 1 ) - T16( 2, 4 ) = TL( 2, 2 )*TR( 2, 1 ) - T16( 3, 1 ) = TL( 1, 1 )*TR( 1, 2 ) - T16( 4, 2 ) = TL( 2, 2 )*TR( 1, 2 ) - END IF - IF( LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = TL( 2, 1 )*TR( 1, 2 ) - T16( 2, 3 ) = TL( 1, 2 )*TR( 1, 2 ) - T16( 3, 2 ) = TL( 2, 1 )*TR( 2, 1 ) - T16( 4, 1 ) = TL( 1, 2 )*TR( 2, 1 ) - ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN - T16( 1, 4 ) = TL( 2, 1 )*TR( 2, 1 ) - T16( 2, 3 ) = TL( 1, 2 )*TR( 2, 1 ) - T16( 3, 2 ) = TL( 2, 1 )*TR( 1, 2 ) - T16( 4, 1 ) = TL( 1, 2 )*TR( 1, 2 ) - ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN - T16( 1, 4 ) = TL( 1, 2 )*TR( 1, 2 ) - T16( 2, 3 ) = TL( 2, 1 )*TR( 1, 2 ) - T16( 3, 2 ) = TL( 1, 2 )*TR( 2, 1 ) - T16( 4, 1 ) = TL( 2, 1 )*TR( 2, 1 ) - ELSE - T16( 1, 4 ) = TL( 1, 2 )*TR( 2, 1 ) - T16( 2, 3 ) = TL( 2, 1 )*TR( 2, 1 ) - T16( 3, 2 ) = TL( 1, 2 )*TR( 1, 2 ) - T16( 4, 1 ) = TL( 2, 1 )*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 ) -C -C Perform elimination. -C - DO 100 I = 1, 3 - XMAX = ZERO -C - DO 70 IP = I, 4 -C - 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 -C - 70 CONTINUE -C - 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 -C - DO 90 J = I + 1, 4 - T16( J, I ) = T16( J, I ) / T16( I, I ) - BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) -C - DO 80 K = I + 1, 4 - T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) - 80 CONTINUE -C - 90 CONTINUE -C - 100 CONTINUE -C - IF( ABS( T16( 4, 4 ) ).LT.SMIN ) - $ T16( 4, 4 ) = SMIN - 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 -C - DO 120 I = 1, 4 - K = 5 - I - TEMP = ONE / T16( K, K ) - TMP( K ) = BTMP( K )*TEMP -C - DO 110 J = K + 1, 4 - TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) - 110 CONTINUE -C - 120 CONTINUE -C - 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 -C - 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 ) ) ) -C - RETURN -C *** Last line of SB04PX *** - END diff --git a/slycot/src/SB04PY.f b/slycot/src/SB04PY.f deleted file mode 100644 index 46b81f88..00000000 --- a/slycot/src/SB04PY.f +++ /dev/null @@ -1,1111 +0,0 @@ - SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, - $ LDC, SCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the discrete-time Sylvester equation -C -C op(A)*X*op(B) + ISGN*X = scale*C, -C -C where op(A) = A or A**T, A and B are both upper quasi-triangular, -C and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand -C side C and the solution X are M-by-N; and scale is an output scale -C factor, set less than or equal to 1 to avoid overflow in X. The -C solution matrix X is overwritten onto C. -C -C A and B must be in Schur canonical form (as returned by LAPACK -C Library routine DHSEQR), that is, block upper triangular with -C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has -C its diagonal elements equal and its off-diagonal elements of -C opposite sign. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANA CHARACTER*1 -C Specifies the form of op(A) to be used, as follows: -C = 'N': op(A) = A (No transpose); -C = 'T': op(A) = A**T (Transpose); -C = 'C': op(A) = A**T (Conjugate transpose = Transpose). -C -C TRANB CHARACTER*1 -C Specifies the form of op(B) to be used, as follows: -C = 'N': op(B) = B (No transpose); -C = 'T': op(B) = B**T (Transpose); -C = 'C': op(B) = B**T (Conjugate transpose = Transpose). -C -C ISGN INTEGER -C Specifies the sign of the equation as described before. -C ISGN may only be 1 or -1. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A, and the number of rows in the -C matrices X and C. M >= 0. -C -C N (input) INTEGER -C The order of the matrix B, and the number of columns in -C the matrices X and C. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain the -C upper quasi-triangular matrix A, in Schur canonical form. -C The part of A below the first sub-diagonal is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain the -C upper quasi-triangular matrix B, in Schur canonical form. -C The part of B below the first sub-diagonal is not -C referenced. -C -C LDB (input) INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix C. -C On exit, if INFO >= 0, the leading M-by-N part of this -C array contains the solution matrix X. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor, scale, set less than or equal to 1 to -C prevent the solution overflowing. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: A and -ISGN*B have almost reciprocal eigenvalues; -C perturbed values were used to solve the equation -C (but the matrices A and B are unchanged). -C -C METHOD -C -C The solution matrix X is computed column-wise via a back -C substitution scheme, an extension and refinement of the algorithm -C in [1], similar to that used in [2] for continuous-time Sylvester -C equations. A set of equivalent linear algebraic systems of -C equations of order at most four are formed and solved using -C Gaussian elimination with complete pivoting. -C -C REFERENCES -C -C [1] Bartels, R.H. and Stewart, G.W. T -C Solution of the matrix equation A X + XB = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C The algorithm is stable and reliable, since Gaussian elimination -C with complete pivoting is used. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. -C D. Sima, University of Bucharest, April 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. -C Partly based on the routine SYLSV, A. Varga, 1992. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, matrix algebra, Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER TRANA, TRANB - INTEGER INFO, ISGN, LDA, LDB, LDC, M, N - DOUBLE PRECISION SCALE -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ) -C .. -C .. Local Scalars .. - LOGICAL NOTRNA, NOTRNB - INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, - $ MNK1, MNK2, MNL1, MNL2 - DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, - $ SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM -C .. -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) -C .. -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT, DLAMCH, DLANGE - EXTERNAL DDOT, DLAMCH, DLANGE, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLABAD, DLALN2, DSCAL, SB04PX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters -C - NOTRNA = LSAME( TRANA, 'N' ) - NOTRNB = LSAME( TRANB, 'N' ) -C - 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( 'SB04PY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALE = ONE - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'Precision' ) - SMLNUM = DLAMCH( 'Safe minimum' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) - SMLNUM = SMLNUM*DBLE( M*N ) / EPS - BIGNUM = ONE / SMLNUM -C - SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), - $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) -C - SGN = ISGN -C - IF( NOTRNA .AND. NOTRNB ) THEN -C -C Solve A*X*B + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-left corner column by column by -C -C A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C M -C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) + -C J=K+1 -C M L-1 -C SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }. -C J=K I=1 -C -C Start column loop (index = L) -C L1 (L2) : column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 60 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 60 - L1 = L - IF( L.EQ.N ) THEN - L2 = L - ELSE - IF( B( L+1, L ).NE.ZERO ) THEN - L2 = L + 1 - ELSE - L2 = L - END IF - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = M -C - DO 50 K = M, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 50 - K2 = K - IF( K.EQ.1 ) THEN - K1 = K - ELSE - IF( A( K, K-1 ).NE.ZERO ) THEN - K1 = K - 1 - ELSE - K1 = K - END IF - KNEXT = K1 - 1 - END IF -C - MNK1 = MIN( K1+1, M ) - MNK2 = MIN( K2+1, M ) - P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), - $ 1 ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN -C - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 10 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 10 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 20 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 20 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 30 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 30 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) - P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) -C - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L2, L1 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 40 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 40 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - 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 -C - 50 CONTINUE -C - 60 CONTINUE -C - ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN -C -C Solve A'*X*B + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C upper-left corner column by column by -C -C A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C K-1 -C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) + -C J=1 -C K L-1 -C SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }. -C J=1 I=1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = 1 -C - DO 120 L = 1, N - IF( L.LT.LNEXT ) - $ GO TO 120 - L1 = L - IF( L.EQ.N ) THEN - L2 = L - ELSE - IF( B( L+1, L ).NE.ZERO ) THEN - L2 = L + 1 - ELSE - L2 = L - END IF - LNEXT = L2 + 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = 1 -C - DO 110 K = 1, M - IF( K.LT.KNEXT ) - $ GO TO 110 - K1 = K - IF( K.EQ.M ) THEN - K2 = K - ELSE - IF( A( K+1, K ).NE.ZERO ) THEN - K2 = K + 1 - ELSE - K2 = K - END IF - KNEXT = K2 + 1 - END IF -C - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1), - $ 1 ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN -C - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 70 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 70 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L1), 1 ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 80 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 80 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 90 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 90 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) -C - DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L1), 1 ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L2, L1 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L2, L1 ) ) -C - DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, - $ B( 1, L2 ), 1 ) - DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, - $ B( 1, L2 ), 1 ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 100 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 100 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 ) - 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 -C - 110 CONTINUE -C - 120 CONTINUE -C - ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN -C -C Solve A'*X*B' + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C top-right corner column by column by -C -C A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C K-1 -C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' + -C J=1 -C K N -C SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }. -C J=1 I=L+1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = N -C - DO 180 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 180 - L2 = L - IF( L.EQ.1 ) THEN - L1 = L - ELSE - IF( B( L, L-1 ).NE.ZERO ) THEN - L1 = L - 1 - ELSE - L1 = L - END IF - LNEXT = L1 - 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = 1 -C - DO 170 K = 1, M - IF( K.LT.KNEXT ) - $ GO TO 170 - K1 = K - IF( K.EQ.M ) THEN - K2 = K - ELSE - IF( A( K+1, K ).NE.ZERO ) THEN - K2 = K + 1 - ELSE - K2 = K - END IF - KNEXT = K2 + 1 - END IF -C - MNL1 = MIN( L1+1, N ) - MNL2 = MIN( L2+1, N ) - P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) - DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 130 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 130 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, - $ B( L1, MNL1 ), LDB ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 140 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 140 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 150 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 150 CONTINUE -C - CALL DSCAL( K1, SCALOC, DWORK, 1 ) - CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) - P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) - P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) -C - DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 160 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 160 CONTINUE -C - CALL DSCAL( K2, SCALOC, DWORK, 1 ) - CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 ) - 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 -C - 170 CONTINUE -C - 180 CONTINUE -C - ELSE -C -C Solve A*X*B' + ISGN*X = scale*C. -C -C The (K,L)th block of X is determined starting from -C bottom-right corner column by column by -C -C A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) -C -C where -C M -C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' + -C J=K+1 -C M N -C SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }. -C J=K I=L+1 -C -C Start column loop (index = L) -C L1 (L2): column index of the first (last) row of X(K,L). -C - LNEXT = N -C - DO 240 L = N, 1, -1 - IF( L.GT.LNEXT ) - $ GO TO 240 - L2 = L - IF( L.EQ.1 ) THEN - L1 = L - ELSE - IF( B( L, L-1 ).NE.ZERO ) THEN - L1 = L - 1 - ELSE - L1 = L - END IF - LNEXT = L1 - 1 - END IF -C -C Start row loop (index = K) -C K1 (K2): row index of the first (last) row of X(K,L). -C - KNEXT = M -C - DO 230 K = M, 1, -1 - IF( K.GT.KNEXT ) - $ GO TO 230 - K2 = K - IF( K.EQ.1 ) THEN - K1 = K - ELSE - IF( A( K, K-1 ).NE.ZERO ) THEN - K1 = K - 1 - ELSE - K1 = K - END IF - KNEXT = K1 - 1 - END IF -C - MNK1 = MIN( K1+1, M ) - MNK2 = MIN( K2+1, M ) - MNL1 = MIN( L1+1, N ) - MNL2 = MIN( L2+1, N ) - P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) - DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) -C - IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN -C - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) - SCALOC = ONE -C - A11 = A( K1, K1 )*B( L1, L1 ) + SGN - 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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 190 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 190 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) -C - ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, - $ B( L1, MNL1 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), - $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 200 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 200 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K2, L1 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN -C - P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), - $ 1 ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), - $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, - $ ZERO, X, 2, SCALOC, XNORM, IERR ) - IF( IERR.NE.0 ) - $ INFO = 1 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 210 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 210 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - SCALE = SCALE*SCALOC - END IF - C( K1, L1 ) = X( 1, 1 ) - C( K1, L2 ) = X( 2, 1 ) -C - ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN -C - P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), - $ 1 ) - P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) - P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), - $ 1 ) -C - DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L1, MNL2 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + - $ P12*B( L1, L2 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), - $ 1 ) - VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + - $ P22*B( L1, L2 ) ) -C - DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, - $ B( L2, MNL2 ), LDB ) - SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + - $ P12*B( L2, L2 ) ) -C - SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), - $ 1 ) - VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + - $ P22*B( L2, L2 ) ) -C - CALL SB04PX( .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 -C - IF( SCALOC.NE.ONE ) THEN -C - DO 220 J = 1, N - CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) - 220 CONTINUE -C - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) - CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) - 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 -C - 230 CONTINUE -C - 240 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04PY *** - END diff --git a/slycot/src/SB04QD.f b/slycot/src/SB04QD.f deleted file mode 100644 index 29ceae42..00000000 --- a/slycot/src/SB04QD.f +++ /dev/null @@ -1,376 +0,0 @@ - SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the discrete-time Sylvester equation -C -C X + AXB = C, -C -C where A, B, C and X are general N-by-N, M-by-M, N-by-M and -C N-by-M matrices respectively. A Hessenberg-Schur method, which -C reduces A to upper Hessenberg form, H = U'AU, and B' to real -C Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the coefficient matrix A of the equation. -C On exit, the leading N-by-N upper Hessenberg part of this -C array contains the matrix H, and the remainder of the -C leading N-by-N part, together with the elements 2,3,...,N -C of array DWORK, contain the orthogonal transformation -C matrix U (stored in factored form). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the coefficient matrix B of the equation. -C On exit, the leading M-by-M part of this array contains -C the quasi-triangular Schur factor S of the matrix B'. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading N-by-M part of this array contains -C the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) -C The leading M-by-M part of this array contains the -C orthogonal matrix Z used to transform B' to real upper -C Schur form. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,M). -C -C Workspace -C -C IWORK INTEGER array, dimension (4*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain -C the scalar factors of the elementary reflectors used to -C reduce A to upper Hessenberg form, as returned by LAPACK -C Library routine DGEHRD. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to -C compute all the eigenvalues of B (see LAPACK Library -C routine DGEES); -C > M: if a singular matrix was encountered whilst solving -C for the (INFO-M)-th column of matrix X. -C -C METHOD -C -C The matrix A is transformed to upper Hessenberg form H = U'AU by -C the orthogonal transformation matrix U; matrix B' is transformed -C to real upper Schur form S = Z'B'Z using the orthogonal -C transformation matrix Z. The matrix C is also multiplied by the -C transformations, F = U'CZ, and the solution matrix Y of the -C transformed system -C -C Y + HYS' = F -C -C is computed by back substitution. Finally, the matrix Y is then -C multiplied by the orthogonal transformation matrices, X = UYZ', in -C order to obtain the solution matrix X to the original problem. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C 3 3 2 2 -C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N -C operations and is backward stable. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000, Aug. 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) -C .. Local Scalars .. - INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, - $ JWORK, SDIM, WRKOPT -C .. Local Scalars .. - LOGICAL BLAS3, BLOCK -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, - $ DORMHR, DSWAP, SB04QU, SB04QY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 9*N, 5*M, N + M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - ILO = 1 - IHI = N - WRKOPT = 2*N*N + 9*N -C -C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper -C triangular. That is, H = U' * A * U (store U in factored -C form) and S = Z' * B' * Z (save Z). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - DO 20 I = 2, M - CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) - 20 CONTINUE -C -C Workspace: need 5*M; -C prefer larger. -C - IEIG = M + 1 - JWORK = IEIG + M - CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, - $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), - $ LDWORK-JWORK+1, BWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need 2*N; -C prefer N + N*NB. -C - ITAU = 2 - JWORK = ITAU + N - 1 - CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, MAX( INT( DWORK(JWORK) ), N*M )+JWORK-1 ) -C - CHUNK = ( LDWORK - JWORK + 1 ) / M - BLOCK = MIN( CHUNK, N ).GT.1 - BLAS3 = CHUNK.GE.N .AND. BLOCK -C - IF ( BLAS3 ) THEN - CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, - $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many rows of C as possible. -C - DO 40 I = 1, N, CHUNK - BL = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, ONE, - $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) - CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) - 40 CONTINUE -C - ELSE -C - DO 60 I = 1, N - CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 60 CONTINUE -C - END IF -C -C Step 3 : Solve Y + H * Y * S' = F for Y. -C - IND = M - 80 CONTINUE -C - IF ( IND.GT.1 ) THEN - IF ( B(IND,IND-1).EQ.ZERO ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N. -C - CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - IND = IND - 1 - ELSE -C -C Solve a special linear algebraic system of order 2*N. -C Workspace: 2*N*N + 9*N; -C - CALL SB04QU( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - IND = IND - 2 - END IF - GO TO 80 - ELSE IF ( IND.EQ.1 ) THEN -C -C Solve a special linear algebraic system of order N. -C Workspace: N*(N+1)/2 + 3*N; -C - CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, - $ DWORK(JWORK), IWORK, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = INFO + M - RETURN - END IF - END IF -C -C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. -C -C Workspace: need N + M; -C prefer N + M*NB. -C - CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ IFAIL ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C - IF ( BLAS3 ) THEN - CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, - $ Z, LDZ, ZERO, DWORK(JWORK), N ) - CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many rows of C as possible. -C - DO 100 I = 1, N, CHUNK - BL = MIN( N-I+1, CHUNK ) - CALL DGEMM( 'NoTranspose', 'Transpose', BL, M, M, ONE, - $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) - CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) - 100 CONTINUE -C - ELSE -C - DO 120 I = 1, N - CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, - $ ZERO, DWORK(JWORK), 1 ) - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - 120 CONTINUE - END IF -C - RETURN -C *** Last line of SB04QD *** - END diff --git a/slycot/src/SB04QR.f b/slycot/src/SB04QR.f deleted file mode 100644 index 77231d32..00000000 --- a/slycot/src/SB04QR.f +++ /dev/null @@ -1,224 +0,0 @@ - SUBROUTINE SB04QR( M, D, IPR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a linear algebraic system of order M whose coefficient -C matrix has zeros below the third subdiagonal and zero elements on -C the third subdiagonal with even column indices. The matrix is -C stored compactly, row-wise. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the system. M >= 0, M even. -C Note that parameter M should have twice the value in the -C original problem (see SLICOT Library routine SB04QU). -C -C D (input/output) DOUBLE PRECISION array, dimension -C (M*M/2+4*M) -C On entry, the first M*M/2 + 3*M elements of this array -C must contain the coefficient matrix, stored compactly, -C row-wise, and the next M elements must contain the right -C hand side of the linear system, as set by SLICOT Library -C routine SB04QU. -C On exit, the content of this array is updated, the last M -C elements containing the solution with components -C interchanged (see IPR). -C -C IPR (output) INTEGER array, dimension (2*M) -C The leading M elements contain information about the -C row interchanges performed for solving the system. -C Specifically, the i-th component of the solution is -C specified by IPR(i). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if a singular matrix was encountered. -C -C METHOD -C -C Gaussian elimination with partial pivoting is used. The rows of -C the matrix are not actually permuted, only their indices are -C interchanged in array IPR. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, M -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION D(*) -C .. Local Scalars .. - INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, - $ MPI2 - DOUBLE PRECISION D1, D2, D3, DMAX -C .. External Subroutines .. - EXTERNAL DAXPY -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD -C .. Executable Statements .. -C - INFO = 0 - I2 = M*M/2 + 3*M - MPI = M - IPRM = I2 - M1 = M - I1 = 1 -C - DO 20 I = 1, M - MPI = MPI + 1 - IPRM = IPRM + 1 - IPR(MPI) = I1 - IPR(I) = IPRM - I1 = I1 + M1 - IF ( I.GE.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2 - 20 CONTINUE -C - M1 = M - 1 - MPI1 = M + 1 -C -C Reduce to upper triangular form. -C - DO 80 I = 1, M1 - MPI = MPI1 - MPI1 = MPI1 + 1 - IPRM = IPR(MPI) - D1 = D(IPRM) - I1 = 3 - IF ( MOD( I, 2 ).EQ.0 ) I1 = 2 - IF ( I.EQ.M1 ) I1 = 1 - MPI2 = MPI + I1 - L = 0 - DMAX = ABS( D1 ) -C - DO 40 J = MPI1, MPI2 - D2 = D(IPR(J)) - D3 = ABS( D2 ) - IF ( D3.GT.DMAX ) THEN - DMAX = D3 - D1 = D2 - L = J - MPI - END IF - 40 CONTINUE -C -C Check singularity. -C - IF ( DMAX.EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C - IF ( L.GT.0 ) THEN -C -C Permute the row indices. -C - K = IPRM - J = MPI + L - IPRM = IPR(J) - IPR(J) = K - IPR(MPI) = IPRM - K = IPR(I) - I2 = I + L - IPR(I) = IPR(I2) - IPR(I2) = K - END IF - IPRM = IPRM + 1 -C -C Annihilate the subdiagonal elements of the matrix. -C - I2 = I - D3 = D(IPR(I)) -C - DO 60 J = MPI1, MPI2 - I2 = I2 + 1 - IPRM1 = IPR(J) - DMAX = -D(IPRM1)/D1 - D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 - CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) - IPR(J) = IPR(J) + 1 - 60 CONTINUE -C - 80 CONTINUE -C - MPI = M + M - IPRM = IPR(MPI) -C -C Check singularity. -C - IF ( D(IPRM).EQ.ZERO ) THEN - INFO = 1 - RETURN - END IF -C -C Back substitution. -C - D(IPR(M)) = D(IPR(M))/D(IPRM) -C - DO 120 I = M1, 1, -1 - MPI = MPI - 1 - IPRM = IPR(MPI) - IPRM1 = IPRM - DMAX = ZERO -C - DO 100 K = I+1, M - IPRM1 = IPRM1 + 1 - DMAX = DMAX + D(IPR(K))*D(IPRM1) - 100 CONTINUE -C - D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) - 120 CONTINUE -C - RETURN -C *** Last line of SB04QR *** - END diff --git a/slycot/src/SB04QU.f b/slycot/src/SB04QU.f deleted file mode 100644 index 2a53f1e3..00000000 --- a/slycot/src/SB04QU.f +++ /dev/null @@ -1,218 +0,0 @@ - SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order 2*M -C whose coefficient matrix has zeros below the third subdiagonal, -C and zero elements on the third subdiagonal with even column -C indices. Such systems appear when solving discrete-time Sylvester -C equations using the Hessenberg-Schur method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C IND and IND - 1 specify the indices of the columns in C -C to be computed. IND > 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with columns IND-1 and IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (2*M*M+8*M) -C -C IPR INTEGER array, dimension (4*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order 2*M, whose coefficient -C matrix has zeros below the third subdiagonal and zero elements on -C the third subdiagonal with even column indices, is constructed and -C solved. The coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, IND1, J, K, K1, K2, M2 - DOUBLE PRECISION TEMP -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DTRMV, SB04QR -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - IND1 = IND - 1 -C - IF ( IND.LT.N ) THEN - DUM(1) = ZERO - CALL DCOPY ( M, DUM, 0, D, 1 ) - DO 10 I = IND + 1, N - CALL DAXPY ( M, B(IND1,I), C(1,I), 1, D, 1 ) - 10 CONTINUE -C - DO 20 I = 2, M - C(I,IND1) = C(I,IND1) - A(I,I-1)*D(I-1) - 20 CONTINUE - CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, - $ D, 1 ) - DO 30 I = 1, M - C(I,IND1) = C(I,IND1) - D(I) - 30 CONTINUE -C - CALL DCOPY ( M, DUM, 0, D, 1 ) - DO 40 I = IND + 1, N - CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) - 40 CONTINUE -C - DO 50 I = 2, M - C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) - 50 CONTINUE - CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, - $ D, 1 ) - DO 60 I = 1, M - C(I,IND) = C(I,IND) - D(I) - 60 CONTINUE - END IF -C -C Construct the linear algebraic system of order 2*M. -C - K1 = -1 - M2 = 2*M - I2 = M2*(M + 3) - K = M2 -C - DO 80 I = 1, M -C - DO 70 J = MAX( 1, I - 1 ), M - K1 = K1 + 2 - K2 = K1 + K - TEMP = A(I,J) - D(K1) = TEMP * B(IND1,IND1) - D(K1+1) = TEMP * B(IND1,IND) - D(K2) = TEMP * B(IND,IND1) - D(K2+1) = TEMP * B(IND,IND) - IF ( I.EQ.J ) THEN - D(K1) = D(K1) + ONE - D(K2+1) = D(K2+1) + ONE - END IF - 70 CONTINUE -C - K1 = K2 - IF ( I.GT.1 ) K = K - 2 -C -C Store the right hand side. -C - I2 = I2 + 2 - D(I2) = C(I,IND) - D(I2-1) = C(I,IND1) - 80 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04QR( M2, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE - I2 = 0 -C - DO 90 I = 1, M - I2 = I2 + 2 - C(I,IND1) = D(IPR(I2-1)) - C(I,IND) = D(IPR(I2)) - 90 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04QU *** - END diff --git a/slycot/src/SB04QY.f b/slycot/src/SB04QY.f deleted file mode 100644 index f351a2f4..00000000 --- a/slycot/src/SB04QY.f +++ /dev/null @@ -1,185 +0,0 @@ - SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct and solve a linear algebraic system of order M whose -C coefficient matrix is in upper Hessenberg form. Such systems -C appear when solving discrete-time Sylvester equations using the -C Hessenberg-Schur method. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix B. N >= 0. -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C IND (input) INTEGER -C The index of the column in C to be computed. IND >= 1. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain an -C upper Hessenberg matrix. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,N) -C The leading N-by-N part of this array must contain a -C matrix in real Schur form. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading M-by-N part of this array must -C contain the coefficient matrix C of the equation. -C On exit, the leading M-by-N part of this array contains -C the matrix C with column IND updated. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M). -C -C Workspace -C -C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) -C -C IPR INTEGER array, dimension (2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C > 0: if INFO = IND, a singular matrix was encountered. -C -C METHOD -C -C A special linear algebraic system of order M, with coefficient -C matrix in upper Hessenberg form is constructed and solved. The -C coefficient matrix is stored compactly, row-wise. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, IND, LDA, LDB, LDC, M, N -C .. Array Arguments .. - INTEGER IPR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) -C .. Local Scalars .. - INTEGER I, I2, J, K, K1, K2, M1 -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, DTRMV, SB04MW -C .. Executable Statements .. -C - IF ( IND.LT.N ) THEN - DUM(1) = ZERO - CALL DCOPY ( M, DUM, 0, D, 1 ) - DO 10 I = IND + 1, N - CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) - 10 CONTINUE - DO 20 I = 2, M - C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) - 20 CONTINUE - CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, - $ D, 1 ) - DO 30 I = 1, M - C(I,IND) = C(I,IND) - D(I) - 30 CONTINUE - END IF -C - M1 = M + 1 - I2 = ( M*M1 )/2 + M1 - K2 = 1 - K = M -C -C Construct the linear algebraic system of order M. -C - DO 40 I = 1, M - J = M1 - K - CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) - CALL DSCAL ( K, B(IND,IND), D(K2), 1 ) - K1 = K2 - K2 = K2 + K - IF ( I.GT.1 ) THEN - K1 = K1 + 1 - K = K - 1 - END IF - D(K1) = D(K1) + ONE -C -C Store the right hand side. -C - D(I2) = C(I,IND) - I2 = I2 + 1 - 40 CONTINUE -C -C Solve the linear algebraic system and store the solution in C. -C - CALL SB04MW( M, D, IPR, INFO ) -C - IF ( INFO.NE.0 ) THEN - INFO = IND - ELSE -C - DO 50 I = 1, M - C(I,IND) = D(IPR(I)) - 50 CONTINUE -C - END IF -C - RETURN -C *** Last line of SB04QY *** - END diff --git a/slycot/src/SB04RD.f b/slycot/src/SB04RD.f deleted file mode 100644 index 6fd6feae..00000000 --- a/slycot/src/SB04RD.f +++ /dev/null @@ -1,406 +0,0 @@ - SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, - $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the discrete-time Sylvester equation -C -C X + AXB = C, -C -C with at least one of the matrices A or B in Schur form and the -C other in Hessenberg or Schur form (both either upper or lower); -C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, -C respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHU CHARACTER*1 -C Indicates whether A and/or B is/are in Schur or -C Hessenberg form as follows: -C = 'A': A is in Schur form, B is in Hessenberg form; -C = 'B': B is in Schur form, A is in Hessenberg form; -C = 'S': Both A and B are in Schur form. -C -C ULA CHARACTER*1 -C Indicates whether A is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and -C upper Schur form otherwise; -C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and -C lower Schur form otherwise. -C -C ULB CHARACTER*1 -C Indicates whether B is in upper or lower Schur form or -C upper or lower Hessenberg form as follows: -C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and -C upper Schur form otherwise; -C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and -C lower Schur form otherwise. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C coefficient matrix A of the equation. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading M-by-M part of this array must contain the -C coefficient matrix B of the equation. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) -C On entry, the leading N-by-M part of this array must -C contain the coefficient matrix C of the equation. -C On exit, if INFO = 0, the leading N-by-M part of this -C array contains the solution matrix X of the problem. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity in -C the Sylvester equation. If the user sets TOL > 0, then the -C given value of TOL is used as a lower bound for the -C reciprocal condition number; a matrix whose estimated -C condition number is less than 1/TOL is considered to be -C nonsingular. If the user sets TOL <= 0, then a default -C tolerance, defined by TOLDEF = EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*MAX(M,N)) -C This parameter is not referenced if ABSCHU = 'S', -C ULA = 'U', and ULB = 'U'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; -C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if a (numerically) singular matrix T was encountered -C during the computation of the solution matrix X. -C That is, the estimated reciprocal condition number -C of T is less than or equal to TOL. -C -C METHOD -C -C Matrices A and B are assumed to be in (upper or lower) Hessenberg -C or Schur form (with at least one of them in Schur form). The -C solution matrix X is then computed by rows or columns via the back -C substitution scheme proposed by Golub, Nash and Van Loan (see -C [1]), which involves the solution of triangular systems of -C equations that are constructed recursively and which may be nearly -C singular if A and -B have almost reciprocal eigenvalues. If near -C singularity is detected, then the routine returns with the Error -C Indicator (INFO) set to 1. -C -C REFERENCES -C -C [1] Golub, G.H., Nash, S. and Van Loan, C.F. -C A Hessenberg-Schur method for the problem AX + XB = C. -C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. -C -C [2] Sima, V. -C Algorithms for Linear-quadratic Optimization. -C Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C 2 2 -C The algorithm requires approximately 5M N + 0.5MN operations in -C 2 2 -C the worst case and 2.5M N + 0.5MN operations in the best case -C (where M is the order of the matrix in Hessenberg form and N is -C the order of the matrix in Schur form) and is mixed stable (see -C [1]). -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHU, ULA, ULB - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) -C .. Local Scalars .. - CHARACTER ABSCHR - LOGICAL LABSCB, LABSCS, LULA, LULB - INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, - $ LDW, MAXMN - DOUBLE PRECISION SCALE, TOL1 -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - MAXMN = MAX( M, N ) - LABSCB = LSAME( ABSCHU, 'B' ) - LABSCS = LSAME( ABSCHU, 'S' ) - LULA = LSAME( ULA, 'U' ) - LULB = LSAME( ULB, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. - $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.2*N .OR. - $ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND. - $ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB04RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAXMN.EQ.0 ) - $ RETURN -C - IF ( LABSCS .AND. LULA .AND. LULB ) THEN -C -C If both matrices are in a real Schur form, use SB04PY. -C - CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, - $ B, LDB, C, LDC, SCALE, DWORK, INFO ) - IF ( SCALE.NE.ONE ) - $ INFO = 1 - RETURN - END IF -C - LDW = 2*MAXMN - JWORK = LDW*LDW + 3*LDW + 1 - TOL1 = TOL - IF ( TOL1.LE.ZERO ) - $ TOL1 = DLAMCH( 'Epsilon' ) -C -C Choose the smallest of both matrices as the one in Hessenberg -C form when possible. -C - ABSCHR = ABSCHU - IF ( LABSCS ) THEN - IF ( N.GT.M ) THEN - ABSCHR = 'A' - ELSE - ABSCHR = 'B' - END IF - END IF - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C B is in Schur form: recursion on the columns of B. -C - IF ( LULB ) THEN -C -C B is upper: forward recursion. -C - IBEG = 1 - IEND = M - FWD = 1 - INCR = 0 - ELSE -C -C B is lower: backward recursion. -C - IBEG = M - IEND = 1 - FWD = -1 - INCR = -1 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( B(I+FWD,I).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, - $ A, LDA, DWORK(JWORK), DWORK ) - CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) - ELSE - IPINCR = I + INCR - CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, - $ A, LDA, DWORK(JWORK), DWORK ) - CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), - $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), - $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) - CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) - END IF - I = I + FWD*ISTEP - GO TO 20 - END IF -C END WHILE 20 - ELSE -C -C A is in Schur form: recursion on the rows of A. -C - IF ( LULA ) THEN -C -C A is upper: backward recursion. -C - IBEG = N - IEND = 1 - FWD = -1 - INCR = -1 - ELSE -C -C A is lower: forward recursion. -C - IBEG = 1 - IEND = N - FWD = 1 - INCR = 0 - END IF - I = IBEG -C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO - 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN -C -C Test for 1-by-1 or 2-by-2 diagonal block in the Schur -C form. -C - IF ( I.EQ.IEND ) THEN - ISTEP = 1 - ELSE - IF ( A(I,I+FWD).EQ.ZERO ) THEN - ISTEP = 1 - ELSE - ISTEP = 2 - END IF - END IF -C - IF ( ISTEP.EQ.1 ) THEN - CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, - $ B, LDB, DWORK(JWORK), DWORK ) - CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), - $ TOL1, IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) - ELSE - IPINCR = I + INCR - CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, - $ B, LDB, DWORK(JWORK), DWORK ) - CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), - $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), - $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, - $ IWORK, DWORK, LDW, INFO ) - IF ( INFO.EQ.1 ) - $ RETURN - CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) - CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) - END IF - I = I + FWD*ISTEP - GO TO 40 - END IF -C END WHILE 40 - END IF -C - RETURN -C *** Last line of SB04RD *** - END diff --git a/slycot/src/SB04RV.f b/slycot/src/SB04RV.f deleted file mode 100644 index a385fb8a..00000000 --- a/slycot/src/SB04RV.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, - $ LDBA, D, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand sides D for a system of equations in -C quasi-Hessenberg form solved via SB04RX (case with 2 right-hand -C sides). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation X + AXB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the first column/row of C to be used in -C the construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C, the matrix not contained in AB. -C -C LDBA INTEGER -C The leading dimension of array BA. -C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading 2*N or 2*M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side stored as a matrix with two rows. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C where LDWORK is equal to 2*N or 2*M (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDBA, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the 2 columns of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) - CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, - $ ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX+1), - $ 1, ZERO, DWORK(N+1), 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, - $ ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.LT.M-1 ) THEN - CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, - $ AB(INDX+2,INDX+1), 1, ZERO, DWORK(N+1), 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, - $ ONE, D(2), 2 ) - END IF - END IF - ELSE -C -C Construct the 2 rows of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) - CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N-1 ) THEN - CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, - $ AB(INDX,INDX+2), LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, - $ AB(INDX+1,INDX+2), LDAB, ZERO, DWORK(M+1), - $ 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, - $ ONE, D(2), 2 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), - $ LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX+1,1), - $ LDAB, ZERO, DWORK(M+1), 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, - $ D(1), 2 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, - $ ONE, D(2), 2 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04RV *** - END diff --git a/slycot/src/SB04RW.f b/slycot/src/SB04RW.f deleted file mode 100644 index 9dc815c6..00000000 --- a/slycot/src/SB04RW.f +++ /dev/null @@ -1,178 +0,0 @@ - SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, - $ LDBA, D, DWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the right-hand side D for a system of equations in -C Hessenberg form solved via SB04RY (case with 1 right-hand side). -C -C ARGUMENTS -C -C Mode Parameters -C -C ABSCHR CHARACTER*1 -C Indicates whether AB contains A or B, as follows: -C = 'A': AB contains A; -C = 'B': AB contains B. -C -C UL CHARACTER*1 -C Indicates whether AB is upper or lower Hessenberg matrix, -C as follows: -C = 'U': AB is upper Hessenberg; -C = 'L': AB is lower Hessenberg. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The order of the matrix B. M >= 0. -C -C C (input) DOUBLE PRECISION array, dimension (LDC,M) -C The leading N-by-M part of this array must contain both -C the not yet modified part of the coefficient matrix C of -C the Sylvester equation X + AXB = C, and both the currently -C computed part of the solution of the Sylvester equation. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,N). -C -C INDX (input) INTEGER -C The position of the column/row of C to be used in the -C construction of the right-hand side D. -C -C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C. -C -C LDAB INTEGER -C The leading dimension of array AB. -C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on -C ABSCHR = 'A' or ABSCHR = 'B', respectively). -C -C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) -C The leading N-by-N or M-by-M part of this array must -C contain either A or B of the Sylvester equation -C X + AXB = C, the matrix not contained in AB. -C -C LDBA INTEGER -C The leading dimension of array BA. -C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively). -C -C D (output) DOUBLE PRECISION array, dimension (*) -C The leading N or M part of this array (depending on -C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the -C right-hand side. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C where LDWORK is equal to N or M (depending on ABSCHR = 'B' -C or ABSCHR = 'A', respectively). -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ABSCHR, UL - INTEGER INDX, LDAB, LDBA, LDC, M, N -C .. Array Arguments .. - DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV -C .. Executable Statements .. -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - IF ( LSAME( ABSCHR, 'B' ) ) THEN -C -C Construct the column of the right-hand side. -C - CALL DCOPY( N, C(1,INDX), 1, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, - $ ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, - $ ONE, D, 1 ) - END IF - ELSE - IF ( INDX.LT.M ) THEN - CALL DGEMV( 'N', N, M-INDX, ONE, C(1,INDX+1), LDC, - $ AB(INDX+1,INDX), 1, ZERO, DWORK, 1 ) - CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, D, - $ 1 ) - END IF - END IF - ELSE -C -C Construct the row of the right-hand side. -C - CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) - IF ( LSAME( UL, 'U' ) ) THEN - IF ( INDX.LT.N ) THEN - CALL DGEMV( 'T', N-INDX, M, ONE, C(INDX+1,1), LDC, - $ AB(INDX,INDX+1), LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, - $ 1 ) - END IF - ELSE - IF ( INDX.GT.1 ) THEN - CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), - $ LDAB, ZERO, DWORK, 1 ) - CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, - $ 1 ) - END IF - END IF - END IF -C - RETURN -C *** Last line of SB04RW *** - END diff --git a/slycot/src/SB04RX.f b/slycot/src/SB04RX.f deleted file mode 100644 index e84bb188..00000000 --- a/slycot/src/SB04RX.f +++ /dev/null @@ -1,375 +0,0 @@ - SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, - $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in quasi-Hessenberg form -C (Hessenberg form plus two consecutive offdiagonals) with two -C right-hand sides. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether A is upper or lower Hessenberg matrix, -C as follows: -C = 'U': A is upper Hessenberg; -C = 'L': A is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBD1, (input) DOUBLE PRECISION -C LAMBD2, These variables must contain the 2-by-2 block to be -C LAMBD3, multiplied to the elements of A. -C LAMBD4 -C -C D (input/output) DOUBLE PRECISION array, dimension (2*M) -C On entry, this array must contain the two right-hand -C side vectors of the quasi-Hessenberg system, stored -C row-wise. -C On exit, if INFO = 0, this array contains the two solution -C vectors of the quasi-Hessenberg system, stored row-wise. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the quasi-Hessenberg matrix. -C A matrix whose estimated condition number is less -C than 1/TOL is considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) -C The leading 2*M-by-2*M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the quasi-Hessenberg matrix. The remaining 6*M elements -C are used as workspace for the computation of the -C reciprocal condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. -C LDDWOR >= MAX(1,2*M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the quasi-Hessenberg matrix is (numerically) -C singular. That is, its estimated reciprocal -C condition number is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M, LDA, and LDDWOR must be such that the value -C of the LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, 2*M ) ) -C -C These conditions are not checked by the routine. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, J2, M2, MJ, ML - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON, - $ DTRSV -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN, MOD -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - M2 = M*2 - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - J2 = J*2 - ML = MIN( M, J + 1 ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) - CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 ) - CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 ) - CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 ) - CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) - CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 ) -C - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE - DWORK(J2,J2) = DWORK(J2,J2) + ONE - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(J+3,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R ) - DWORK(J+2,J) = R - DWORK(J+3,J) = ZERO - CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR, - $ DWORK(J+3,J+1), LDDWOR, C, S ) - CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J+2,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) - DWORK(J+1,J) = R - DWORK(J+2,J) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, - $ DWORK(J+2,J+1), LDDWOR, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C, - $ S, R ) - DWORK(MJ+1,MJ-1) = R - DWORK(MJ+1,MJ-2) = ZERO - CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1, - $ C, S ) - CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, - $ S, R ) - DWORK(MJ+1,MJ) = R - DWORK(MJ+1,MJ-1) = ZERO - CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, - $ S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J2 = J*2 - J1 = MAX( J - 1, 1 ) - ML = MIN( M - J + 2, M ) - CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), - $ LDDWOR ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) - CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 ) - CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 ) - CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 ) - CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) - CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 ) -C - DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE - DWORK(J2,J2) = DWORK(J2,J2) + ONE - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C, - $ S, R ) - DWORK(MJ-1,MJ+1) = R - DWORK(MJ-2,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR, - $ DWORK(MJ-2,1), LDDWOR, C, S ) - CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, - $ S, R ) - DWORK(MJ,MJ+1) = R - DWORK(MJ-1,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) - END IF - END IF - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M2 - 1 - MJ = M2 - J - IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN - IF ( DWORK(J,J+3).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R ) - DWORK(J,J+2) = R - DWORK(J,J+3) = ZERO - CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3), - $ 1, C, S ) - CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) - END IF - END IF - IF ( J.LT.M2-1 ) THEN - IF ( DWORK(J,J+2).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) - DWORK(J,J+1) = R - DWORK(J,J+2) = ZERO - CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), - $ 1, C, S ) - CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) - END IF - END IF - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, - $ DWORK(1,M2+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04RX *** - END diff --git a/slycot/src/SB04RY.f b/slycot/src/SB04RY.f deleted file mode 100644 index 2ea8fd91..00000000 --- a/slycot/src/SB04RY.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, - $ DWORK, LDDWOR, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve a system of equations in Hessenberg form with one -C right-hand side. -C -C ARGUMENTS -C -C Mode Parameters -C -C RC CHARACTER*1 -C Indicates processing by columns or rows, as follows: -C = 'R': Row transformations are applied; -C = 'C': Column transformations are applied. -C -C UL CHARACTER*1 -C Indicates whether A is upper or lower Hessenberg matrix, -C as follows: -C = 'U': A is upper Hessenberg; -C = 'L': A is lower Hessenberg. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrix A. M >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain a -C matrix A in Hessenberg form. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C LAMBDA (input) DOUBLE PRECISION -C This variable must contain the value to be multiplied with -C the elements of A. -C -C D (input/output) DOUBLE PRECISION array, dimension (M) -C On entry, this array must contain the right-hand side -C vector of the Hessenberg system. -C On exit, if INFO = 0, this array contains the solution -C vector of the Hessenberg system. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the triangular factor R of the Hessenberg matrix. A matrix -C whose estimated condition number is less than 1/TOL is -C considered to be nonsingular. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) -C The leading M-by-M part of this array is used for -C computing the triangular factor of the QR decomposition -C of the Hessenberg matrix. The remaining 3*M elements are -C used as workspace for the computation of the reciprocal -C condition estimate. -C -C LDDWOR INTEGER -C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 1: if the Hessenberg matrix is (numerically) singular. -C That is, its estimated reciprocal condition number -C is less than or equal to TOL. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C D. Sima, University of Bucharest, May 2000. -C -C REVISIONS -C -C - -C -C Note that RC, UL, M, LDA, and LDDWOR must be such that the value -C of the LOGICAL variable OK in the following statement is true. -C -C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. -C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) -C .AND. -C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. -C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) -C .AND. -C ( M.GE.0 ) -C .AND. -C ( LDA.GE.MAX( 1, M ) ) -C .AND. -C ( LDDWOR.GE.MAX( 1, M ) ) -C -C These conditions are not checked by the routine. -C -C KEYWORDS -C -C Hessenberg form, orthogonal transformation, real Schur form, -C Sylvester equation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER RC, UL - INTEGER INFO, LDA, LDDWOR, M - DOUBLE PRECISION LAMBDA, TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) -C .. Local Scalars .. - CHARACTER TRANS - INTEGER J, J1, MJ - DOUBLE PRECISION C, R, RCOND, S -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLARTG, DROT, DSCAL, DTRCON, DTRSV -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C For speed, no tests on the input scalar arguments are made. -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( LSAME( UL, 'U' ) ) THEN -C - DO 20 J = 1, M - CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) - CALL DSCAL( MIN( J+1, M ), LAMBDA, DWORK(1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + ONE - 20 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is an upper Hessenberg matrix, row transformations. -C - DO 40 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J+1,J).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) - DWORK(J,J) = R - DWORK(J+1,J) = ZERO - CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 40 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is an upper Hessenberg matrix, column transformations. -C - DO 60 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ+1,MJ) = ZERO - CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, - $ S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 60 CONTINUE -C - END IF - ELSE -C - DO 80 J = 1, M - J1 = MAX( J - 1, 1 ) - CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) - CALL DSCAL( M-J1+1, LAMBDA, DWORK(J1,J), 1 ) - DWORK(J,J) = DWORK(J,J) + ONE - 80 CONTINUE -C - IF ( LSAME( RC, 'R' ) ) THEN - TRANS = 'N' -C -C A is a lower Hessenberg matrix, row transformations. -C - DO 100 J = 1, M - 1 - MJ = M - J - IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, - $ R ) - DWORK(MJ+1,MJ+1) = R - DWORK(MJ,MJ+1) = ZERO - CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), - $ LDDWOR, C, S ) - CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) - END IF - 100 CONTINUE -C - ELSE - TRANS = 'T' -C -C A is a lower Hessenberg matrix, column transformations. -C - DO 120 J = 1, M - 1 - MJ = M - J - IF ( DWORK(J,J+1).NE.ZERO ) THEN - CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) - DWORK(J,J) = R - DWORK(J,J+1) = ZERO - CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, - $ S ) - CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) - END IF - 120 CONTINUE -C - END IF - END IF -C - CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, - $ DWORK(1,M+1), IWORK, INFO ) - IF ( RCOND.LE.TOL ) THEN - INFO = 1 - ELSE - CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) - END IF -C - RETURN -C *** Last line of SB04RY *** - END diff --git a/slycot/src/SB06ND.f b/slycot/src/SB06ND.f deleted file mode 100644 index a3774439..00000000 --- a/slycot/src/SB06ND.f +++ /dev/null @@ -1,326 +0,0 @@ - SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F, - $ LDF, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the minimum norm feedback matrix F to perform -C "deadbeat control" on a (A,B)-pair of a state-space model (which -C must be preliminarily reduced to upper "staircase" form using -C SLICOT Library routine AB01OD) such that the matrix R = A + BFU' -C is nilpotent. -C (The transformation matrix U reduces R to upper Schur form with -C zero blocks on its diagonal (of dimension KSTAIR(i)) and -C therefore contains bases for the i-th controllable subspaces, -C where i = 1,...,KMAX). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The actual input dimension. M >= 0. -C -C KMAX (input) INTEGER -C The number of "stairs" in the staircase form as produced -C by SLICOT Library routine AB01OD. 0 <= KMAX <= N. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the transformed state-space matrix of the -C (A,B)-pair with triangular stairs, as produced by SLICOT -C Library routine AB01OD (with option STAGES = 'A'). -C On exit, the leading N-by-N part of this array contains -C the matrix U'AU + U'BF. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the transformed triangular input matrix of the -C (A,B)-pair as produced by SLICOT Library routine AB01OD -C (with option STAGES = 'A'). -C On exit, the leading N-by-M part of this array contains -C the matrix U'B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C KSTAIR (input) INTEGER array, dimension (KMAX) -C The leading KMAX elements of this array must contain the -C dimensions of each "stair" as produced by SLICOT Library -C routine AB01OD. -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) -C On entry, the leading N-by-N part of this array must -C contain either a transformation matrix (e.g. from a -C previous call to other SLICOT routine) or be initialised -C as the identity matrix. -C On exit, the leading N-by-N part of this array contains -C the product of the input matrix U and the state-space -C transformation matrix which reduces A + BFU' to real -C Schur form. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,N). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the -C deadbeat feedback matrix F. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Starting from the (A,B)-pair in "staircase form" with "triangular" -C stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the -C vector KSTAIR): -C -C | B | A * . . . * | -C | 1| 11 . . | -C | | A A . . | -C | | 21 22 . . | -C | | . . . | -C [ B | A ] = | | . . * | -C | | . . | -C | 0 | 0 | -C | | A A | -C | | r,r-1 rr | -C -C where the i-th diagonal block of A has dimension KSTAIR(i), for -C i = 1,2,...,r, the feedback matrix F is constructed recursively in -C r steps (where the number of "stairs" r is given by KMAX). In each -C step a unitary state-space transformation U and a part of F are -C updated in order to achieve the final form: -C -C | 0 A * . . . * | -C | 12 . . | -C | . . | -C | 0 A . . | -C | 23 . . | -C | . . | -C [ U'AU + U'BF ] = | . . * | . -C | . . | -C | | -C | A | -C | r-1,r| -C | | -C | 0 | -C -C -C REFERENCES -C -C [1] Van Dooren, P. -C Deadbeat control: a special inverse eigenvalue problem. -C BIT, 24, pp. 681-699, 1984. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + M) * N**2) operations and is mixed -C numerical stable (see [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. -C Supersedes Release 2.0 routine SB06BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C 1997, December 10; 2003, September 27. -C -C KEYWORDS -C -C Canonical form, deadbeat control, eigenvalue assignment, feedback -C control, orthogonal transformation, real Schur form, staircase -C form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, KMAX, LDA, LDB, LDF, LDU, M, N -C .. Array Arguments .. - INTEGER KSTAIR(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), U(LDU,*) -C .. Local Scalars .. - INTEGER J, J0, JCUR, JKCUR, JMKCUR, KCUR, KK, KMIN, - $ KSTEP, MKCUR, NCONT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLACPY, DLARFG, DLASET, - $ SLCT_DLATZM, DTRSM, XERBLA -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( KMAX.LT.0 .OR. KMAX.GT.N ) 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( LDU.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -12 - ELSE - NCONT = 0 -C - DO 10 KK = 1, KMAX - NCONT = NCONT + KSTAIR(KK) - 10 CONTINUE -C - IF( NCONT.GT.N ) - $ INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB06ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - DO 120 KMIN = 1, KMAX - JCUR = NCONT - KSTEP = KMAX - KMIN -C -C Triangularize bottom part of A (if KSTEP > 0). -C - DO 40 KK = KMAX, KMAX - KSTEP + 1, -1 - KCUR = KSTAIR(KK) -C -C Construct Ukk and store in Fkk. -C - DO 20 J = 1, KCUR - JMKCUR = JCUR - KCUR - CALL DCOPY( KCUR, A(JCUR,JMKCUR), LDA, F(1,JCUR), 1 ) - CALL DLARFG( KCUR+1, A(JCUR,JCUR), F(1,JCUR), 1, - $ DWORK(JCUR) ) - CALL DLASET( 'Full', 1, KCUR, ZERO, ZERO, A(JCUR,JMKCUR), - $ LDA ) -C -C Backmultiply A and U with Ukk. -C - CALL SLCT_DLATZM( 'Right', JCUR-1, KCUR+1, F(1,JCUR), 1, - $ DWORK(JCUR), A(1,JCUR), A(1,JMKCUR), LDA, - $ DWORK ) -C - CALL SLCT_DLATZM( 'Right', N, KCUR+1, F(1,JCUR), 1, - $ DWORK(JCUR), U(1,JCUR), U(1,JMKCUR), LDU, - $ DWORK(N+1) ) - JCUR = JCUR - 1 - 20 CONTINUE -C - 40 CONTINUE -C -C Eliminate diagonal block Aii by feedback Fi. -C - KCUR = KSTAIR(KMIN) - J0 = JCUR - KCUR + 1 - MKCUR = M - KCUR + 1 -C -C Solve for Fi and add B x Fi to A. -C - CALL DLACPY( 'Full', KCUR, KCUR, A(J0,J0), LDA, F(MKCUR,J0), - $ LDF ) - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', KCUR, - $ KCUR, -ONE, B(J0,MKCUR), LDB, F(MKCUR,J0), LDF ) - IF ( J0.GT.1 ) - $ CALL DGEMM( 'No transpose', 'No transpose', J0-1, KCUR, - $ KCUR, ONE, B(1,MKCUR), LDB, F(MKCUR,J0), LDF, - $ ONE, A(1,J0), LDA ) - CALL DLASET( 'Full', KCUR, KCUR, ZERO, ZERO, A(J0,J0), LDA ) - CALL DLASET( 'Full', M-KCUR, KCUR, ZERO, ZERO, F(1,J0), LDF ) -C - IF ( KSTEP.NE.0 ) THEN - JKCUR = NCONT -C -C Premultiply A with Ukk. -C - DO 80 KK = KMAX, KMAX - KSTEP + 1, -1 - KCUR = KSTAIR(KK) - JCUR = JKCUR - KCUR -C - DO 60 J = 1, KCUR - CALL SLCT_DLATZM( 'Left', KCUR+1, N-JCUR+1, - $ F(1,JKCUR), 1, - $ DWORK(JKCUR), A(JKCUR,JCUR), - $ A(JCUR,JCUR), LDA, DWORK(N+1) ) - JCUR = JCUR - 1 - JKCUR = JKCUR - 1 - 60 CONTINUE -C - 80 CONTINUE -C -C Premultiply B with Ukk. -C - JCUR = JCUR + KCUR - JKCUR = JCUR + KCUR -C - DO 100 J = M, M - KCUR + 1, -1 - CALL SLCT_DLATZM( 'Left', KCUR+1, M-J+1, F(1,JKCUR), 1, - $ DWORK(JKCUR), B(JKCUR,J), B(JCUR,J), LDB, - $ DWORK(N+1) ) - JCUR = JCUR - 1 - JKCUR = JKCUR - 1 - 100 CONTINUE -C - END IF - 120 CONTINUE -C - IF ( NCONT.NE.N ) - $ CALL DLASET( 'Full', M, N-NCONT, ZERO, ZERO, F(1,NCONT+1), - $ LDF ) -C - RETURN -C *** Last line of SB06ND *** - END diff --git a/slycot/src/SB08CD.f b/slycot/src/SB08CD.f deleted file mode 100644 index ed703beb..00000000 --- a/slycot/src/SB08CD.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), an output -C injection matrix H, an orthogonal transformation matrix Z, and a -C gain matrix V, such that the systems -C -C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D) -C and -C R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V) -C -C provide a stable left coprime factorization of G in the form -C -1 -C G = R * Q, -C -C where G, Q and R are the corresponding transfer-function matrices -C and the denominator R is co-inner, that is, R(s)*R'(-s) = I in -C the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time -C case. The Z matrix is not explicitly computed. -C -C Note: G must have no observable poles on the imaginary axis -C for a continuous-time system, or on the unit circle for a -C discrete-time system. If the given state-space representation -C is not detectable, the undetectable part of the original -C system is automatically deflated and the order of the systems -C Q and R is accordingly reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrices B -C and BR, and the number of columns of the matrix C. -C N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C, D and DR, and the number of columns -C of the matrices BR and DR. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. The matrix A must not -C have observable eigenvalues on the imaginary axis, if -C DICO = 'C', or on the unit circle, if DICO = 'D'. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The leading NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*(B+H*D), the -C input/state matrix of the numerator factor Q. -C The remaining part of this array is needed as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix V*C*Z, the -C state/output matrix of the numerator factor Q. -C The first NR columns of this array represent the -C state/output matrix of a minimal realization of the -C denominator factor R. -C The remaining part of this array is needed as workspace. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P), if N > 0. -C LDC >= 1, if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,MAX(M,P)) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix. -C On exit, the leading P-by-M part of this array contains -C the matrix V*D representing the input/output matrix -C of the numerator factor Q. -C The remaining part of this array is needed as workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C unobservable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of observable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) -C The leading NQ-by-P part of this array contains the -C leading NQ-by-P part of the output injection matrix -C Z'*H, which reflects the eigenvalues of A lying outside -C the stable region to values which are symmetric with -C respect to the imaginary axis (if DICO = 'C') or the unit -C circle (if DICO = 'D'). The first NR rows of this matrix -C form the input/state matrix of a minimal realization of -C the denominator factor R. -C -C LDBR INTEGER -C The leading dimension of array BR. LDBR >= MAX(1,N). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) -C The leading P-by-P part of this array contains the lower -C triangular matrix V representing the input/output matrix -C of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C C are considered zero (used for observability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(C), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(C) denotes -C the infinity-norm of C. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, P*N + MAX( N*(N+5),P*(P+2),4*P,4*M ) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(H) <= 10*NORM(A)/NORM(C) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C along the diagonal; -C = 3: if DICO = 'C' and the matrix A has an observable -C eigenvalue on the imaginary axis, or DICO = 'D' and -C A has an observable eigenvalue on the unit circle. -C -C METHOD -C -C The subroutine uses the right coprime factorization algorithm with -C inner denominator of [1] applied to G'. -C -C REFERENCES -C -C [1] Varga A. -C A Schur method for computing coprime factorizations with -C inner denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine LCFID. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C May 2003, A. Varga, DLR Oberpfaffenhofen. -C Nov 2003, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - INTEGER I, KBR, KW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL AB07MD, DLASET, DSWAP, MA02AD, MA02BD, SB08DD, - $ TB01XD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.LSAME( DICO, 'C' ) .AND. - $ .NOT.LSAME( DICO, 'D' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) - $ THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN - INFO = -12 - ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, P*N + MAX( N*(N+5), P*(P+2), 4*P, - $ 4*M ) ) ) THEN - INFO = -21 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, P ).EQ.0 ) THEN - NQ = 0 - NR = 0 - DWORK(1) = ONE - CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) - RETURN - END IF -C -C Compute the dual system G' = (A',C',B',D'). -C - CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) -C -C Compute the right coprime factorization with inner -C denominator of G'. -C -C Workspace needed: P*N; -C Additional workspace: need MAX( N*(N+5), P*(P+2), 4*P, 4*M ); -C prefer larger. -C - KBR = 1 - KW = KBR + P*N - CALL SB08DD( DICO, N, P, M, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - IF( INFO.EQ.0 ) THEN -C -C Determine the elements of the left coprime factorization from -C those of the computed right coprime factorization and make the -C state-matrix upper real Schur. -C - CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) -C - CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) - CALL MA02BD( 'Left', NQ, P, BR, LDBR ) -C - DO 10 I = 2, P - CALL DSWAP( I-1, DR(I,1), LDDR, DR(1,I), 1 ) - 10 CONTINUE -C - END IF -C - DWORK(1) = DWORK(KW) + DBLE( KW-1 ) -C - RETURN -C *** Last line of SB08CD *** - END diff --git a/slycot/src/SB08DD.f b/slycot/src/SB08DD.f deleted file mode 100644 index e88c9028..00000000 --- a/slycot/src/SB08DD.f +++ /dev/null @@ -1,583 +0,0 @@ - SUBROUTINE SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, LDWORK, - $ IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), a feedback matrix -C F, an orthogonal transformation matrix Z, and a gain matrix V, -C such that the systems -C -C Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V) -C and -C R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V) -C -C provide a stable right coprime factorization of G in the form -C -1 -C G = Q * R , -C -C where G, Q and R are the corresponding transfer-function matrices -C and the denominator R is inner, that is, R'(-s)*R(s) = I in the -C continuous-time case, or R'(1/z)*R(z) = I in the discrete-time -C case. The Z matrix is not explicitly computed. -C -C Note: G must have no controllable poles on the imaginary axis -C for a continuous-time system, or on the unit circle for a -C discrete-time system. If the given state-space representation -C is not stabilizable, the unstabilizable part of the original -C system is automatically deflated and the order of the systems -C Q and R is accordingly reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrix B and -C the number of columns of the matrices C and CR. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B, D and DR and the number of rows of the -C matrices CR and DR. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C and D. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. The matrix A must not -C have controllable eigenvalues on the imaginary axis, if -C DICO = 'C', or on the unit circle, if DICO = 'D'. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The trailing NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*B*V, the -C input/state matrix of the numerator factor Q. The last -C NR rows of this matrix form the input/state matrix of -C a minimal realization of the denominator factor R. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix (C+D*F)*Z, -C the state/output matrix of the numerator factor Q. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix. -C On exit, the leading P-by-M part of this array contains -C the matrix D*V representing the input/output matrix -C of the numerator factor Q. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C uncontrollable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of controllable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) -C The leading M-by-NQ part of this array contains the -C leading M-by-NQ part of the feedback matrix F*Z, which -C reflects the eigenvalues of A lying outside the stable -C region to values which are symmetric with respect to the -C imaginary axis (if DICO = 'C') or the unit circle (if -C DICO = 'D'). The last NR columns of this matrix form the -C state/output matrix of a minimal realization of the -C denominator factor R. -C -C LDCR INTEGER -C The leading dimension of array CR. LDCR >= MAX(1,M). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) -C The leading M-by-M part of this array contains the upper -C triangular matrix V of order M representing the -C input/output matrix of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,M). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(B), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(B) denotes -C the 1-norm of B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(F) <= 10*NORM(A)/NORM(B) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal; -C = 3: if DICO = 'C' and the matrix A has a controllable -C eigenvalue on the imaginary axis, or DICO = 'D' -C and A has a controllable eigenvalue on the unit -C circle. -C -C METHOD -C -C The subroutine is based on the factorization algorithm of [1]. -C -C REFERENCES -C -C [1] Varga A. -C A Schur method for computing coprime factorizations with inner -C denominators and applications in model reduction. -C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFID. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Feb. 1999, May 2003, A. Varga, DLR Oberpfaffenhofen. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TEN, ZERO - PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER I, IB, IB1, J, K, KFI, KV, KW, KWI, KWR, KZ, L, - $ L1, NB, NCUR, NFP, NLOW, NSUP - DOUBLE PRECISION ALPHA, BNORM, CS, PR, RMAX, SM, SN, TOLER, - $ WRKOPT, X, Y -C .. Local Arrays .. - DOUBLE PRECISION Z(4,4) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - LOGICAL LSAME - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, - $ DTRMM, DTRMV, SB01FY, TB01LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ) ) THEN - INFO = -21 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08DD', -INFO ) - RETURN - END IF -C -C Set DR = I and quick return if possible. -C - NR = 0 - IF( MIN( M, P ).GT.0 ) - $ CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) - IF( MIN( N, M ).EQ.0 ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Set F = 0 in the array CR. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) -C -C Compute the norm of B and set the default tolerance if necessary. -C - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - TOLER = TOL - IF( TOLER.LE.ZERO ) - $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) - IF( BNORM.LE.TOLER ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Compute the bound for the numerical stability condition. -C - RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM -C -C Allocate working storage. -C - KZ = 1 - KWR = KZ + N*N - KWI = KWR + N - KW = KWI + N -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- Z'*A*Z and accumulate the -C transformations in Z. The separation of spectrum of A is -C performed such that the leading NFP-by-NFP submatrix of A -C corresponds to the "stable" eigenvalues which will be not -C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A -C corresponds to the "unstable" eigenvalues to be modified. -C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - IF( DISCR ) THEN - ALPHA = ONE - ELSE - ALPHA = ZERO - END IF - CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA, A, LDA, - $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Perform the pole assignment if there exist "unstable" eigenvalues. -C - NQ = N - IF( NFP.LT.N ) THEN - KV = 1 - KFI = KV + M*M - KW = KFI + 2*M -C -C Set the limits for the bottom diagonal block. -C - NLOW = NFP + 1 - NSUP = N -C -C WHILE (NLOW <= NSUP) DO - 10 IF( NLOW.LE.NSUP ) THEN -C -C Main loop for assigning one or two poles. -C -C Determine the dimension of the last block. -C - IB = 1 - IF( NLOW.LT.NSUP ) THEN - IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 - END IF - L = NSUP - IB + 1 -C -C Check the controllability of the last block. -C - IF( DLANGE( '1-norm', IB, M, B(L,1), LDB, DWORK(KW) ) - $ .LE.TOLER ) THEN -C -C Deflate the uncontrollable block and resume the main -C loop. -C - NSUP = NSUP - IB - ELSE -C -C Determine the M-by-IB feedback matrix FI which assigns -C the selected IB poles for the pair -C ( A(L:L+IB-1,L:L+IB-1), B(L:L+IB-1,1:M) ). -C -C Workspace needed: M*(M+2). -C - CALL SB01FY( DISCR, IB, M, A(L,L), LDA, B(L,1), LDB, - $ DWORK(KFI), M, DWORK(KV), M, INFO ) - IF( INFO.EQ.2 ) THEN - INFO = 3 - RETURN - END IF -C -C Check for possible numerical instability. -C - IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) - $ .GT.RMAX ) IWARN = IWARN + 1 -C -C Update the state matrix A <-- A + B*[0 FI]. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, - $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), - $ LDA ) -C -C Update the feedback matrix F <-- F + V*[0 FI] in CR. -C - IF( DISCR ) - $ CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', - $ M, IB, ONE, DR, LDDR, DWORK(KFI), M ) - K = KFI - DO 30 J = L, L + IB - 1 - DO 20 I = 1, M - CR(I,J) = CR(I,J) + DWORK(K) - K = K + 1 - 20 CONTINUE - 30 CONTINUE -C - IF( DISCR ) THEN -C -C Update the input matrix B <-- B*V. -C - CALL DTRMM( 'Right', 'Upper', 'NoTranspose', - $ 'NonUnit', N, M, ONE, DWORK(KV), M, B, - $ LDB ) -C -C Update the feedthrough matrix DR <-- DR*V. -C - K = KV - DO 40 I = 1, M - CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', - $ M-I+1, DWORK(K), M, DR(I,I), LDDR ) - K = K + M + 1 - 40 CONTINUE - END IF -C - IF( IB.EQ.2 ) THEN -C -C Put the 2x2 block in a standard form. -C - L1 = L + 1 - CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), - $ X, Y, PR, SM, CS, SN ) -C -C Apply the transformation to A, B, C and F. -C - IF( L1.LT.NSUP ) - $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), - $ LDA, CS, SN ) - CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) - CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) - IF( P.GT.0 ) - $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) - CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) - END IF - IF( NLOW+IB.LE.NSUP ) THEN -C -C Move the last block(s) to the leading position(s) of -C the bottom block. -C -C Workspace: need MAX(4*N, 4*M, 4*P). -C - NCUR = NSUP - IB -C WHILE (NCUR >= NLOW) DO - 50 IF( NCUR.GE.NLOW ) THEN -C -C Loop for positioning of the last block. -C -C Determine the dimension of the current block. -C - IB1 = 1 - IF( NCUR.GT.NLOW ) THEN - IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 - END IF - NB = IB1 + IB -C -C Initialize the local transformation matrix Z. -C - CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) - L = NCUR - IB1 + 1 -C -C Exchange two adjacent blocks and accumulate the -C transformations in Z. -C - CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, IB1, - $ IB, DWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Apply the transformation to the rest of A. -C - L1 = L + NB - IF( L1.LE.NSUP ) THEN - CALL DGEMM( 'Transpose', 'NoTranspose', NB, - $ NSUP-L1+1, NB, ONE, Z, 4, A(L,L1), - $ LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, NB, - $ A(L,L1), LDA ) - END IF - CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, NB, - $ NB, ONE, A(1,L), LDA, Z, 4, ZERO, - $ DWORK, N ) - CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), - $ LDA ) -C -C Apply the transformation to B, C and F. -C - CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, NB, - $ ONE, Z, 4, B(L,1), LDB, ZERO, DWORK, - $ NB ) - CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), - $ LDB ) -C - IF( P.GT.0 ) THEN - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NB, - $ NB, ONE, C(1,L), LDC, Z, 4, ZERO, - $ DWORK, P ) - CALL DLACPY( 'Full', P, NB, DWORK, P, - $ C(1,L), LDC ) - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, - $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, - $ DWORK, M ) - CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), - $ LDCR ) -C - NCUR = NCUR - IB1 - GO TO 50 - END IF -C END WHILE 50 -C - END IF - NLOW = NLOW + IB - END IF - GO TO 10 - END IF -C END WHILE 10 -C - NQ = NSUP - NR = NSUP - NFP -C -C Annihilate the elements below the first subdiagonal of A. -C - IF( NQ.GT.2 ) - $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) - END IF -C -C Compute C <-- CQ = C + D*F and D <-- DQ = D*DR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, - $ CR, LDCR, ONE, C, LDC ) - IF( DISCR ) - $ CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, - $ ONE, DR, LDDR, D, LDD ) -C - DWORK(1) = MAX( WRKOPT, DBLE( MAX( M*(M+2), 4*M, 4*P ) ) ) -C - RETURN -C *** Last line of SB08DD *** - END diff --git a/slycot/src/SB08ED.f b/slycot/src/SB08ED.f deleted file mode 100644 index b171c4a1..00000000 --- a/slycot/src/SB08ED.f +++ /dev/null @@ -1,359 +0,0 @@ - SUBROUTINE SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, - $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), an output -C injection matrix H and an orthogonal transformation matrix Z, such -C that the systems -C -C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D) -C and -C R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I) -C -C provide a stable left coprime factorization of G in the form -C -1 -C G = R * Q, -C -C where G, Q and R are the corresponding transfer-function matrices. -C The resulting state dynamics matrix of the systems Q and R has -C eigenvalues lying inside a given stability domain. -C The Z matrix is not explicitly computed. -C -C Note: If the given state-space representation is not detectable, -C the undetectable part of the original system is automatically -C deflated and the order of the systems Q and R is accordingly -C reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrices B -C and BR, and the number of columns of the matrix C. -C N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C, D and DR, and the number of columns of -C the matrices BR and DR. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION array, dimension (2) -C ALPHA(1) contains the desired stability degree to be -C assigned for the eigenvalues of A+H*C, and ALPHA(2) -C the stability margin. The eigenvalues outside the -C ALPHA(2)-stability region will be assigned to have the -C real parts equal to ALPHA(1) < 0 and unmodified -C imaginary parts for a continuous-time system -C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 -C for a discrete-time system (DICO = 'D'). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The leading NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix of the system. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*(B+H*D), the -C input/state matrix of the numerator factor Q. -C The remaining part of this array is needed as workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix of the system. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix C*Z, the -C state/output matrix of the numerator factor Q. -C The first NR columns of this array represent the -C state/output matrix of a minimal realization of the -C denominator factor R. -C The remaining part of this array is needed as workspace. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P), if N > 0. -C LDC >= 1, if N = 0. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array must contain the -C input/output matrix. D represents also the input/output -C matrix of the numerator factor Q. -C This array is modified internally, but restored on exit. -C The remaining part of this array is needed as workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C unobservable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of observable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) -C The leading NQ-by-P part of this array contains the -C leading NQ-by-P part of the output injection matrix -C Z'*H, which moves the eigenvalues of A lying outside -C the ALPHA-stable region to values on the ALPHA-stability -C boundary. The first NR rows of this matrix form the -C input/state matrix of a minimal realization of the -C denominator factor R. -C -C LDBR INTEGER -C The leading dimension of array BR. LDBR >= MAX(1,N). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) -C The leading P-by-P part of this array contains an -C identity matrix representing the input/output matrix -C of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C C are considered zero (used for observability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(C), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(C) denotes -C the infinity-norm of C. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(H) <= 10*NORM(A)/NORM(C) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + H*C)*Z -C along the diagonal. -C -C METHOD -C -C The subroutine uses the right coprime factorization algorithm -C of [1] applied to G'. -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine LCFS. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C May 2003, A. Varga, DLR Oberpfaffenhofen. -C Nov 2003, A. Varga, DLR Oberpfaffenhofen. -C Sep. 2005, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), BR(LDBR,*), - $ C(LDC,*), D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER KBR, KW -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External subroutines .. - EXTERNAL AB07MD, DLASET, MA02AD, MA02BD, SB08FD, TB01XD, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT.( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE - $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) - $ .OR. - $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) - $ ) ) 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( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) - $ THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN - INFO = -13 - ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ) ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, P ).EQ.0 ) THEN - NQ = 0 - NR = 0 - DWORK(1) = ONE - CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) - RETURN - END IF -C -C Compute the dual system G' = (A',C',B',D'). -C - CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) -C -C Compute the right coprime factorization of G' with -C prescribed stability degree. -C -C Workspace needed: P*N; -C Additional workspace: need MAX( N*(N+5), 5*P, 4*M ); -C prefer larger. -C - KBR = 1 - KW = KBR + P*N - CALL SB08FD( DICO, N, P, M, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, - $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - IF( INFO.EQ.0 ) THEN -C -C Determine the elements of the left coprime factorization from -C those of the computed right coprime factorization and make the -C state-matrix upper real Schur. -C - CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) -C - CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) - CALL MA02BD( 'Left', NQ, P, BR, LDBR ) -C - END IF -C - DWORK(1) = DWORK(KW) + DBLE( KW-1 ) -C - RETURN -C *** Last line of SB08ED *** - END diff --git a/slycot/src/SB08FD.f b/slycot/src/SB08FD.f deleted file mode 100644 index 54a21b1d..00000000 --- a/slycot/src/SB08FD.f +++ /dev/null @@ -1,630 +0,0 @@ - SUBROUTINE SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, - $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct, for a given system G = (A,B,C,D), a feedback -C matrix F and an orthogonal transformation matrix Z, such that -C the systems -C -C Q = (Z'*(A+B*F)*Z, Z'*B, (C+D*F)*Z, D) -C and -C R = (Z'*(A+B*F)*Z, Z'*B, F*Z, I) -C -C provide a stable right coprime factorization of G in the form -C -1 -C G = Q * R , -C -C where G, Q and R are the corresponding transfer-function matrices. -C The resulting state dynamics matrix of the systems Q and R has -C eigenvalues lying inside a given stability domain. -C The Z matrix is not explicitly computed. -C -C Note: If the given state-space representation is not stabilizable, -C the unstabilizable part of the original system is automatically -C deflated and the order of the systems Q and R is accordingly -C reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the state vector, i.e. the order of the -C matrix A, and also the number of rows of the matrix B and -C the number of columns of the matrices C and CR. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B, D and DR and the number of rows of the -C matrices CR and DR. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows -C of the matrices C and D. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION array, dimension (2) -C ALPHA(1) contains the desired stability degree to be -C assigned for the eigenvalues of A+B*F, and ALPHA(2) -C the stability margin. The eigenvalues outside the -C ALPHA(2)-stability region will be assigned to have the -C real parts equal to ALPHA(1) < 0 and unmodified -C imaginary parts for a continuous-time system -C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 -C for a discrete-time system (DICO = 'D'). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading NQ-by-NQ part of this array contains -C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the -C state dynamics matrix of the numerator factor Q, in a -C real Schur form. The trailing NR-by-NR part of this matrix -C represents the state dynamics matrix of a minimal -C realization of the denominator factor R. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix. -C On exit, the leading NQ-by-M part of this array contains -C the leading NQ-by-M part of the matrix Z'*B, the -C input/state matrix of the numerator factor Q. The last -C NR rows of this matrix form the input/state matrix of -C a minimal realization of the denominator factor R. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-NQ part of this array contains -C the leading P-by-NQ part of the matrix (C+D*F)*Z, -C the state/output matrix of the numerator factor Q. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C input/output matrix. D represents also the input/output -C matrix of the numerator factor Q. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C NQ (output) INTEGER -C The order of the resulting factors Q and R. -C Generally, NQ = N - NS, where NS is the number of -C uncontrollable eigenvalues outside the stability region. -C -C NR (output) INTEGER -C The order of the minimal realization of the factor R. -C Generally, NR is the number of controllable eigenvalues -C of A outside the stability region (the number of modified -C eigenvalues). -C -C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) -C The leading M-by-NQ part of this array contains the -C leading M-by-NQ part of the feedback matrix F*Z, which -C moves the eigenvalues of A lying outside the ALPHA-stable -C region to values which are on the ALPHA-stability -C boundary. The last NR columns of this matrix form the -C state/output matrix of a minimal realization of the -C denominator factor R. -C -C LDCR INTEGER -C The leading dimension of array CR. LDCR >= MAX(1,M). -C -C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) -C The leading M-by-M part of this array contains an -C identity matrix representing the input/output matrix -C of the denominator factor R. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,M). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The absolute tolerance level below which the elements of -C B are considered zero (used for controllability tests). -C If the user sets TOL <= 0, then an implicitly computed, -C default tolerance, defined by TOLDEF = N*EPS*NORM(B), -C is used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH) and NORM(B) denotes -C the 1-norm of B. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LWORK >= MAX( 1, N*(N+5), 5*M, 4*P ). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = K: K violations of the numerical stability condition -C NORM(F) <= 10*NORM(A)/NORM(B) occured during the -C assignment of eigenvalues. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A to a real Schur form failed; -C = 2: a failure was detected during the ordering of the -C real Schur form of A, or in the iterative process -C for reordering the eigenvalues of Z'*(A + B*F)*Z -C along the diagonal. -C -C METHOD -C -C The subroutine is based on the factorization algorithm of [1]. -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires no more than 14N floating point -C operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFS. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Mar. 2003, May 2003, A. Varga, German Aerospace Center. -C May 2003, V. Sima, Research Institute for Informatics, Bucharest. -C Sep. 2005, A. Varga, German Aerospace Center. -C -C KEYWORDS -C -C Coprime factorization, eigenvalue, eigenvalue assignment, -C feedback control, pole placement, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TEN, ZERO - PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO - INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, - $ LDWORK, M, N, NQ, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), C(LDC,*), - $ CR(LDCR,*), D(LDD,*), DR(LDDR,*), DWORK(*) -C .. Local Scalars .. - LOGICAL DISCR - INTEGER I, IB, IB1, J, K, KFI, KG, KW, KWI, KWR, KZ, L, - $ L1, NB, NCUR, NCUR1, NFP, NLOW, NMOVES, NSUP - DOUBLE PRECISION BNORM, CS, PR, RMAX, SM, SN, TOLER, WRKOPT, X, Y -C .. Local Arrays .. - DOUBLE PRECISION A2(2,2), Z(4,4) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - LOGICAL LSAME - EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, - $ SB01BY, TB01LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -C -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - IWARN = 0 - INFO = 0 -C -C Check the scalar input parameters. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE - $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) - $ .OR. - $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) - $ ) ) 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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN - INFO = -17 - ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), 5*M, 4*P ) ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08FD', -INFO ) - RETURN - END IF -C -C Set DR = I and quick return if possible. -C - NR = 0 - CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) - IF( MIN( N, M ).EQ.0 ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Set F = 0 in the array CR. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) -C -C Compute the norm of B and set the default tolerance if necessary. -C - BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) - TOLER = TOL - IF( TOLER.LE.ZERO ) - $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) - IF( BNORM.LE.TOLER ) THEN - NQ = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Compute the bound for the numerical stability condition. -C - RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM -C -C Allocate working storage. -C - KZ = 1 - KWR = KZ + N*N - KWI = KWR + N - KW = KWI + N -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- Z'*A*Z and accumulate the -C transformations in Z. The separation of spectrum of A is -C performed such that the leading NFP-by-NFP submatrix of A -C corresponds to the "stable" eigenvalues which will be not -C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A -C corresponds to the "unstable" eigenvalues to be modified. -C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. -C -C Workspace needed: N*(N+2); -C Additional workspace: need 3*N; -C prefer larger. -C - CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA(2), A, LDA, - $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = DWORK(KW) + DBLE( KW-1 ) -C -C Perform the pole assignment if there exist "unstable" eigenvalues. -C - NQ = N - IF( NFP.LT.N ) THEN - KG = 1 - KFI = KG + 2*M - KW = KFI + 2*M -C -C Set the limits for the bottom diagonal block. -C - NLOW = NFP + 1 - NSUP = N -C -C WHILE (NLOW <= NSUP) DO - 10 IF( NLOW.LE.NSUP ) THEN -C -C Main loop for assigning one or two poles. -C -C Determine the dimension of the last block. -C - IB = 1 - IF( NLOW.LT.NSUP ) THEN - IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 - END IF - L = NSUP - IB + 1 -C -C Save the last IB rows of B in G. -C - CALL DLACPY( 'Full', IB, M, B(L,1), LDB, DWORK(KG), IB ) -C -C Check the controllability of the last block. -C - IF( DLANGE( '1-norm', IB, M, DWORK(KG), IB, DWORK(KW) ) - $ .LE.TOLER )THEN -C -C Deflate the uncontrollable block and resume the -C main loop. -C - NSUP = NSUP - IB - ELSE -C -C Form the IBxIB matrix A2 from the last diagonal block and -C set the pole(s) to be assigned. -C - A2(1,1) = A(L,L) - IF( IB.EQ.1 ) THEN - SM = ALPHA(1) - IF( DISCR ) SM = SIGN( ALPHA(1), A2(1,1) ) - PR = ALPHA(1) - ELSE - A2(1,2) = A(L,NSUP) - A2(2,1) = A(NSUP,L) - A2(2,2) = A(NSUP,NSUP) - SM = ALPHA(1) + ALPHA(1) - PR = ALPHA(1)*ALPHA(1) - IF( DISCR ) THEN - X = A2(1,1) - Y = SQRT( ABS( A2(1,2)*A2(2,1) ) ) - SM = SM * X / DLAPY2( X, Y ) - ELSE - PR = PR - A2(1,2)*A2(2,1) - END IF - END IF -C -C Determine the M-by-IB feedback matrix FI which assigns -C the selected IB poles for the pair (A2,G). -C -C Workspace needed: 5*M. -C - CALL SB01BY( IB, M, SM, PR, A2, DWORK(KG), DWORK(KFI), - $ TOLER, DWORK(KW), INFO ) - IF( INFO.NE.0 ) THEN -C -C Uncontrollable 2x2 block with double real eigenvalues -C which due to roundoff appear as a pair of complex -C conjugated eigenvalues. -C One of them can be elliminated using the information -C in DWORK(KFI) and DWORK(KFI+M). -C - CS = DWORK(KFI) - SN = -DWORK(KFI+M) -C -C Apply the Givens transformation to A, B, C and F. -C - L1 = L + 1 - CALL DROT( NSUP-L+1, A(L1,L), LDA, A(L,L), - $ LDA, CS, SN ) - CALL DROT( L1, A(1,L1), 1, A(1,L), 1, CS, SN ) - CALL DROT( M, B(L1,1), LDB, B(L,1), LDB, CS, SN ) - IF( P.GT.0 ) - $ CALL DROT( P, C(1,L1), 1, C(1,L), 1, CS, SN ) - CALL DROT( M, CR(1,L1), 1, CR(1,L), 1, CS, SN ) -C -C Deflate the uncontrollable block and resume the -C main loop. -C - A(L1,L) = ZERO - NSUP = NSUP - 1 - INFO = 0 - GO TO 10 - END IF -C -C Check for possible numerical instability. -C - IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) - $ .GT.RMAX ) IWARN = IWARN + 1 -C -C Update the feedback matrix F <-- F + [0 FI] in CR. -C - K = KFI - DO 30 J = L, L + IB - 1 - DO 20 I = 1, M - CR(I,J) = CR(I,J) + DWORK(K) - K = K + 1 - 20 CONTINUE - 30 CONTINUE -C -C Update the state matrix A <-- A + B*[0 FI]. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, - $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), - $ LDA ) - IF( IB.EQ.2 ) THEN -C -C Try to split the 2x2 block and standardize it. -C - L1 = L + 1 - CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), - $ X, Y, PR, SM, CS, SN ) -C -C Apply the transformation to A, B, C and F. -C - IF( L1.LT.NSUP ) - $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), - $ LDA, CS, SN ) - CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) - CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) - IF( P.GT.0 ) - $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) - CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) - END IF - IF( NLOW+IB.LE.NSUP ) THEN -C -C Move the last block(s) to the leading position(s) of -C the bottom block. -C -C Workspace: need MAX(4*N, 4*M, 4*P). -C - NCUR1 = NSUP - IB - NMOVES = 1 - IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN - IB = 1 - NMOVES = 2 - END IF -C -C WHILE (NMOVES > 0) DO - 40 IF( NMOVES.GT.0 ) THEN - NCUR = NCUR1 -C -C WHILE (NCUR >= NLOW) DO - 50 IF( NCUR.GE.NLOW ) THEN -C -C Loop for positioning of the last block. -C -C Determine the dimension of the current block. -C - IB1 = 1 - IF( NCUR.GT.NLOW ) THEN - IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 - END IF - NB = IB1 + IB -C -C Initialize the local transformation matrix Z. -C - CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) - L = NCUR - IB1 + 1 -C -C Exchange two adjacent blocks and accumulate the -C transformations in Z. -C - CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, - $ IB1, IB, DWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Apply the transformation to the rest of A. -C - L1 = L + NB - IF( L1.LE.NSUP ) THEN - CALL DGEMM( 'Transpose', 'NoTranspose', NB, - $ NSUP-L1+1, NB, ONE, Z, 4, - $ A(L,L1), LDA, ZERO, DWORK, NB ) - CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, - $ NB, A(L,L1), LDA ) - END IF - CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, - $ NB, NB, ONE, A(1,L), LDA, Z, 4, - $ ZERO, DWORK, N ) - CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), - $ LDA ) -C -C Apply the transformation to B, C and F. -C - CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, - $ NB, ONE, Z, 4, B(L,1), LDB, ZERO, - $ DWORK, NB ) - CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), - $ LDB ) -C - IF( P.GT.0 ) THEN - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, - $ NB, NB, ONE, C(1,L), LDC, Z, 4, - $ ZERO, DWORK, P ) - CALL DLACPY( 'Full', P, NB, DWORK, P, - $ C(1,L), LDC ) - END IF -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, - $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, - $ DWORK, M ) - CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), - $ LDCR ) -C - NCUR = NCUR - IB1 - GO TO 50 - END IF -C END WHILE 50 -C - NMOVES = NMOVES - 1 - NCUR1 = NCUR1 + 1 - NLOW = NLOW + IB - GO TO 40 - END IF -C END WHILE 40 -C - ELSE - NLOW = NLOW + IB - END IF - END IF - GO TO 10 - END IF -C END WHILE 10 -C - NQ = NSUP - NR = NSUP - NFP -C -C Annihilate the elements below the first subdiagonal of A. -C - IF( NQ.GT.2 ) - $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) - END IF -C -C Compute C <-- CQ = C + D*F. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, - $ CR, LDCR, ONE, C, LDC ) -C - DWORK(1) = MAX( WRKOPT, DBLE( MAX( 5*M, 4*P ) ) ) -C - RETURN -C *** Last line of SB08FD *** - END diff --git a/slycot/src/SB08GD.f b/slycot/src/SB08GD.f deleted file mode 100644 index 0368fdf7..00000000 --- a/slycot/src/SB08GD.f +++ /dev/null @@ -1,256 +0,0 @@ - SUBROUTINE SB08GD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, BR, - $ LDBR, DR, LDDR, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the state-space representation for the system -C G = (A,B,C,D) from the factors Q = (AQR,BQ,CQR,DQ) and -C R = (AQR,BR,CQR,DR) of its left coprime factorization -C -1 -C G = R * Q, -C -C where G, Q and R are the corresponding transfer-function matrices. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. Also the number of rows of the -C matrices B and BR and the number of columns of the matrix -C C. N represents the order of the systems Q and R. N >= 0. -C -C M (input) INTEGER -C The dimension of input vector, i.e. the number of columns -C of the matrices B and D. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector, i.e. the number of rows of -C the matrices C, D and DR and the number of columns of the -C matrices BR and DR. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix AQR of the systems -C Q and R. -C On exit, the leading N-by-N part of this array contains -C the state dynamics matrix of the system G. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix BQ of the system Q. -C On exit, the leading N-by-M part of this array contains -C the input/state matrix of the system G. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix CQR of the systems -C Q and R. -C On exit, the leading P-by-N part of this array contains -C the state/output matrix of the system G. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix DQ of the system Q. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix of the system G. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C BR (input) DOUBLE PRECISION array, dimension (LDBR,P) -C The leading N-by-P part of this array must contain the -C input/state matrix BR of the system R. -C -C LDBR INTEGER -C The leading dimension of array BR. LDBR >= MAX(1,N). -C -C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,P) -C On entry, the leading P-by-P part of this array must -C contain the input/output matrix DR of the system R. -C On exit, the leading P-by-P part of this array contains -C the LU factorization of the matrix DR, as computed by -C LAPACK Library routine DGETRF. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,P). -C -C Workspace -C -C IWORK INTEGER array, dimension (P) -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*P)) -C On exit, DWORK(1) contains an estimate of the reciprocal -C condition number of the matrix DR. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix DR is singular; -C = 2: the matrix DR is numerically singular (warning); -C the calculations continued. -C -C METHOD -C -C The subroutine computes the matrices of the state-space -C representation G = (A,B,C,D) by using the formulas: -C -C -1 -1 -C A = AQR - BR * DR * CQR, C = DR * CQR, -C -1 -1 -C B = BQ - BR * DR * DQ, D = DR * DQ. -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine LCFI. -C -C REVISIONS -C -C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C -C KEYWORDS -C -C Coprime factorization, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDBR, LDC, LDD, LDDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars - DOUBLE PRECISION DRNORM, RCOND -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Check the scalar input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN - INFO = -15 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08GD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( P.EQ.0 )THEN - DWORK(1) = ONE - RETURN - END IF -C -C Factor the matrix DR. First, compute the 1-norm. -C - DRNORM = DLANGE( '1-norm', P, P, DR, LDDR, DWORK ) - CALL DGETRF( P, P, DR, LDDR, IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 1 - DWORK(1) = ZERO - RETURN - END IF -C -1 -C Compute C = DR * CQR. -C - CALL DGETRS( 'NoTranspose', P, N, DR, LDDR, IWORK, C, LDC, INFO ) -C -1 -C Compute A = AQR - BR * DR * CQR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, -ONE, BR, LDBR, - $ C, LDC, ONE, A, LDA ) -C -1 -C Compute D = DR * DQ. -C - CALL DGETRS( 'NoTranspose', P, M, DR, LDDR, IWORK, D, LDD, INFO ) -C -1 -C Compute B = BQ - BR * DR * DQ. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, -ONE, BR, LDBR, - $ D, LDD, ONE, B, LDB ) -C -C Estimate the reciprocal condition number of DR. -C Workspace 4*P. -C - CALL DGECON( '1-norm', P, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, - $ INFO ) - IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) - $ INFO = 2 -C - DWORK(1) = RCOND -C - RETURN -C *** Last line of SB08GD *** - END diff --git a/slycot/src/SB08HD.f b/slycot/src/SB08HD.f deleted file mode 100644 index b1a2227d..00000000 --- a/slycot/src/SB08HD.f +++ /dev/null @@ -1,267 +0,0 @@ - SUBROUTINE SB08HD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, CR, - $ LDCR, DR, LDDR, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the state-space representation for the system -C G = (A,B,C,D) from the factors Q = (AQR,BQR,CQ,DQ) and -C R = (AQR,BQR,CR,DR) of its right coprime factorization -C -1 -C G = Q * R , -C -C where G, Q and R are the corresponding transfer-function matrices. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. Also the number of rows of the -C matrix B and the number of columns of the matrices C and -C CR. N represents the order of the systems Q and R. -C N >= 0. -C -C M (input) INTEGER -C The dimension of input vector. Also the number of columns -C of the matrices B, D and DR and the number of rows of the -C matrices CR and DR. M >= 0. -C -C P (input) INTEGER -C The dimension of output vector. Also the number of rows -C of the matrices C and D. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix AQR of the systems -C Q and R. -C On exit, the leading N-by-N part of this array contains -C the state dynamics matrix of the system G. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix BQR of the systems Q and R. -C On exit, the leading N-by-M part of this array contains -C the input/state matrix of the system G. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix CQ of the system Q. -C On exit, the leading P-by-N part of this array contains -C the state/output matrix of the system G. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the input/output matrix DQ of the system Q. -C On exit, the leading P-by-M part of this array contains -C the input/output matrix of the system G. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C CR (input) DOUBLE PRECISION array, dimension (LDCR,N) -C The leading M-by-N part of this array must contain the -C state/output matrix CR of the system R. -C -C LDCR INTEGER -C The leading dimension of array CR. LDCR >= MAX(1,M). -C -C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,M) -C On entry, the leading M-by-M part of this array must -C contain the input/output matrix DR of the system R. -C On exit, the leading M-by-M part of this array contains -C the LU factorization of the matrix DR, as computed by -C LAPACK Library routine DGETRF. -C -C LDDR INTEGER -C The leading dimension of array DR. LDDR >= MAX(1,M). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*M)) -C On exit, DWORK(1) contains an estimate of the reciprocal -C condition number of the matrix DR. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the matrix DR is singular; -C = 2: the matrix DR is numerically singular (warning); -C the calculations continued. -C -C METHOD -C -C The subroutine computes the matrices of the state-space -C representation G = (A,B,C,D) by using the formulas: -C -C -1 -1 -C A = AQR - BQR * DR * CR, B = BQR * DR , -C -1 -1 -C C = CQ - DQ * DR * CR, D = DQ * DR . -C -C REFERENCES -C -C [1] Varga A. -C Coprime factors model reduction method based on -C square-root balancing-free techniques. -C System Analysis, Modelling and Simulation, -C vol. 11, pp. 303-311, 1993. -C -C CONTRIBUTOR -C -C C. Oara and A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 1998. -C Based on the RASP routine RCFI. -C V. Sima, Research Institute for Informatics, Bucharest, Nov. 1998, -C full BLAS 3 version. -C -C REVISIONS -C -C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. -C Mar. 2000, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Coprime factorization, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDCR, LDD, LDDR, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), - $ D(LDD,*), DR(LDDR,*), DWORK(*) - INTEGER IWORK(*) -C .. Local Scalars - DOUBLE PRECISION DRNORM, RCOND -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DTRSM, MA02GD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Check the scalar input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN - INFO = -15 - END IF - IF( INFO.NE.0 )THEN -C -C Error return. -C - CALL XERBLA( 'SB08HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( M.EQ.0 )THEN - DWORK(1) = ONE - RETURN - END IF -C -C Factor the matrix DR. First, compute the 1-norm. -C - DRNORM = DLANGE( '1-norm', M, M, DR, LDDR, DWORK ) - CALL DGETRF( M, M, DR, LDDR, IWORK, INFO ) - IF( INFO.NE.0 ) THEN - INFO = 1 - DWORK(1) = ZERO - RETURN - END IF -C -1 -C Compute B = BQR * DR , using the factorization P*DR = L*U. -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, M, ONE, - $ DR, LDDR, B, LDB ) - CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', N, M, ONE, - $ DR, LDDR, B, LDB ) - CALL MA02GD( N, B, LDB, 1, M, IWORK, -1 ) -C -1 -C Compute A = AQR - BQR * DR * CR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, -ONE, B, LDB, - $ CR, LDCR, ONE, A, LDA ) -C -1 -C Compute D = DQ * DR . -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, ONE, - $ DR, LDDR, D, LDD ) - CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', P, M, ONE, - $ DR, LDDR, D, LDD ) - CALL MA02GD( P, D, LDD, 1, M, IWORK, -1 ) -C -1 -C Compute C = CQ - DQ * DR * CR. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, -ONE, D, LDD, - $ CR, LDCR, ONE, C, LDC ) -C -C Estimate the reciprocal condition number of DR. -C Workspace 4*M. -C - CALL DGECON( '1-norm', M, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, - $ INFO ) - IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) - $ INFO = 2 -C - DWORK(1) = RCOND -C - RETURN -C *** Last line of SB08HD *** - END diff --git a/slycot/src/SB08MD.f b/slycot/src/SB08MD.f deleted file mode 100644 index 78f6d46c..00000000 --- a/slycot/src/SB08MD.f +++ /dev/null @@ -1,471 +0,0 @@ - SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a real polynomial E(s) such that -C -C (a) E(-s) * E(s) = A(-s) * A(s) and -C (b) E(s) is stable - that is, all the zeros of E(s) have -C non-positive real parts, -C -C which corresponds to computing the spectral factorization of the -C real polynomial A(s) arising from continuous optimality problems. -C -C The input polynomial may be supplied either in the form -C -C A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA -C -C or as -C -C B(s) = A(-s) * A(s) -C = b(0) + b(1) * s**2 + ... + b(DA) * s**(2*DA) (1) -C -C ARGUMENTS -C -C Mode Parameters -C -C ACONA CHARACTER*1 -C Indicates whether the coefficients of A(s) or B(s) = -C A(-s) * A(s) are to be supplied as follows: -C = 'A': The coefficients of A(s) are to be supplied; -C = 'B': The coefficients of B(s) are to be supplied. -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(s) and E(s). DA >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (DA+1) -C On entry, this array must contain either the coefficients -C of the polynomial A(s) in increasing powers of s if -C ACONA = 'A', or the coefficients of the polynomial B(s) in -C increasing powers of s**2 (see equation (1)) if ACONA = -C 'B'. -C On exit, this array contains the coefficients of the -C polynomial B(s) in increasing powers of s**2. -C -C RES (output) DOUBLE PRECISION -C An estimate of the accuracy with which the coefficients of -C the polynomial E(s) have been computed (see also METHOD -C and NUMERICAL ASPECTS). -C -C E (output) DOUBLE PRECISION array, dimension (DA+1) -C The coefficients of the spectral factor E(s) in increasing -C powers of s. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 5*DA+5. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if on entry, A(I) = 0.0, for I = 1,2,...,DA+1. -C = 2: if on entry, ACONA = 'B' but the supplied -C coefficients of the polynomial B(s) are not the -C coefficients of A(-s) * A(s) for some real A(s); -C in this case, RES and E are unassigned; -C = 3: if the iterative process (see METHOD) has failed to -C converge in 30 iterations; -C = 4: if the last computed iterate (see METHOD) is -C unstable. If ACONA = 'B', then the supplied -C coefficients of the polynomial B(s) may not be the -C coefficients of A(-s) * A(s) for some real A(s). -C -C METHOD -C _ _ -C Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s). -C -C The method used by the routine is based on applying the -C Newton-Raphson iteration to the function -C _ _ -C F(e) = A * A - e * e, -C -C which leads to the iteration formulae (see [1]): -C -C _(i) (i) _(i) (i) _ ) -C q * x + x * q = 2 A * A ) -C ) for i = 0, 1, 2,... -C (i+1) (i) (i) ) -C q = (q + x )/2 ) -C -C (0) DA -C Starting from q = (1 + s) (which has no zeros in the closed -C (1) (2) (3) -C right half-plane), the sequence of iterates q , q , q ,... -C converges to a solution of F(e) = 0 which has no zeros in the -C open right half-plane. -C -C The iterates satisfy the following conditions: -C -C (i) -C (a) q is a stable polynomial (no zeros in the closed right -C half-plane) and -C -C (i) (i-1) -C (b) q (1) <= q (1). -C -C (i-1) (i) -C The iterative process stops with q , (where i <= 30) if q -C violates either (a) or (b), or if the condition -C _(i) (i) _ -C (c) RES = ||(q q - A A)|| < tol, -C -C is satisfied, where || . || denotes the largest coefficient of -C _(i) (i) _ -C the polynomial (q q - A A) and tol is an estimate of the -C _(i) (i) -C rounding error in the computed coefficients of q q . If there -C is no convergence after 30 iterations then the routine returns -C with the Error Indicator (INFO) set to 3, and the value of RES may -C indicate whether or not the last computed iterate is close to the -C solution. -C -C If ACONA = 'B', then it is possible that the equation e(-s) * -C e(s) = B(s) has no real solution, which will be the case if A(1) -C < 0 or if ( -1)**DA * A(DA+1) < 0. -C -C REFERENCES -C -C [1] Vostry, Z. -C New Algorithm for Polynomial Spectral Factorization with -C Quadratic Convergence II. -C Kybernetika, 12, pp. 248-259, 1976. -C -C NUMERICAL ASPECTS -C -C The conditioning of the problem depends upon the distance of the -C zeros of A(s) from the imaginary axis and on their multiplicity. -C For a well-conditioned problem the accuracy of the computed -C coefficients of E(s) is of the order of RES. However, for problems -C with zeros near the imaginary axis or with multiple zeros, the -C value of RES may be an overestimate of the true accuracy. -C -C FURTHER COMMENTS -C -C In order for the problem e(-s) * e(s) = B(s) to have a real -C solution e(s), it is necessary and sufficient that B(j*omega) -C >= 0 for any purely imaginary argument j*omega (see [1]). -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08AD by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Factorization, Laplace transform, optimal control, optimal -C filtering, polynomial operations, spectral factorization, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ACONA - INTEGER DA, INFO, LDWORK - DOUBLE PRECISION RES -C .. Array Arguments .. - DOUBLE PRECISION A(*), DWORK(*), E(*) -C .. Local Scalars .. - LOGICAL CONV, LACONA, STABLE - INTEGER BINC, DA1, I, I0, J, K, LAMBDA, LAY, LAYEND, - $ LDIF, LPHEND, LPHI, LQ, M, NC - DOUBLE PRECISION A0, EPS, MU, MUJ, SI, SIGNI, SIGNI0, SIGNJ, - $ SIMIN1, SQRTA0, SQRTMJ, SQRTMU, TOLPHI, W, XDA -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, SB08MY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MOD, SQRT -C .. Executable Statements .. -C - INFO = 0 - LACONA = LSAME( ACONA, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN - INFO = -1 - ELSE IF( DA.LT.0 ) THEN - INFO = -2 - ELSE IF( LDWORK.LT.5*DA + 5 ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB08MD', -INFO ) - RETURN - END IF -C - IF ( .NOT.LACONA ) THEN - CALL DCOPY( DA+1, A, 1, E, 1 ) - ELSE - W = ZERO - CALL SB08MY( DA, A, E, W ) - END IF -C -C Reduce E such that the first and the last element are non-zero. -C - DA1 = DA + 1 -C -C WHILE ( DA1 >= 1 and E(DA1) = 0 ) DO - 20 IF ( DA1.GE.1 ) THEN - IF ( E(DA1).EQ.ZERO ) THEN - DA1 = DA1 - 1 - GO TO 20 - END IF - END IF -C END WHILE 20 -C - DA1 = DA1 - 1 - IF ( DA1.LT.0 ) THEN - INFO = 1 - RETURN - END IF -C - I0 = 1 -C -C WHILE ( E(I0) = 0 ) DO - 40 IF ( E(I0).EQ.ZERO ) THEN - I0 = I0 + 1 - GO TO 40 - END IF -C END WHILE 40 -C - I0 = I0 - 1 - IF ( I0.NE.0 ) THEN - IF ( MOD( I0, 2 ).EQ.0 ) THEN - SIGNI0 = ONE - ELSE - SIGNI0 = -ONE - END IF -C - DO 60 I = 1, DA1 - I0 + 1 - E(I) = SIGNI0*E(I+I0) - 60 CONTINUE -C - DA1 = DA1 - I0 - END IF - IF ( MOD( DA1, 2 ).EQ.0 ) THEN - SIGNI = ONE - ELSE - SIGNI = -ONE - END IF - NC = DA1 + 1 - IF ( ( E(1).LT.ZERO ) .OR. ( ( E(NC)*SIGNI ).LT.ZERO ) ) THEN - INFO = 2 - RETURN - END IF -C -C Initialization. -C - EPS = DLAMCH( 'Epsilon' ) - SI = ONE/DLAMCH( 'Safe minimum' ) - LQ = 1 - LAY = LQ + NC - LAMBDA = LAY + NC - LPHI = LAMBDA + NC - LDIF = LPHI + NC -C - A0 = E(1) - BINC = 1 -C -C Computation of the starting polynomial and scaling of the input -C polynomial. -C - MU = ( A0/ABS( E(NC) ) )**( ONE/DBLE( DA1 ) ) - MUJ = ONE -C - DO 80 J = 1, NC - W = E(J)*MUJ/A0 - A(J) = W - E(J) = BINC - DWORK(LQ+J-1) = BINC - MUJ = MUJ*MU - BINC = BINC*( NC - J )/J - 80 CONTINUE -C - CONV = .FALSE. - STABLE = .TRUE. -C -C The contents of the arrays is, cf [1], -C -C E : the last computed stable polynomial q ; -C i-1 -C DWORK(LAY+1,...,LAY+DA1-1) : a'(1), ..., a'(DA1-1), these values -C are changed during the computation -C into y; -C (LAMBDA+1,...,LAMBDA+DA1-2) : lambda(1), ..., lambda(DA1-2), -C the factors of the Routh -C stability test, (lambda(i) is -C P(i) in [1]); -C (LPHI+1,...,LPHI+DA1-1) : phi(1), ..., phi(DA1-1), the values -C phi(i,j), see [1], scheme (11); -C (LDIF,...,LDIF+DA1) : the coeffs of q (-s) * q (s) - b(s). -C i i -C DWORK(LQ,...,LQ+DA1) : the last computed polynomial q . -C i - I = 0 -C -C WHILE ( I < 30 and CONV = FALSE and STABLE = TRUE ) DO - 100 IF ( I.LT.30 .AND. .NOT.CONV .AND. STABLE ) THEN - I = I + 1 - CALL DCOPY( NC, A, 1, DWORK(LAY), 1 ) - CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LPHI), 1 ) - M = DA1/2 - LAYEND = LAY + DA1 - LPHEND = LPHI + DA1 - XDA = A(NC)/DWORK(LQ+DA1) -C - DO 120 K = 1, M - DWORK(LAY+K) = DWORK(LAY+K) - DWORK(LPHI+2*K) - DWORK(LAYEND-K) = DWORK(LAYEND-K) - DWORK(LPHEND-2*K)*XDA - 120 CONTINUE -C -C Computation of lambda(k) and y(k). -C - K = 1 -C -C WHILE ( K <= DA1 - 2 and STABLE = TRUE ) DO - 140 IF ( ( K.LE.( DA1 - 2 ) ) .AND. STABLE ) THEN - IF ( DWORK(LPHI+K).LE.ZERO ) STABLE = .FALSE. - IF ( STABLE ) THEN - W = DWORK(LPHI+K-1)/DWORK(LPHI+K) - DWORK(LAMBDA+K) = W - CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, - $ DWORK(LPHI+K+1), 2 ) - W = DWORK(LAY+K)/DWORK(LPHI+K) - DWORK(LAY+K) = W - CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, - $ DWORK(LAY+K+1), 1 ) - K = K + 1 - END IF - GO TO 140 - END IF -C END WHILE 140 -C - IF ( DWORK(LPHI+DA1-1).LE.ZERO ) THEN - STABLE = .FALSE. - ELSE - DWORK(LAY+DA1-1) = DWORK(LAY+DA1-1)/DWORK(LPHI+DA1-1) - END IF -C -C STABLE = The polynomial q is stable. -C i-1 - IF ( STABLE ) THEN -C -C Computation of x and q . -C i i -C - DO 160 K = DA1 - 2, 1, -1 - W = DWORK(LAMBDA+K) - CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LAY+K+1), 2, - $ DWORK(LAY+K), 2 ) - 160 CONTINUE -C - DWORK(LAY+DA1) = XDA -C - CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) - SIMIN1 = SI - SI = DWORK(LQ) - SIGNJ = -ONE -C - DO 180 J = 1, DA1 - W = HALF*( DWORK(LQ+J) + SIGNJ*DWORK(LAY+J) ) - DWORK(LQ+J) = W - SI = SI + W - SIGNJ = -SIGNJ - 180 CONTINUE -C - TOLPHI = EPS - CALL SB08MY( DA1, E, DWORK(LDIF), TOLPHI ) - CALL DAXPY( NC, -ONE, A, 1, DWORK(LDIF), 1 ) - RES = ABS( DWORK( IDAMAX( NC, DWORK(LDIF), 1 ) + LDIF-1 ) ) -C -C Convergency test. -C - IF ( ( SI.GT.SIMIN1 ) .OR. ( RES.LT.TOLPHI ) ) THEN - CONV = .TRUE. - END IF - GO TO 100 - END IF - END IF -C END WHILE 100 -C -C Backscaling. -C - MU = ONE/MU - SQRTA0 = SQRT( A0 ) - SQRTMU = SQRT( MU ) - MUJ = ONE - SQRTMJ = ONE -C - DO 200 J = 1, NC - E(J) = E(J)*SQRTA0*SQRTMJ - A(J) = A(J)*A0*MUJ - MUJ = MUJ*MU - SQRTMJ = SQRTMJ*SQRTMU - 200 CONTINUE -C - IF ( I0.NE.0 ) THEN -C - DO 220 J = NC, 1, -1 - E(I0+J) = E(J) - A(I0+J) = SIGNI0*A(J) - 220 CONTINUE -C - DO 240 J = 1, I0 - E(J) = ZERO - A(J) = ZERO - 240 CONTINUE -C - END IF -C - IF ( .NOT.CONV ) THEN - IF ( STABLE ) THEN - INFO = 3 - ELSE - INFO = 4 - END IF - END IF -C - RETURN -C *** Last line of SB08MD *** - END diff --git a/slycot/src/SB08MY.f b/slycot/src/SB08MY.f deleted file mode 100644 index 085be630..00000000 --- a/slycot/src/SB08MY.f +++ /dev/null @@ -1,102 +0,0 @@ - SUBROUTINE SB08MY( DA, A, B, EPSB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of B(s) = A(s) * A(-s) and a norm -C for the accuracy of the computed coefficients. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(s) and B(s). DA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (DA+1) -C This array must contain the coefficients of the polynomial -C A(s) in increasing powers of s. -C -C B (output) DOUBLE PRECISION array, dimension (DA+1) -C This array contains the coefficients of the polynomial -C B(s) in increasing powers of s**2. -C -C EPSB (input/output) DOUBLE PRECISION -C On entry, EPSB must contain the machine precision (see -C LAPACK Library routine DLAMCH). -C On exit, EPSB contains an updated value, using a norm -C for the accuracy of the computed coefficients. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08AZ by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Laplace transform, polynomial operations, spectral factorization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO=2.0D0, - $ THREE = 3.0D0 ) -C .. Scalar Arguments .. - INTEGER DA - DOUBLE PRECISION EPSB -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION MAXSA, SA, SABS, SIGNI, SIGNK, TERM -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. Executable Statements .. -C - SIGNI = ONE - MAXSA = ZERO -C - DO 40 I = 0, DA - SABS = A(I+1)**2 - SA = SIGNI*SABS - SIGNK = -TWO*SIGNI -C - DO 20 K = 1, MIN( I, DA - I ) - TERM = SIGNK*A(I-K+1)*A(I+K+1) - SA = SA + TERM - SABS = SABS + ABS( TERM ) - SIGNK = -SIGNK - 20 CONTINUE -C - B(I+1) = SA - MAXSA = MAX( MAXSA, SABS ) - SIGNI = -SIGNI - 40 CONTINUE -C - EPSB = THREE*MAXSA*EPSB -C - RETURN -C *** Last line of SB08MY *** - END diff --git a/slycot/src/SB08ND.f b/slycot/src/SB08ND.f deleted file mode 100644 index ced79b32..00000000 --- a/slycot/src/SB08ND.f +++ /dev/null @@ -1,382 +0,0 @@ - SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a real polynomial E(z) such that -C -C (a) E(1/z) * E(z) = A(1/z) * A(z) and -C (b) E(z) is stable - that is, E(z) has no zeros with modulus -C greater than 1, -C -C which corresponds to computing the spectral factorization of the -C real polynomial A(z) arising from discrete optimality problems. -C -C The input polynomial may be supplied either in the form -C -C A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA -C -C or as -C -C B(z) = A(1/z) * A(z) -C = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA) -C (1) -C -C ARGUMENTS -C -C Mode Parameters -C -C ACONA CHARACTER*1 -C Indicates whether the coefficients of A(z) or B(z) = -C A(1/z) * A(z) are to be supplied as follows: -C = 'A': The coefficients of A(z) are to be supplied; -C = 'B': The coefficients of B(z) are to be supplied. -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(z) and E(z). DA >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (DA+1) -C On entry, if ACONA = 'A', this array must contain the -C coefficients of the polynomial A(z) in increasing powers -C of z, and if ACONA = 'B', this array must contain the -C coefficients b ,b ,...,b of the polynomial B(z) in -C 0 1 DA -C equation (1). That is, A(i) = b for i = 1,2,...,DA+1. -C i-1 -C On exit, this array contains the coefficients of the -C polynomial B(z) in eqation (1). Specifically, A(i) -C contains b , for i = 1,2,...DA+1. -C i-1 -C -C RES (output) DOUBLE PRECISION -C An estimate of the accuracy with which the coefficients of -C the polynomial E(z) have been computed (see also METHOD -C and NUMERICAL ASPECTS). -C -C E (output) DOUBLE PRECISION array, dimension (DA+1) -C The coefficients of the spectral factor E(z) in increasing -C powers of z. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= 5*DA+5. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 2: if on entry, ACONA = 'B' but the supplied -C coefficients of the polynomial B(z) are not the -C coefficients of A(1/z) * A(z) for some real A(z); -C in this case, RES and E are unassigned; -C = 3: if the iterative process (see METHOD) has failed to -C converge in 30 iterations; -C = 4: if the last computed iterate (see METHOD) is -C unstable. If ACONA = 'B', then the supplied -C coefficients of the polynomial B(z) may not be the -C coefficients of A(1/z) * A(z) for some real A(z). -C -C METHOD -C _ _ -C Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z). -C -C The method used by the routine is based on applying the -C Newton-Raphson iteration to the function -C _ _ -C F(e) = A * A - e * e, -C -C which leads to the iteration formulae (see [1] and [2]) -C -C _(i) (i) _(i) (i) _ ) -C q * x + x * q = 2 A * A ) -C ) for i = 0, 1, 2,... -C (i+1) (i) (i) ) -C q = (q + x )/2 ) -C -C The iteration starts from -C -C (0) DA -C q (z) = (b(0) + b(1) * z + ... + b(DA) * z ) / SQRT( b(0)) -C -C which is a Hurwitz polynomial that has no zeros in the closed unit -C (i) -C circle (see [2], Theorem 3). Then lim q = e, the convergence is -C uniform and e is a Hurwitz polynomial. -C -C The iterates satisfy the following conditions: -C (i) -C (a) q has no zeros in the closed unit circle, -C (i) (i-1) -C (b) q <= q and -C 0 0 -C DA (i) 2 DA 2 -C (c) SUM (q ) - SUM (A ) >= 0. -C k=0 k k=0 k -C (i) -C The iterative process stops if q violates (a), (b) or (c), -C or if the condition -C _(i) (i) _ -C (d) RES = ||(q q - A A)|| < tol, -C -C is satisfied, where || . || denotes the largest coefficient of -C _(i) (i) _ -C the polynomial (q q - A A) and tol is an estimate of the -C _(i) (i) -C rounding error in the computed coefficients of q q . If -C (i-1) -C condition (a) or (b) is violated then q is taken otherwise -C (i) -C q is used. Thus the computed reciprocal polynomial E(z) = z**DA -C * q(1/z) is stable. If there is no convergence after 30 iterations -C then the routine returns with the Error Indicator (INFO) set to 3, -C and the value of RES may indicate whether or not the last computed -C iterate is close to the solution. -C (0) -C If ACONA = 'B', then it is possible that q is not a Hurwitz -C polynomial, in which case the equation e(1/z) * e(z) = B(z) has no -C real solution (see [2], Theorem 3). -C -C REFERENCES -C -C [1] Kucera, V. -C Discrete Linear Control, The polynomial Approach. -C John Wiley & Sons, Chichester, 1979. -C -C [2] Vostry, Z. -C New Algorithm for Polynomial Spectral Factorization with -C Quadratic Convergence I. -C Kybernetika, 11, pp. 415-422, 1975. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08BD by F. Delebecque and -C A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Factorization, Laplace transform, optimal control, optimal -C filtering, polynomial operations, spectral factorization, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, TWO - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ TWO = 2.0D0 ) -C .. Scalar Arguments .. - CHARACTER ACONA - INTEGER DA, INFO, LDWORK - DOUBLE PRECISION RES -C .. Array Arguments .. - DOUBLE PRECISION A(*), DWORK(*), E(*) -C .. Local Scalars .. - LOGICAL CONV, HURWTZ, LACONA - INTEGER I, J, K, LALPHA, LAMBDA, LETA, LQ, LRO, NC, NCK - DOUBLE PRECISION A0, RES0, S, SA0, TOLQ, W -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, SB08NY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C - INFO = 0 - LACONA = LSAME( ACONA, 'A' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN - INFO = -1 - ELSE IF( DA.LT.0 ) THEN - INFO = -2 - ELSE IF( LDWORK.LT.5*DA + 5 ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB08ND', -INFO ) - RETURN - END IF -C - NC = DA + 1 - IF ( .NOT.LACONA ) THEN - IF ( A(1).LE.ZERO ) THEN - INFO = 2 - RETURN - END IF - CALL DCOPY( NC, A, 1, E, 1 ) - ELSE - CALL SB08NY( DA, A, E, W ) - END IF -C -C Initialization. -C - LALPHA = 1 - LRO = LALPHA + NC - LETA = LRO + NC - LAMBDA = LETA + NC - LQ = LAMBDA + NC -C - A0 = E(1) - SA0 = SQRT( A0 ) - S = ZERO -C - DO 20 J = 1, NC - W = E(J) - A(J) = W - W = W/SA0 - E(J) = W - DWORK(LQ-1+J) = W - S = S + W**2 - 20 CONTINUE -C - RES0 = S - A0 -C -C The contents of the arrays is, cf [1], Section 7.6, -C -C E : the last computed Hurwitz polynomial q ; -C i-1 -C DWORK(LALPHA,..,LALPHA+DA-K) : alpha(k,0),...alpha(k,n-k); -C (LRO,...,LRO+DA-K) : alpha(k,n-k),...,alpha(k); -C (LETA,...,LETA+DA) : eta(0),...,eta(n); -C (LAMBDA,...,LAMBDA+DA-1) : lambda(0),...,lambda(n-1) -C -C DWORK(LQ,...,LQ+DA) : the last computed polynomial q . -C i - I = 0 - CONV = .FALSE. - HURWTZ = .TRUE. -C -C WHILE ( I < 30 and CONV = FALSE and HURWTZ = TRUE ) DO - 40 IF ( I.LT.30 .AND. .NOT.CONV .AND. HURWTZ ) THEN - I = I + 1 - CALL DCOPY( NC, A, 1, DWORK(LETA), 1 ) - CALL DSCAL( NC, TWO, DWORK(LETA), 1 ) - CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LALPHA), 1 ) -C -C Computation of lambda(k) and eta(k). -C - K = 1 -C -C WHILE ( K <= DA and HURWTZ = TRUE ) DO - 60 IF ( ( K.LE.DA ) .AND. HURWTZ ) THEN - NCK = NC - K - CALL DCOPY( NCK+1, DWORK(LALPHA), -1, DWORK(LRO), 1 ) - W = DWORK(LALPHA+NCK)/DWORK(LRO+NCK) - IF ( ABS( W ).GE.ONE ) HURWTZ = .FALSE. - IF ( HURWTZ ) THEN - DWORK(LAMBDA+K-1) = W - CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LALPHA), 1 ) - W = DWORK(LETA+NCK)/DWORK(LALPHA) - DWORK(LETA+NCK) = W - CALL DAXPY( NCK-1, -W, DWORK(LALPHA+1), -1, - $ DWORK(LETA+1), 1 ) - K = K + 1 - END IF - GO TO 60 - END IF -C END WHILE 60 -C -C HURWTZ = The polynomial q is a Hurwitz polynomial. -C i-1 - IF ( HURWTZ ) THEN - CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) -C -C Accuracy test. -C - CALL SB08NY( DA, E, DWORK(LQ), TOLQ ) - CALL DAXPY( NC, -ONE, A, 1, DWORK(LQ), 1 ) - RES = ABS( DWORK( IDAMAX( NC, DWORK(LQ), 1 ) + LQ - 1 ) ) - CONV = ( RES.LT.TOLQ ) .OR. ( RES0.LT.ZERO ) -C - IF ( .NOT.CONV ) THEN - DWORK(LETA) = HALF*DWORK(LETA)/DWORK(LALPHA) -C -C Computation of x and q . -C i i -C DWORK(LETA,...,LETA+DA) : eta(k,0),...,eta(k,n) -C (LRO,...,LRO+DA-K+1) : eta(k,n-k+1),...,eta(k,0) -C - DO 80 K = DA, 1, -1 - NCK = NC - K + 1 - CALL DCOPY( NCK, DWORK(LETA), -1, DWORK(LRO), 1 ) - W = DWORK(LAMBDA+K-1) - CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LETA), 1 ) - 80 CONTINUE -C - S = ZERO -C - DO 100 J = 0, DA - W = HALF*( DWORK(LETA+J) + E(J+1) ) - DWORK(LQ+J) = W - S = S + W**2 - 100 CONTINUE -C - RES0 = S - A0 -C -C Test on the monotonicity of q . -C 0 - CONV = DWORK(LQ).GT.E(1) - GO TO 40 - END IF - END IF - END IF -C END WHILE 40 -C -C Reverse the order of the coefficients in the array E. -C - CALL DSWAP( NC, E, 1, DWORK, -1 ) - CALL DSWAP( NC, DWORK, 1, E, 1 ) -C - IF ( .NOT.CONV ) THEN - IF ( HURWTZ ) THEN - INFO = 3 - ELSE IF ( I.EQ.1 ) THEN - INFO = 2 - ELSE - INFO = 4 - END IF - END IF -C - RETURN -C *** Last line of SB08ND *** - END diff --git a/slycot/src/SB08NY.f b/slycot/src/SB08NY.f deleted file mode 100644 index f6c0cb66..00000000 --- a/slycot/src/SB08NY.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE SB08NY( DA, A, B, EPSB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the coefficients of B(z) = A(1/z) * A(z) and a norm for -C the accuracy of the computed coefficients. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C DA (input) INTEGER -C The degree of the polynomials A(z) and B(z). DA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (DA+1) -C This array must contain the coefficients of the polynomial -C A(z) in increasing powers of z. -C -C B (output) DOUBLE PRECISION array, dimension (DA+1) -C This array contains the coefficients of the polynomial -C B(z). -C -C EPSB (output) DOUBLE PRECISION -C A value used for checking the accuracy of the computed -C coefficients. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB08BZ by A.J. Geurts. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Laplace transform, polynomial operations, spectral factorization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION THREE - PARAMETER ( THREE = 3.0D0 ) -C .. Scalar Arguments .. - INTEGER DA - DOUBLE PRECISION EPSB -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - INTEGER I -C .. External Functions .. - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH -C .. Executable Statements .. -C - DO 20 I = 1, DA + 1 - B(I) = DDOT( DA-I+2, A(1), 1, A(I), 1 ) - 20 CONTINUE -C - EPSB = THREE*DLAMCH( 'Epsilon' )*B(1) -C - RETURN -C *** Last line of SB08NY *** - END diff --git a/slycot/src/SB09MD.f b/slycot/src/SB09MD.f deleted file mode 100644 index edb0e2d1..00000000 --- a/slycot/src/SB09MD.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, - $ LDSE, PRE, LDPRE, TOL, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compare two multivariable sequences M1(k) and M2(k) for -C k = 1,2,...,N, and evaluate their closeness. Each of the -C parameters M1(k) and M2(k) is an NC by NB matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of parameters. N >= 0. -C -C NC (input) INTEGER -C The number of rows in M1(k) and M2(k). NC >= 0. -C -C NB (input) INTEGER -C The number of columns in M1(k) and M2(k). NB >= 0. -C -C H1 (input) DOUBLE PRECISION array, dimension (LDH1,N*NB) -C The leading NC-by-N*NB part of this array must contain -C the multivariable sequence M1(k), where k = 1,2,...,N. -C Each parameter M1(k) is an NC-by-NB matrix, whose -C (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for -C i = 1,2,...,NC and j = 1,2,...,NB. -C -C LDH1 INTEGER -C The leading dimension of array H1. LDH1 >= MAX(1,NC). -C -C H2 (input) DOUBLE PRECISION array, dimension (LDH2,N*NB) -C The leading NC-by-N*NB part of this array must contain -C the multivariable sequence M2(k), where k = 1,2,...,N. -C Each parameter M2(k) is an NC-by-NB matrix, whose -C (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for -C i = 1,2,...,NC and j = 1,2,...,NB. -C -C LDH2 INTEGER -C The leading dimension of array H2. LDH2 >= MAX(1,NC). -C -C SS (output) DOUBLE PRECISION array, dimension (LDSS,NB) -C The leading NC-by-NB part of this array contains the -C matrix SS. -C -C LDSS INTEGER -C The leading dimension of array SS. LDSS >= MAX(1,NC). -C -C SE (output) DOUBLE PRECISION array, dimension (LDSE,NB) -C The leading NC-by-NB part of this array contains the -C quadratic error matrix SE. -C -C LDSE INTEGER -C The leading dimension of array SE. LDSE >= MAX(1,NC). -C -C PRE (output) DOUBLE PRECISION array, dimension (LDPRE,NB) -C The leading NC-by-NB part of this array contains the -C percentage relative error matrix PRE. -C -C LDPRE INTEGER -C The leading dimension of array PRE. LDPRE >= MAX(1,NC). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in the computation of the error -C matrices SE and PRE. If the user sets TOL to be less than -C EPS then the tolerance is taken as EPS, where EPS is the -C machine precision (see LAPACK Library routine DLAMCH). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The (i,j)-th element of the matrix SS is defined by: -C N 2 -C SS = SUM M1 (k) . (1) -C ij k=1 ij -C -C The (i,j)-th element of the quadratic error matrix SE is defined -C by: -C N 2 -C SE = SUM (M1 (k) - M2 (k)) . (2) -C ij k=1 ij ij -C -C The (i,j)-th element of the percentage relative error matrix PRE -C is defined by: -C -C PRE = 100 x SQRT( SE / SS ). (3) -C ij ij ij -C -C The following precautions are taken by the routine to guard -C against underflow and overflow: -C -C (i) if ABS( M1 (k) ) > 1/TOL or ABS( M1 (k) - M2 (k) ) > 1/TOL, -C ij ij ij -C -C then SE and SS are set to 1/TOL and PRE is set to 1; and -C ij ij ij -C -C (ii) if ABS( SS ) <= TOL, then PRE is set to 100. -C ij ij -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C 2xNBxNCx(N+1) multiplications/divisions, -C 4xNBxNCxN additions/subtractions and -C NBxNC square roots. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. -C Supersedes Release 2.0 routine SB09AD by S. Van Huffel, Katholieke -C University Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Closeness multivariable sequences, elementary matrix operations, -C real signals, system response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HUNDRD - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 100.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDH1, LDH2, LDPRE, LDSE, LDSS, N, NB, NC - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION H1(LDH1,*), H2(LDH2,*), PRE(LDPRE,*), - $ SE(LDSE,*), SS(LDSS,*) -C .. Local Scalars .. - LOGICAL NOFLOW - INTEGER I, J, K - DOUBLE PRECISION EPSO, SSE, SSS, TOLER, VAR, VARE -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NC.LT.0 ) THEN - INFO = -2 - ELSE IF( NB.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH1.LT.MAX( 1, NC ) ) THEN - INFO = -5 - ELSE IF( LDH2.LT.MAX( 1, NC ) ) THEN - INFO = -7 - ELSE IF( LDSS.LT.MAX( 1, NC ) ) THEN - INFO = -9 - ELSE IF( LDSE.LT.MAX( 1, NC ) ) THEN - INFO = -11 - ELSE IF( LDPRE.LT.MAX( 1, NC ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB09MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. NC.EQ.0 .OR. NB.EQ.0 ) - $ RETURN -C - TOLER = MAX( TOL, DLAMCH( 'Epsilon' ) ) - EPSO = ONE/TOLER -C - DO 60 J = 1, NB -C - DO 40 I = 1, NC - SSE = ZERO - SSS = ZERO - NOFLOW = .TRUE. - K = 0 -C -C WHILE ( ( NOFLOW .AND. ( K .LT. N*NB ) ) DO - 20 IF ( ( NOFLOW ) .AND. ( K.LT.N*NB ) ) THEN - VAR = H1(I,K+J) - VARE = H2(I,K+J) - VAR - IF ( ABS( VAR ).GT.EPSO .OR. ABS( VARE ).GT.EPSO ) - $ THEN - SE(I,J) = EPSO - SS(I,J) = EPSO - PRE(I,J) = ONE - NOFLOW = .FALSE. - ELSE - IF ( ABS( VARE ).GT.TOLER ) SSE = SSE + VARE*VARE - IF ( ABS( VAR ).GT.TOLER ) SSS = SSS + VAR*VAR - K = K + NB - END IF - GO TO 20 - END IF -C END WHILE 20 -C - IF ( NOFLOW ) THEN - SE(I,J) = SSE - SS(I,J) = SSS - PRE(I,J) = HUNDRD - IF ( SSS.GT.TOLER ) PRE(I,J) = SQRT( SSE/SSS )*HUNDRD - END IF - 40 CONTINUE -C - 60 CONTINUE -C - RETURN -C *** Last line of SB09MD *** - END diff --git a/slycot/src/SB10AD.f b/slycot/src/SB10AD.f deleted file mode 100644 index a74b3a8e..00000000 --- a/slycot/src/SB10AD.f +++ /dev/null @@ -1,827 +0,0 @@ - SUBROUTINE SB10AD( JOB, N, M, NP, NCON, NMEAS, GAMMA, A, LDA, - $ B, LDB, C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, - $ LDCK, DK, LDDK, AC, LDAC, BC, LDBC, CC, LDCC, - $ DC, LDDC, RCOND, GTOL, ACTOL, IWORK, LIWORK, - $ DWORK, LDWORK, BWORK, LBWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity optimal n-state -C controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C using modified Glover's and Doyle's 1988 formulas, for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for the estimated minimal possible value of gamma with respect -C to GTOL, where B2 has as column size the number of control inputs -C (NCON) and C2 has as row size the number of measurements (NMEAS) -C being provided to the controller, and then to compute the matrices -C of the closed-loop system -C -C | AC | BC | -C G = |----|----|, -C | CC | DC | -C -C if the stabilizing controller exists. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C (A3) | A-j*omega*I B2 | has full column rank for all omega, -C | C1 D12 | -C -C (A4) | A-j*omega*I B1 | has full row rank for all omega. -C | C2 D21 | -C -C ARGUMENTS -C -C Input/Output Parameters -C -C JOB (input) INTEGER -C Indicates the strategy for reducing the GAMMA value, as -C follows: -C = 1: Use bisection method for decreasing GAMMA from GAMMA -C to GAMMAMIN until the closed-loop system leaves -C stability. -C = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA -C for which the closed-loop system retains stability. -C = 3: First bisection, then scanning. -C = 4: Find suboptimal controller only. -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input/output) DOUBLE PRECISION -C The initial value of gamma on input. It is assumed that -C gamma is sufficiently large so that the controller is -C admissible. GAMMA >= 0. -C On output it contains the minimal estimated gamma. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) -C The leading 2*N-by-2*N part of this array contains the -C closed-loop system state matrix AC. -C -C LDAC INTEGER -C The leading dimension of the array AC. -C LDAC >= max(1,2*N). -C -C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) -C The leading 2*N-by-(M-NCON) part of this array contains -C the closed-loop system input matrix BC. -C -C LDBC INTEGER -C The leading dimension of the array BC. -C LDBC >= max(1,2*N). -C -C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) -C The leading (NP-NMEAS)-by-2*N part of this array contains -C the closed-loop system output matrix CC. -C -C LDCC INTEGER -C The leading dimension of the array CC. -C LDCC >= max(1,NP-NMEAS). -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) -C The leading (NP-NMEAS)-by-(M-NCON) part of this array -C contains the closed-loop system input/output matrix DC. -C -C LDDC INTEGER -C The leading dimension of the array DC. -C LDDC >= max(1,NP-NMEAS). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C For the last successful step: -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Tolerances -C -C GTOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of GAMMA -C and its distance to the estimated minimal possible -C value of GAMMA. -C If GTOL <= 0, then a default value equal to sqrt(EPS) -C is used, where EPS is the relative machine precision. -C -C ACTOL DOUBLE PRECISION -C Upper bound for the poles of the closed-loop system -C used for determining if it is stable. -C ACTOL <= 0 for stable systems. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C -C LIWORK INTEGER -C The dimension of the array IWORK. -C LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C value of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)), -C where -C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2; -C LW2 = max( ( N + NP1 + 1 )*( N + M2 ) + -C max( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), -C ( N + NP2 )*( N + M1 + 1 ) + -C max( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), -C M2 + NP1*NP1 + max( NP1*max( N, M1 ), -C 3*M2 + NP1, 5*M2 ), -C NP2 + M1*M1 + max( max( N, NP1 )*M1, -C 3*NP2 + M1, 5*NP2 ) ); -C LW3 = max( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ), -C 6*min( ND1, M1 ) ), -C NP1*ND2 + max( 4*min( NP1, ND2 ) + -C max( NP1,ND2 ), -C 6*min( NP1, ND2 ) ) ); -C LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; -C LW5 = 2*N*N + M*N + N*NP; -C LW6 = max( M*M + max( 2*M1, 3*N*N + -C max( N*M, 10*N*N + 12*N + 5 ) ), -C NP*NP + max( 2*NP1, 3*N*N + -C max( N*NP, 10*N*N + 12*N + 5 ) )); -C LW7 = M2*NP2 + NP2*NP2 + M2*M2 + -C max( ND1*ND1 + max( 2*ND1, ( ND1 + ND2 )*NP2 ), -C ND2*ND2 + max( 2*ND2, ND2*M2 ), 3*N, -C N*( 2*NP2 + M2 ) + -C max( 2*N*M2, M2*NP2 + -C max( M2*M2 + 3*M2, NP2*( 2*NP2 + -C M2 + max( NP2, N ) ) ) ) ); -C M1 = M - M2, NP1 = NP - NP2, -C ND1 = NP1 - M2, ND2 = M1 - NP2. -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (LBWORK) -C -C LBWORK INTEGER -C The dimension of the array BWORK. LBWORK >= 2*N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix | A-j*omega*I B2 | had not full -C | C1 D12 | -C column rank in respect to the tolerance EPS; -C = 2: if the matrix | A-j*omega*I B1 | had not full row -C | C2 D21 | -C rank in respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance SQRT(EPS); -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance SQRT(EPS); -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21); -C |C1 D12| |C2 D21| -C = 6: if the controller is not admissible (too small value -C of gamma); -C = 7: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 8: if the Y-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is -C zero [3]; -C = 10: if there are numerical problems when estimating -C singular values of D1111, D1112, D1111', D1121'; -C = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22 -C are singular to working precision; -C = 12: if a stabilizing controller cannot be found. -C -C METHOD -C -C The routine implements the Glover's and Doyle's 1988 formulas [1], -C [2], modified to improve the efficiency as described in [3]. -C -C JOB = 1: It tries with a decreasing value of GAMMA, starting with -C the given, and with the newly obtained controller estimates of the -C closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL) -C the iterations can be continued until the given tolerance between -C GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the -C next step GAMMA is increased. The step in the all next iterations -C is step = step/2. The closed-loop system is obtained by the -C formulas given in [2]. -C -C JOB = 2: The same as for JOB = 1, but with non-varying step till -C GAMMA = 0, step = max(0.1, GTOL). -C -C JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker -C procedure. -C -C JOB = 4: Suboptimal controller for current GAMMA only. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, MA, 1995. -C -C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of continuous-time -C linear control systems. -C Rep. 98-14, Department of Engineering, Leicester University, -C Leicester, U.K., 1998. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and on the condition numbers of -C the two Riccati equations, as given by the values of RCOND(1), -C RCOND(2), RCOND(3) and RCOND(4), respectively. -C This approach by estimating the closed-loop system and checking -C its poles seems to be reliable. -C -C CONTRIBUTORS -C -C A. Markovski, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, -C July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, P1, THOUS - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ P1 = 0.1D+0, THOUS = 1.0D+3 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, JOB, LBWORK, LDA, LDAC, LDAK, LDB, LDBC, - $ LDBK, LDC, LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, - $ LIWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION ACTOL, GAMMA, GTOL -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), - $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), - $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), - $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), - $ DWORK( * ), RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER I, INF, INFO2, INFO3, IWAC, IWC, IWD, IWD1, - $ IWF, IWH, IWRE, IWRK, IWS1, IWS2, IWTU, IWTY, - $ IWWI, IWWR, IWX, IWY, LW1, LW2, LW3, LW4, LW5, - $ LW6, LW7, LWAMAX, M1, M11, M2, MINWRK, MODE, - $ NP1, NP11, NP2 - DOUBLE PRECISION GAMABS, GAMAMN, GAMAMX, GTOLL, MINEAC, STEPG, - $ TOL2 -C .. -C .. External Functions .. - LOGICAL SELECT - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DGESVD, DLACPY, SB10LD, SB10PD, SB10QD, - $ SB10RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN, SQRT -C .. -C .. Executable Statements .. -C -C Decode and test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS - NP11 = NP1 - M2 - M11 = M1 - NP2 -C - INFO = 0 - IF ( JOB.LT.1 .OR. JOB.GT.4 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( NP.LT.0 ) THEN - INFO = -4 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -5 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -6 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -15 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -23 - ELSE IF( LDAC.LT.MAX( 1, 2*N ) ) THEN - INFO = -25 - ELSE IF( LDBC.LT.MAX( 1, 2*N ) ) THEN - INFO = -27 - ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN - INFO = -29 - ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN - INFO = -31 - ELSE -C -C Compute workspace. -C - LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 - LW2 = MAX( ( N + NP1 + 1 )*( N + M2 ) + - $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), - $ ( N + NP2 )*( N + M1 + 1 ) + - $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), - $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, - $ 5*M2 ), - $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, - $ 5*NP2 ) ) - LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ), - $ 6*MIN( NP11, M1 ) ), - $ NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ), - $ 6*MIN( NP1, M11 ) ) ) - LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP - LW5 = 2*N*N + M*N + N*NP - LW6 = MAX( M*M + MAX( 2*M1, 3*N*N + - $ MAX( N*M, 10*N*N + 12*N + 5 ) ), - $ NP*NP + MAX( 2*NP1, 3*N*N + - $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) - LW7 = M2*NP2 + NP2*NP2 + M2*M2 + - $ MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ), - $ M11*M11 + MAX( 2*M11, M11*M2 ), 3*N, - $ N*( 2*NP2 + M2 ) + - $ MAX( 2*N*M2, M2*NP2 + - $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + - $ M2 + MAX( NP2, N ) ) ) ) ) - MINWRK = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -38 - ELSE IF( LIWORK.LT.MAX( 2*MAX( N, M1, NP1, M2, NP2 ), - $ N*N ) ) THEN - INFO = -36 - ELSE IF( LBWORK.LT.2*N ) THEN - INFO = -40 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - MODE = JOB - IF ( MODE.GT.2 ) - $ MODE = 1 - GTOLL = GTOL - IF( GTOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for GAMMA. -C - GTOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage 1. -C - IWC = 1 + N*M - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) -C - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) -C - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the Hinf optimal controller. -C Workspace: need LW1 + MAX(1,LWP1,LWP2,LWP3,LWP4), -C prefer larger, -C where -C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 -C LWP1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), -C LWP2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), -C LWP3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), -C LWP4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), -C with M1 = M - M2 and NP1 = NP - NP2. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C LW1 + MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). -C - TOL2 = -ONE -C - CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), - $ M2, DWORK( IWTY ), NP2, RCOND, TOL2, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IF ( INFO2.NE.0 ) THEN - INFO = INFO2 - RETURN - END IF -C -C Workspace usage 2. -C - IWD1 = IWRK - IWS1 = IWD1 + NP11*M1 -C -C Check if GAMMA < max(sigma[D1111,D1112],sigma[D1111',D1121']). -C Workspace: need LW1 + MAX(1, LWS1, LWS2), -C prefer larger, -C where -C LWS1 = NP11*M1 + MAX(4*MIN(NP11,M1)+MAX(NP11,M1),6*MIN(NP11,M1)) -C LWS2 = NP1*M11 + MAX(4*MIN(NP1,M11)+MAX(NP1,M11),6*MIN(NP1,M11)) -C - INFO2 = 0 - INFO3 = 0 -C - IF ( NP11.NE.0 .AND. M1.NE.0 ) THEN - IWRK = IWS1 + MIN( NP11, M1 ) - CALL DLACPY( 'Full', NP11, M1, DWORK(IWD), LDD, DWORK(IWD1), - $ NP11 ) - CALL DGESVD( 'N', 'N', NP11, M1, DWORK(IWD1), NP11, - $ DWORK(IWS1), DWORK(IWS1), 1, DWORK(IWS1), 1, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) - ELSE - DWORK(IWS1) = ZERO - END IF -C - IWS2 = IWD1 + NP1*M11 - IF ( NP1.NE.0 .AND. M11.NE.0 ) THEN - IWRK = IWS2 + MIN( NP1, M11 ) - CALL DLACPY( 'Full', NP1, M11, DWORK(IWD), LDD, DWORK(IWD1), - $ NP1 ) - CALL DGESVD( 'N', 'N', NP1, M11, DWORK(IWD1), NP1, DWORK(IWS2), - $ DWORK(IWS2), 1, DWORK(IWS2), 1, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO3 ) - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) - ELSE - DWORK(IWS2) = ZERO - END IF -C - GAMAMN = MAX( DWORK(IWS1), DWORK(IWS2) ) -C - IF ( INFO2.GT.0 .OR. INFO3.GT.0 ) THEN - INFO = 10 - RETURN - ELSE IF ( GAMMA.LE.GAMAMN ) THEN - INFO = 6 - RETURN - END IF -C -C Workspace usage 3. -C - IWX = IWD1 - IWY = IWX + N*N - IWF = IWY + N*N - IWH = IWF + M*N - IWRK = IWH + N*NP - IWAC = IWD1 - IWWR = IWAC + 4*N*N - IWWI = IWWR + 2*N - IWRE = IWWI + 2*N -C -C Prepare some auxiliary variables for the gamma iteration. -C - STEPG = GAMMA - GAMAMN - GAMABS = GAMMA - GAMAMX = GAMMA - INF = 0 -C -C ############################################################### -C -C Begin the gamma iteration. -C - 10 CONTINUE - STEPG = STEPG/TWO -C -C Try to compute the state feedback and output injection -C matrices for the current GAMMA. -C - CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), - $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ BWORK, INFO2 ) -C - IF ( INFO2.NE.0 ) GOTO 30 -C -C Try to compute the Hinf suboptimal (yet) controller. -C - CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, - $ DWORK( IWTY ), NP2, DWORK( IWX ), N, DWORK( IWY ), - $ N, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) -C - IF ( INFO2.NE.0 ) GOTO 30 -C -C Compute the closed-loop system. -C Workspace: need LW1 + 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; -C prefer larger. -C - CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, - $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, - $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, - $ DWORK( IWD1 ), LDWORK-IWD1+1, INFO2 ) -C - IF ( INFO2.NE.0 ) GOTO 30 -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWD1 ) ) + IWD1 - 1 ) -C -C Compute the poles of the closed-loop system. -C Workspace: need LW1 + 4*N*N + 4*N + max(1,6*N); -C prefer larger. -C - CALL DLACPY( 'Full', 2*N, 2*N, AC, LDAC, DWORK(IWAC), 2*N ) -C - CALL DGEES( 'N', 'N', SELECT, 2*N, DWORK(IWAC), 2*N, IWORK, - $ DWORK(IWWR), DWORK(IWWI), DWORK(IWRE), 1, - $ DWORK(IWRE), LDWORK-IWRE+1, BWORK, INFO2 ) -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRE ) ) + IWRE - 1 ) -C -C Now DWORK(IWWR+I)=Re(Lambda), DWORK(IWWI+I)=Im(Lambda), -C for I=0,2*N-1. -C - MINEAC = -THOUS -C - DO 20 I = 0, 2*N - 1 - MINEAC = MAX( MINEAC, DWORK(IWWR+I) ) - 20 CONTINUE -C -C Check if the closed-loop system is stable. -C - 30 IF ( MODE.EQ.1 ) THEN - IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN - GAMABS = GAMMA - GAMMA = GAMMA - STEPG - INF = 1 - ELSE - GAMMA = MIN( GAMMA + STEPG, GAMAMX ) - END IF - ELSE IF ( MODE.EQ.2 ) THEN - IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN - GAMABS = GAMMA - INF = 1 - END IF - GAMMA = GAMMA - MAX( P1, GTOLL ) - END IF -C -C More iterations? -C - IF ( MODE.EQ.1 .AND. JOB.EQ.3 .AND. TWO*STEPG.LT.GTOLL ) THEN - MODE = 2 - GAMMA = GAMABS - END IF -C - IF ( JOB.NE.4 .AND. - $ ( MODE.EQ.1 .AND. TWO*STEPG.GE.GTOLL .OR. - $ MODE.EQ.2 .AND. GAMMA.GT.ZERO ) ) THEN - GOTO 10 - END IF -C -C ############################################################### -C -C End of the gamma iteration - Return if no stabilizing controller -C was found. -C - IF ( INF.EQ.0 ) THEN - INFO = 12 - RETURN - END IF -C -C Now compute the state feedback and output injection matrices -C using GAMABS. -C - GAMMA = GAMABS -C -C Integer workspace: need max(2*max(N,M-NCON,NP-NMEAS),N*N). -C Workspace: need LW1P + -C max(1,M*M + max(2*M1,3*N*N + -C max(N*M,10*N*N+12*N+5)), -C NP*NP + max(2*NP1,3*N*N + -C max(N*NP,10*N*N+12*N+5))); -C prefer larger, -C where LW1P = LW1 + 2*N*N + M*N + N*NP. -C An upper bound of the second term after LW1P is -C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). -C - CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), - $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ BWORK, INFO2 ) -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C - IF ( INFO2.GT.0 ) THEN - INFO = INFO2 + 5 - RETURN - END IF -C -C Compute the Hinf optimal controller. -C Integer workspace: need max(2*(max(NP,M)-M2-NP2,M2,N),NP2). -C Workspace: need LW1P + -C max(1, M2*NP2 + NP2*NP2 + M2*M2 + -C max(D1*D1 + max(2*D1, (D1+D2)*NP2), -C D2*D2 + max(2*D2, D2*M2), 3*N, -C N*(2*NP2 + M2) + -C max(2*N*M2, M2*NP2 + -C max(M2*M2+3*M2, NP2*(2*NP2+ -C M2+max(NP2,N)))))) -C where D1 = NP1 - M2 = NP11, D2 = M1 - NP2 = M11; -C prefer larger. -C An upper bound of the second term after LW1P is -C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). -C - CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C - IF( INFO2.EQ.1 ) THEN - INFO = 6 - RETURN - ELSE IF( INFO2.EQ.2 ) THEN - INFO = 9 - RETURN - END IF -C -C Integer workspace: need 2*max(NCON,NMEAS). -C Workspace: need 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; -C prefer larger. -C - CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, - $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, - $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, DWORK, - $ LDWORK, INFO2 ) -C - IF( INFO2.GT.0 ) THEN - INFO = 11 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10AD *** - END diff --git a/slycot/src/SB10DD.f b/slycot/src/SB10DD.f deleted file mode 100644 index b6a99f7b..00000000 --- a/slycot/src/SB10DD.f +++ /dev/null @@ -1,1007 +0,0 @@ - SUBROUTINE SB10DD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, - $ DK, LDDK, X, LDX, Z, LDZ, RCOND, TOL, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity (sub)optimal n-state -C controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C for the discrete-time system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for a given value of gamma, where B2 has as column size the -C number of control inputs (NCON) and C2 has as row size the number -C of measurements (NMEAS) being provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C j*Theta -C (A3) | A-e *I B2 | has full column rank for all -C | C1 D12 | -C -C 0 <= Theta < 2*Pi , -C -C j*Theta -C (A4) | A-e *I B1 | has full row rank for all -C | C2 D21 | -C -C 0 <= Theta < 2*Pi . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA > 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the matrix -C Z, solution of the Z-Riccati equation. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION array, dimension (8) -C RCOND contains estimates of the reciprocal condition -C numbers of the matrices which are to be inverted and -C estimates of the reciprocal condition numbers of the -C Riccati equations which have to be solved during the -C computation of the controller. (See the description of -C the algorithm in [2].) -C RCOND(1) contains the reciprocal condition number of the -C matrix R3; -C RCOND(2) contains the reciprocal condition number of the -C matrix R1 - R2'*inv(R3)*R2; -C RCOND(3) contains the reciprocal condition number of the -C matrix V21; -C RCOND(4) contains the reciprocal condition number of the -C matrix St3; -C RCOND(5) contains the reciprocal condition number of the -C matrix V12; -C RCOND(6) contains the reciprocal condition number of the -C matrix Im2 + DKHAT*D22 -C RCOND(7) contains the reciprocal condition number of the -C X-Riccati equation; -C RCOND(8) contains the reciprocal condition number of the -C Z-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used in neglecting the small singular values -C in rank determination. If TOL <= 0, then a default value -C equal to 1000*EPS is used, where EPS is the relative -C machine precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(LW1,LW2,LW3,LW4), where -C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)); -C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)); -C LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N + -C max(14*N+23,16*N,2*N+M,3*M); -C LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N + -C N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) + -C max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N + -C max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C j*Theta -C = 1: if the matrix | A-e *I B2 | had not full -C | C1 D12 | -C column rank; -C j*Theta -C = 2: if the matrix | A-e *I B1 | had not full -C | C2 D21 | -C row rank; -C = 3: if the matrix D12 had not full column rank; -C = 4: if the matrix D21 had not full row rank; -C = 5: if the controller is not admissible (too small value -C of gamma); -C = 6: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 7: if the Z-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 8: if the matrix Im2 + DKHAT*D22 is singular. -C = 9: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C -C METHOD -C -C The routine implements the method presented in [1]. -C -C REFERENCES -C -C [1] Green, M. and Limebeer, D.J.N. -C Linear Robust Control. -C Prentice-Hall, Englewood Cliffs, NJ, 1995. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C With approaching the minimum value of gamma some of the matrices -C which are to be inverted tend to become ill-conditioned and -C the X- or Z-Riccati equation may also become ill-conditioned -C which may deteriorate the accuracy of the result. (The -C corresponding reciprocal condition numbers are given in -C the output array RCOND.) -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, discrete-time H-infinity optimal -C control, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, THOUSN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, - $ THOUSN = 1.0D+3 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA, TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( * ), X( LDX, * ), Z( LDZ, * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG, - $ IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU, - $ IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2 - DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL -C -C .. External Functions - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY, - $ DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK, - $ DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU, - $ MB01RX, SB02OD, SB02SD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LE.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -20 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -22 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE -C -C Compute workspace. -C - IWB = ( N + NP1 + 1 )*( N + M2 ) + - $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ) - IWC = ( N + NP2 )*( N + M1 + 1 ) + - $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ) - IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) + - $ 6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M ) - IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) + - $ 6*N + N*( M + NP2 ) + - $ MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) ) - MINWRK = MAX( IWB, IWC, IWD, IWG ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -31 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10DD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - RCOND( 5 ) = ONE - RCOND( 6 ) = ONE - RCOND( 7 ) = ONE - RCOND( 8 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance in rank determination. -C - TOLL = THOUSN*DLAMCH( 'Epsilon' ) - END IF -C -C Workspace usage. -C - IWS = (N+NP1)*(N+M2) + 1 - IWRK = IWS + (N+M2) -C -C jTheta -C Determine if |A-e I B2 | has full column rank at -C | C1 D12| -C Theta = Pi/2 . -C Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)); -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 ) - CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 ) - CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, - $ DWORK( (N+NP1)*N+1 ), N+NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( (N+NP1)*N+N+1 ), N+NP1 ) - CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ), - $ DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Workspace usage. -C - IWS = (N+NP2)*(N+M1) + 1 - IWRK = IWS + (N+NP2) -C -C jTheta -C Determine if |A-e I B1 | has full row rank at -C | C2 D21| -C Theta = Pi/2 . -C Workspace: need (N+NP2)*(N+M1+1) + -C MAX(3*(N+NP2)+N+M1,5*(N+NP2)); -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 ) - CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ), - $ N+NP2 ) - CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ), - $ N+NP2 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( (N+NP2)*N+N+1 ), N+NP2 ) - CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ), - $ DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWS = NP1*M2 + 1 - IWRK = IWS + M2 -C -C Determine if D12 has full column rank. -C Workspace: need (NP1+1)*M2 + MAX(3*M2+NP1,5*M2); -C prefer larger. -C - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 ) - CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK, - $ NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWS = NP2*M1 + 1 - IWRK = IWS + NP2 -C -C Determine if D21 has full row rank. -C Workspace: need NP2*(M1+1) + MAX(3*NP2+M1,5*NP2); -C prefer larger. -C - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 ) - CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK, - $ NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 9 - RETURN - END IF - IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN - INFO = 4 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWV = 1 - IWB = IWV + M*M - IWC = IWB + N*M1 - IWD = IWC + ( M2 + NP2 )*N - IWQ = IWD + ( M2 + NP2 )*M1 - IWL = IWQ + N*N - IWR = IWL + N*M - IWI = IWR + 2*N - IWH = IWI + 2*N - IWS = IWH + 2*N - IWT = IWS + ( 2*N + M )*( 2*N + M ) - IWU = IWT + ( 2*N + M )*2*N - IWRK = IWU + 4*N*N - IR2 = IWV + M1 - IR3 = IR2 + M*M1 -C -C Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| . -C |D12'| | 0 0| -C - CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO, - $ DWORK, M ) - DO 10 J = 1, M*M1, M + 1 - DWORK( J ) = DWORK( J ) - GAMMA*GAMMA - 10 CONTINUE -C -C Compute C1'*C1 . -C - CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO, - $ DWORK( IWQ ), N ) -C -C Compute C1'*|D11 D12| . -C - CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC, - $ D, LDD, ZERO, DWORK( IWL ), N ) -C -C Solution of the X-Riccati equation. -C Workspace: need 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + -C 6*N + max(14*N+23,16*N,2*N+M,3*M); -C prefer larger. -C - CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B, - $ LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N, - $ RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ), - $ DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ), - $ 2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 6 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Condition estimation. -C Workspace: need 4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) + -C max(5*N,max(3,2*N*N)+N*N); -C prefer larger. -C - IWS = IWR - IWH = IWS + M*M - IWT = IWH + N*M - IWU = IWT + N*N - IWG = IWU + N*N - IWRK = IWG + N*N - CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M ) - CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M ) - CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ), - $ M, INFO2 ) - CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE, - $ DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 ) - CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N, - $ DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X, - $ LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWRK = IWR -C -C Compute the lower triangle of |R1 R2'| = R0 + B'*X*B . -C |R2 R3 | -C - CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M, - $ B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 ) -C -C Compute the Cholesky factorization of R3, R3 = V12'*V12 . -C Note that V12' is stored. -C - ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) ) - CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 1 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C - CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M, - $ RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 5 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -C Compute R2 <- inv(V12')*R2 . -C - CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1, - $ ONE, DWORK( IR3 ), M, DWORK( IR2 ), M ) -C -C Compute -Nabla = R2'*inv(R3)*R2 - R1 . -C - CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M, - $ -ONE, DWORK, M ) -C -C Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t. -C Note that V21t' is stored. -C - ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) ) - CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 2 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C - CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 3 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -C Compute X*A . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX, - $ A, LDA, ZERO, DWORK( IWQ ), N ) -C -C Compute |L1| = |D11'|*C1 + B'*X*A . -C |L2| = |D12'| -C - CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M ) - CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M ) - CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB, - $ DWORK( IWQ ), N, ONE, DWORK( IWL ), M ) -C -C Compute L2 <- inv(V12')*L2 . -C - CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE, - $ DWORK( IR3 ), M, DWORK( IWL+M1 ), M ) -C -C Compute L_Nabla = L1 - R2'*inv(R3)*L2 . -C - CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE, - $ DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE, - $ DWORK( IWL ), M ) -C -C Compute L_Nabla <- inv(V21t')*L_Nabla . -C - CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE, - $ DWORK, M, DWORK( IWL ), M ) -C -C Compute Bt1 = B1*inv(V21t) . -C - CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE, - $ DWORK, M, DWORK( IWB ), N ) -C -C Compute At . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE, - $ DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK ) -C -C Scale Bt1 . -C - CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 ) -C -C Compute |Dt11| = |R2 |*inv(V21t) . -C |Dt21| |D21| -C - CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ), - $ M2+NP2 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ), - $ M2+NP2 ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2, - $ M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 ) -C -C Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla . -C |Ct2| = |C2| + |Dt21| -C - CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ), - $ M2+NP2 ) - CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ), - $ M2+NP2 ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE, - $ DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE, - $ DWORK( IWC ), M2+NP2 ) -C -C Scale |Dt11| . -C |Dt21| -C - CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 ) -C -C Workspace usage. -C - IWW = IWD + ( M2 + NP2 )*M1 - IWQ = IWW + ( M2 + NP2 )*( M2 + NP2 ) - IWL = IWQ + N*N - IWR = IWL + N*( M2 + NP2 ) - IWI = IWR + 2*N - IWH = IWI + 2*N - IWS = IWH + 2*N - IWT = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 ) - IWU = IWT + ( 2*N + M2 + NP2 )*2*N - IWG = IWU + 4*N*N - IWRK = IWG + ( M2 + NP2 )*N - IS2 = IWW + ( M2 + NP2 )*M2 - IS3 = IS2 + M2 -C -C Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| . -C |Dt21| | 0 0| -C - CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ), - $ M2+NP2, ZERO, DWORK( IWW ), M2+NP2 ) - DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1 - DWORK( J ) = DWORK( J ) - GAMMA*GAMMA - 20 CONTINUE -C -C Compute Bt1*Bt1' . -C - CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N, - $ ZERO, DWORK( IWQ ), N ) -C -C Compute Bt1*|Dt11' Dt21'| . -C - CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE, - $ DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO, - $ DWORK( IWL ), N ) -C -C Transpose At in situ (in AK) . -C - DO 30 J = 2, N - CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) - 30 CONTINUE -C -C Transpose Ct . -C - CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, - $ DWORK( IWG ), N ) -C -C Solution of the Z-Riccati equation. -C Workspace: need 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + -C N*(M+NP2) + 6*N + -C max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); -C prefer larger. -C - CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK, - $ LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ), - $ M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR), - $ DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2, - $ DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL, - $ IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 7 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Condition estimation. -C Workspace: need 4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+ -C N*(M+2*M2+3*NP2) + (M2+NP2)*M1 + -C max(5*N,max(3,2*N*N)+N*N); -C prefer larger. -C - IWS = IWR - IWH = IWS + ( M2 + NP2 )*( M2 + NP2 ) - IWT = IWH + N*( M2 + NP2 ) - IWU = IWT + N*N - IWG = IWU + N*N - IWRK = IWG + N*N - CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2, - $ DWORK( IWS ), M2+NP2 ) - CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, - $ DWORK( IWH ), M2+NP2 ) - CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK, - $ DWORK( IWH ), M2+NP2, INFO2 ) - CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE, - $ DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ), - $ M2+NP2, INFO2 ) - CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ), - $ N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IWRK = IWR -C -C Compute the upper triangle of -C |St1 St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| . -C |St2' St3| |Ct2| -C - CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE, - $ DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ, - $ DWORK( IWRK ), (M2+NP2)*N, INFO2 ) -C -C Compute the Cholesky factorization of St3, St3 = U12'*U12 . -C - ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2, - $ DWORK( IWRK ) ) - CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM, - $ RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 4 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -C Compute St2 <- St2*inv(U12) . -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) -C -C Check the negative definiteness of St1 - St2*inv(St3)*St2' . -C - CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ), - $ M2+NP2, -ONE, DWORK( IWW ), M2+NP2 ) - CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 5 - RETURN - END IF -C -C Restore At in situ . -C - DO 40 J = 2, N - CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) - 40 CONTINUE -C -C Compute At*Z . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK, - $ Z, LDZ, ZERO, DWORK( IWRK ), N ) -C -C Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK . -C - CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK ) - CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE, - $ DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE, - $ BK, LDBK ) -C -C Compute St2 <- St2*inv(U12') . -C - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) -C -C Compute DKHAT = -inv(V12)*St2 in DK . -C - CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2, - $ -ONE, DWORK( IR3 ), M, DK, LDDK ) -C -C Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK . -C - CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE, - $ DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE, - $ CK, LDCK ) - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE, - $ DWORK( IR3 ), M, CK, LDCK ) -C -C Compute Mt2*inv(St3) in BK . -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) - CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2, - $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) -C -C Compute AKHAT in AK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE, - $ B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK, - $ LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK ) -C -C Compute BKHAT in BK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE, - $ B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK ) -C -C Compute Im2 + DKHAT*D22 . -C - IWRK = M2*M2 + 1 - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK, - $ LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 8 - RETURN - END IF - CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ), - $ IWORK( M2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 6 ).LT.TOLL ) THEN - INFO = 8 - RETURN - END IF -C -C Compute CK . -C - CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK, - $ INFO2 ) -C -C Compute DK . -C - CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK, - $ INFO2 ) -C -C Compute AK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK, - $ LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK, - $ N, CK, LDCK, ONE, AK, LDAK ) -C -C Compute BK . -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK, - $ N, DK, LDDK, ONE, BK, LDBK ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10DD *** - END diff --git a/slycot/src/SB10ED.f b/slycot/src/SB10ED.f deleted file mode 100644 index 51f7f048..00000000 --- a/slycot/src/SB10ED.f +++ /dev/null @@ -1,468 +0,0 @@ - SUBROUTINE SB10ED( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal n-state controller -C -C | AK | BK | -C K = |----|----| -C | CK | DK | -C -C for the discrete-time system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| , -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C j*Theta -C (A3) | A-e *I B2 | has full column rank for all -C | C1 D12 | -C -C 0 <= Theta < 2*Pi , -C -C -C j*Theta -C (A4) | A-e *I B1 | has full row rank for all -C | C2 D21 | -C -C 0 <= Theta < 2*Pi . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input/worksp.) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C This array is modified internally, but it is restored on -C exit. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION array, dimension (7) -C RCOND contains estimates the reciprocal condition -C numbers of the matrices which are to be inverted and the -C reciprocal condition numbers of the Riccati equations -C which have to be solved during the computation of the -C controller. (See the description of the algorithm in [2].) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix TU; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix TY; -C RCOND(3) contains the reciprocal condition number of the -C matrix Im2 + B2'*X2*B2; -C RCOND(4) contains the reciprocal condition number of the -C matrix Ip2 + C2*Y2*C2'; -C RCOND(5) contains the reciprocal condition number of the -C X-Riccati equation; -C RCOND(6) contains the reciprocal condition number of the -C Y-Riccati equation; -C RCOND(7) contains the reciprocal condition number of the -C matrix Im2 + DKHAT*D22 . -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the -C transformations applied for diagonalizing D12 and D21, -C and for checking the nonsingularity of the matrices to be -C inverted. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*M2,2*N,N*N,NP2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + -C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where -C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), -C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), -C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), -C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), -C LW5 = 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N),M2*(N+M2+ -C max(3,M1)),NP2*(N+NP2+3)), -C LW6 = max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2), -C with M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), -C 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N), -C Q*(N+Q+max(Q,3)))). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C j*Theta -C = 1: if the matrix | A-e *I B2 | had not full -C | C1 D12 | -C column rank in respect to the tolerance EPS; -C j*Theta -C = 2: if the matrix | A-e *I B1 | had not full -C | C2 D21 | -C row rank in respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A-I B2 |, |A-I B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C = 6: if the X-Riccati equation was not solved -C successfully; -C = 7: if the matrix Im2 + B2'*X2*B2 is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL); -C = 8: if the Y-Riccati equation was not solved -C successfully; -C = 9: if the matrix Ip2 + C2*Y2*C2' is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL); -C =10: if the matrix Im2 + DKHAT*D22 is singular, or its -C estimated condition number is larger than or equal -C to 1/TOL. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C matrices which are to be inverted and on the condition numbers of -C the matrix Riccati equations which are to be solved in the -C computation of the controller. (The corresponding reciprocal -C condition numbers are given in the output array RCOND.) -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Feb. 2000, Nov. 2005. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, optimal regulator, -C robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER I, INFO2, IWC, IWD, IWRK, IWTU, IWTY, IWX, IWY, - $ LW1, LW2, LW3, LW4, LW5, LW6, LWAMAX, M1, M2, - $ M2L, MINWRK, NL, NLP, NP1, NP2, NPL - DOUBLE PRECISION TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DLACPY, SB10PD, SB10SD, SB10TD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS - NL = MAX( 1, N ) - NPL = MAX( 1, NP ) - M2L = MAX( 1, M2 ) - NLP = MAX( 1, NP2 ) -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDA.LT.NL ) THEN - INFO = -7 - ELSE IF( LDB.LT.NL ) THEN - INFO = -9 - ELSE IF( LDC.LT.NPL ) THEN - INFO = -11 - ELSE IF( LDD.LT.NPL ) THEN - INFO = -13 - ELSE IF( LDAK.LT.NL ) THEN - INFO = -15 - ELSE IF( LDBK.LT.NL ) THEN - INFO = -17 - ELSE IF( LDCK.LT.M2L ) THEN - INFO = -19 - ELSE IF( LDDK.LT.M2L ) THEN - INFO = -21 - ELSE -C -C Compute workspace. -C - LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, - $ 5*( N + M2 ) ) - LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + - $ M1, 5*( N + NP2 ) ) - LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) - LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) - LW5 = 2*N*N + MAX( 1, 14*N*N + - $ 6*N + MAX( 14*N + 23, 16*N ), - $ M2*( N + M2 + MAX( 3, M1 ) ), - $ NP2*( N + NP2 + 3 ) ) - LW6 = MAX( N*M2, N*NP2, M2*NP2, M2*M2 + 4*M2 ) - MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + - $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -26 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .AND. MAX( M2, NP2 ).EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - RCOND( 5 ) = ONE - RCOND( 6 ) = ONE - RCOND( 7 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for rank tests. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWC = N*M + 1 - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NL ) - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NPL ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NPL ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the H2 optimal controller. -C Since SLICOT Library routine SB10PD performs the tests -C corresponding to the continuous-time counterparts of the -C assumptions (A3) and (A4), for the frequency w = 0, the -C next SB10PD routine call uses A - I. -C - DO 10 I = 1, N - A(I,I) = A(I,I) - ONE - 10 CONTINUE -C - CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, - $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, DWORK( IWTU ), - $ M2L, DWORK( IWTY ), NLP, RCOND, TOLL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - DO 20 I = 1, N - A(I,I) = A(I,I) + ONE - 20 CONTINUE -C - IF( INFO2.GT.0 ) THEN - INFO = INFO2 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IWX = IWRK - IWY = IWX + N*N - IWRK = IWY + N*N -C -C Compute the optimal H2 controller for the normalized system. -C - CALL SB10SD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, - $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, DWORK( IWX ), NL, - $ DWORK( IWY ), NL, RCOND( 3 ), TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 + 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - IWRK = IWX -C -C Compute the H2 optimal controller for the original system. -C - CALL SB10TD( N, M, NP, NCON, NMEAS, DWORK( IWD ), NPL, - $ DWORK( IWTU ), M2L, DWORK( IWTY ), NLP, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, RCOND( 7 ), TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 10 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10ED *** - END diff --git a/slycot/src/SB10FD.f b/slycot/src/SB10FD.f deleted file mode 100644 index 61fcdd4f..00000000 --- a/slycot/src/SB10FD.f +++ /dev/null @@ -1,469 +0,0 @@ - SUBROUTINE SB10FD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, - $ DK, LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, - $ BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity (sub)optimal n-state -C controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C using modified Glover's and Doyle's 1988 formulas, for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for a given value of gamma, where B2 has as column size the -C number of control inputs (NCON) and C2 has as row size the number -C of measurements (NMEAS) being provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank and D21 is full row rank, -C -C (A3) | A-j*omega*I B2 | has full column rank for all omega, -C | C1 D12 | -C -C (A4) | A-j*omega*I B1 | has full row rank for all omega. -C | C2 D21 | -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations for computing the normalized form in -C SLICOT Library routine SB10PD. Transformation matrices -C whose reciprocal condition numbers are less than TOL are -C not allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + -C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where -C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), -C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), -C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), -C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), -C LW5 = 2*N*N + N*(M+NP) + -C max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), -C NP*NP + max(2*NP1,3*N*N + -C max(N*NP,10*N*N+12*N+5))), -C LW6 = 2*N*N + N*(M+NP) + -C max(1, M2*NP2 + NP2*NP2 + M2*M2 + -C max(D1*D1 + max(2*D1, (D1+D2)*NP2), -C D2*D2 + max(2*D2, D2*M2), 3*N, -C N*(2*NP2 + M2) + -C max(2*N*M2, M2*NP2 + -C max(M2*M2+3*M2, NP2*(2*NP2+ -C M2+max(NP2,N)))))), -C with D1 = NP1 - M2, D2 = M1 - NP2, -C NP1 = NP - NP2, M1 = M - M2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), -C 2*N*(N+2*Q)+max(1,4*Q*Q+ -C max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), -C Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix | A-j*omega*I B2 | had not full -C | C1 D12 | -C column rank in respect to the tolerance EPS; -C = 2: if the matrix | A-j*omega*I B1 | had not full row -C | C2 D21 | -C rank in respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C = 6: if the controller is not admissible (too small value -C of gamma); -C = 7: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 8: if the Y-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is -C zero [3]. -C -C METHOD -C -C The routine implements the Glover's and Doyle's 1988 formulas [1], -C [2] modified to improve the efficiency as described in [3]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of continuous-time -C linear control systems. -C Rep. 98-14, Department of Engineering, Leicester University, -C Leicester, U.K., 1998. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and on the condition numbers of -C the two Riccati equations, as given by the values of RCOND(1), -C RCOND(2), RCOND(3) and RCOND(4), respectively. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA, TOL -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, - $ IWX, IWY, LW1, LW2, LW3, LW4, LW5, LW6, - $ LWAMAX, M1, M2, MINWRK, ND1, ND2, NP1, NP2 - DOUBLE PRECISION TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DLACPY, SB10PD, SB10QD, SB10RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -20 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -22 - ELSE -C -C Compute workspace. -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, - $ 5*( N + M2 ) ) - LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + - $ M1, 5*( N + NP2 ) ) - LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) - LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) - LW5 = 2*N*N + N*( M + NP ) + - $ MAX( 1, M*M + MAX( 2*M1, 3*N*N + - $ MAX( N*M, 10*N*N + 12*N + 5 ) ), - $ NP*NP + MAX( 2*NP1, 3*N*N + - $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) - LW6 = 2*N*N + N*( M + NP ) + - $ MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + - $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), - $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, - $ N*( 2*NP2 + M2 ) + - $ MAX( 2*N*M2, M2*NP2 + - $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + - $ M2 + MAX( NP2, N ) ) ) ) ) ) - MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + - $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -27 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10FD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWC = 1 + N*M - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the Hinf (sub)optimal controller. -C - CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), - $ M2, DWORK( IWTY ), NP2, RCOND, TOLL, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IWX = IWRK - IWY = IWX + N*N - IWF = IWY + N*N - IWH = IWF + M*N - IWRK = IWH + N*NP -C -C Compute the (sub)optimal state feedback and output injection -C matrices. -C - CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), - $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 + 5 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute the Hinf (sub)optimal controller. -C - CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), - $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, - $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.EQ.1 ) THEN - INFO = 6 - RETURN - ELSE IF( INFO2.EQ.2 ) THEN - INFO = 9 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10FD *** - END diff --git a/slycot/src/SB10HD.f b/slycot/src/SB10HD.f deleted file mode 100644 index 5e350a98..00000000 --- a/slycot/src/SB10HD.f +++ /dev/null @@ -1,390 +0,0 @@ - SUBROUTINE SB10HD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal n-state controller -C -C | AK | BK | -C K = |----|----| -C | CK | DK | -C -C for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| , -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -c -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) The block D11 of D is zero, -C -C (A3) D12 is full column rank and D21 is full row rank. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations for computing the normalized form in -C SLICOT Library routine SB10UD. Transformation matrices -C whose reciprocal condition numbers are less than TOL are -C not allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*N,N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + -C max(max(M2 + NP1*NP1 + -C max(NP1*N,3*M2+NP1,5*M2), -C NP2 + M1*M1 + -C max(M1*N,3*NP2+M1,5*NP2), -C N*M2,NP2*N,NP2*M2,1), -C N*(14*N+12+M2+NP2)+5), -C where M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C 2*Q*(3*Q+2*N)+max(1,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 2: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 3: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices D12 or D21). -C = 4: if the X-Riccati equation was not solved -C successfully; -C = 5: if the Y-Riccati equation was not solved -C successfully. -C -C METHOD -C -C The routine implements the formulas given in [1], [2]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and on the condition numbers of -C the two Riccati equations, as given by the values of RCOND(1), -C RCOND(2), RCOND(3) and RCOND(4), respectively. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, Oct. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Jan. 2000, Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, optimal regulator, -C robust control. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, - $ IWY, LWAMAX, M1, M2, MINWRK, NP1, NP2 - DOUBLE PRECISION TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DLACPY, SB10UD, SB10VD, SB10WD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE -C -C Compute workspace. -C - MINWRK = N*M + NP*(N+M) + M2*M2 + NP2*NP2 + - $ MAX( MAX( M2 + NP1*NP1 + - $ MAX( NP1*N, 3*M2 + NP1, 5*M2 ), - $ NP2 + M1*M1 + - $ MAX( M1*N, 3*NP2 + M1, 5*NP2 ), - $ N*M2, NP2*N, NP2*M2, 1 ), - $ N*( 14*N + 12 + M2 + NP2 ) + 5 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -26 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10HD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for rank tests. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWC = N*M + 1 - IWD = IWC + NP*N - IWTU = IWD + NP*M - IWTY = IWTU + M2*M2 - IWRK = IWTY + NP2*NP2 -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) - CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) -C -C Transform the system so that D12 and D21 satisfy the formulas -C in the computation of the H2 optimal controller. -C - CALL SB10UD( N, M, NP, NCON, NMEAS, DWORK, N, DWORK( IWC ), NP, - $ DWORK( IWD ), NP, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, RCOND, TOLL, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C - IWY = IWRK - IWF = IWY + N*N - IWH = IWF + M2*N - IWRK = IWH + N*NP2 -C -C Compute the optimal state feedback and output injection matrices. -C AK is used to store X. -C - CALL SB10VD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWF ), M2, DWORK( IWH ), N, - $ AK, LDAK, DWORK( IWY ), N, RCOND( 3 ), IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = INFO2 + 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute the H2 optimal controller. -C - CALL SB10WD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, - $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), M2, - $ DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), - $ NP2, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO2 ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10HD *** - END diff --git a/slycot/src/SB10ID.f b/slycot/src/SB10ID.f deleted file mode 100644 index 2ea302e9..00000000 --- a/slycot/src/SB10ID.f +++ /dev/null @@ -1,584 +0,0 @@ - SUBROUTINE SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, - $ FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK, - $ DK, LDDK, RCOND, IWORK, DWORK, LDWORK, BWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the positive feedback controller -C -C | Ak | Bk | -C K = |----|----| -C | Ck | Dk | -C -C for the shaped plant -C -C | A | B | -C G = |---|---| -C | C | D | -C -C in the McFarlane/Glover Loop Shaping Design Procedure. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the plant. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A of the shaped plant. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B of the shaped plant. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C of the shaped plant. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system matrix D of the shaped plant. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C FACTOR (input) DOUBLE PRECISION -C = 1 implies that an optimal controller is required; -C > 1 implies that a suboptimal controller is required, -C achieving a performance FACTOR less than optimal. -C FACTOR >= 1. -C -C NK (output) INTEGER -C The order of the positive feedback controller. NK <= N. -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading NK-by-NK part of this array contains the -C controller state matrix Ak. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) -C The leading NK-by-NP part of this array contains the -C controller input matrix Bk. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading M-by-NK part of this array contains the -C controller output matrix Ck. -C -C LDCK INTEGER -C The leading dimension of the array CK. LDCK >= max(1,M). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) -C The leading M-by-NP part of this array contains the -C controller matrix Dk. -C -C LDDK INTEGER -C The leading dimension of the array DK. LDDK >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION array, dimension (2) -C RCOND(1) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C RCOND(2) contains an estimate of the reciprocal condition -C number of the Z-Riccati equation. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*N,N*N,M,NP) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + -C max( 6*N*N + 5 + max(1,4*N*N+8*N), N*NP + 2*N ). -C For good performance, LDWORK must generally be larger. -C An upper bound of LDWORK in the above formula is -C LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N + -C 5 + max(1,4*N*N+8*N). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the X-Riccati equation is not solved successfully; -C = 2: the Z-Riccati equation is not solved successfully; -C = 3: the iteration to compute eigenvalues or singular -C values failed to converge; -C = 4: the matrix Ip - D*Dk is singular; -C = 5: the matrix Im - Dk*D is singular; -C = 6: the closed-loop system is unstable. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] McFarlane, D. and Glover, K. -C A loop shaping design procedure using H_infinity synthesis. -C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, -C 1992. -C -C NUMERICAL ASPECTS -C -C The accuracy of the results depends on the conditioning of the -C two Riccati equations solved in the controller design (see the -C output parameter RCOND). -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Feb. 2001. -C -C KEYWORDS -C -C H_infinity control, Loop-shaping design, Robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NK, NP - DOUBLE PRECISION FACTOR -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - LOGICAL BWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 2 ) -C .. -C .. Local Scalars .. - CHARACTER*1 HINV - INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, - $ I11, I12, I13, INFO2, IWRK, J, LWA, LWAMAX, - $ MINWRK, N2, NS, SDIM - DOUBLE PRECISION SEP, FERR, GAMMA -C .. -C .. External Functions .. - LOGICAL SELECT - EXTERNAL SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DPOTRF, DPOTRS, - $ DSYRK, DTRSM, MB02VD, SB02RD, SB10JD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( FACTOR.LT.ONE ) THEN - INFO = -12 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN - INFO = -21 - END IF -C -C Compute workspace. -C - MINWRK = 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + - $ MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*NP + 2*N ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -25 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10ID', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C -C Workspace usage. -C - I1 = N*N - I2 = I1 + N*N - I3 = I2 + M*N - I4 = I3 + M*N - I5 = I4 + M*M - I6 = I5 + NP*NP - I7 = I6 + NP*N - I8 = I7 + N*N - I9 = I8 + N*N - I10 = I9 + N*N - I11 = I10 + N*N - I12 = I11 + 2*N - I13 = I12 + 2*N -C - IWRK = I13 + 4*N*N -C -C Compute D'*C . -C - CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, - $ DWORK( I2+1 ), M ) -C -C Compute S = Im + D'*D . -C - CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I4+1 ), M ) - CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I4+1 ), M ) -C -C Factorize S, S = T'*T, with T upper triangular. -C - CALL DPOTRF( 'U', M, DWORK( I4+1 ), M, INFO2 ) -C -C -1 -C Compute S D'*C . -C - CALL DPOTRS( 'U', M, N, DWORK( I4+1 ), M, DWORK( I2+1 ), M, - $ INFO2 ) -C -C -1 -C Compute B*T . -C - CALL DLACPY( 'F', N, M, B, LDB, DWORK( I3+1 ), N ) - CALL DTRSM( 'R', 'U', 'N', 'N', N, M, ONE, DWORK( I4+1 ), M, - $ DWORK( I3+1 ), N ) -C -C Compute R = Ip + D*D' . -C - CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I5+1 ), NP ) - CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I5+1 ), NP ) -C -C Factorize R, R = U'*U, with U upper triangular. -C - CALL DPOTRF( 'U', NP, DWORK( I5+1 ), NP, INFO2 ) -C -C -T -C Compute U C . -C - CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I6+1 ), NP ) - CALL DTRSM( 'L', 'U', 'T', 'N', NP, N, ONE, DWORK( I5+1 ), NP, - $ DWORK( I6+1 ), NP ) -C -C -1 -C Compute Ar = A - B*S D'*C . -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N ) - CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK( I2+1 ), M, - $ ONE, DWORK( I7+1 ), N ) -C -C -1 -C Compute the upper triangle of Cr = C'*R *C . -C - CALL DSYRK( 'U', 'T', N, NP, ONE, DWORK( I6+1 ), NP, ZERO, - $ DWORK( I8+1 ), N ) -C -C -1 -C Compute the upper triangle of Dr = B*S B' . -C - CALL DSYRK( 'U', 'N', N, M, ONE, DWORK( I3+1 ), N, ZERO, - $ DWORK( I9+1 ), N ) -C -C Solution of the Riccati equation Ar'*X + X*Ar + Cr - X*Dr*X = 0 . -C Workspace: need 10*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + -C 5 + max(1,4*N*N+8*N). -C prefer larger. -C AK is used as workspace. -C - N2 = 2*N - CALL SB02RD( 'A', 'C', HINV, 'N', 'U', 'G', 'S', 'N', 'O', N, - $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, - $ DWORK( I9+1 ), N, DWORK( I8+1 ), N, DWORK, N, SEP, - $ RCOND( 1 ), FERR, DWORK( I11+1 ), DWORK( I12+1 ), - $ DWORK( I13+1 ), N2, IWORK, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( MINWRK, LWA ) -C -C Solution of the Riccati equation Ar*Z + Z*Ar' + Dr - Z*Cr*Z = 0 . -C - CALL SB02RD( 'A', 'C', HINV, 'T', 'U', 'G', 'S', 'N', 'O', N, - $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, - $ DWORK( I8+1 ), N, DWORK( I9+1 ), N, DWORK( I1+1 ), - $ N, SEP, RCOND( 2 ), FERR, DWORK( I11+1 ), - $ DWORK( I12+1 ), DWORK( I13+1 ), N2, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C -1 -1 -C Compute F1 = -( S D'*C + S B'*X ) . -C - CALL DTRSM( 'R', 'U', 'T', 'N', N, M, ONE, DWORK( I4+1 ), M, - $ DWORK( I3+1 ), N ) - CALL DGEMM( 'T', 'N', M, N, N, -ONE, DWORK( I3+1 ), N, DWORK, N, - $ -ONE, DWORK( I2+1 ), M ) -C -C Compute gamma . -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK, N, DWORK( I1+1 ), N, - $ ZERO, DWORK( I7+1 ), N ) - CALL DGEES( 'N', 'N', SELECT, N, DWORK( I7+1 ), N, SDIM, - $ DWORK( I11+1 ), DWORK( I12+1 ), DWORK( IWRK+1 ), N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) - GAMMA = ZERO - DO 10 I = 1, N - GAMMA = MAX( GAMMA, DWORK( I11+I ) ) - 10 CONTINUE - GAMMA = FACTOR*SQRT( ONE + GAMMA ) -C -C Workspace usage. -C Workspace: need 4*N*N + M*N + N*NP. -C - I4 = I3 + N*N - I5 = I4 + N*N -C -C Compute Ac = A + B*F1 . -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I4+1 ), N ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( I2+1 ), M, - $ ONE, DWORK( I4+1 ), N ) -C -C Compute W1' = (1-gamma^2)*In + Z*X . -C - CALL DLASET( 'F', N, N, ZERO, ONE-GAMMA*GAMMA, DWORK( I3+1 ), N ) - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, - $ ONE, DWORK( I3+1 ), N ) -C -C Compute Bcp = gamma^2*Z*C' . -C - CALL DGEMM( 'N', 'T', N, NP, N, GAMMA*GAMMA, DWORK( I1+1 ), N, C, - $ LDC, ZERO, BK, LDBK ) -C -C Compute C + D*F1 . -C - CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I5+1 ), NP ) - CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, DWORK( I2+1 ), M, - $ ONE, DWORK( I5+1 ), NP ) -C -C Compute Acp = W1'*Ac + gamma^2*Z*C'*(C+D*F1) . -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I3+1 ), N, - $ DWORK( I4+1 ), N, ZERO, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, BK, LDBK, - $ DWORK( I5+1 ), NP, ONE, AK, LDAK ) -C -C Compute Ccp = B'*X . -C - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK, N, ZERO, - $ CK, LDCK ) -C -C Set Dcp = -D' . -C - DO 30 I = 1, M - DO 20 J = 1, NP - DK( I, J ) = -D( J, I ) - 20 CONTINUE - 30 CONTINUE -C - IWRK = I4 -C -C Reduce the generalized state-space description to a regular one. -C Workspace: need 3*N*N + M*N. -C Additional workspace: need 2*N*N + 2*N + N*MAX(5,N+M+NP). -C prefer larger. -C - CALL SB10JD( N, NP, M, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ DWORK( I3+1 ), N, NK, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Workspace usage. -C Workspace: need 4*N*N + M*M + NP*NP + 2*M*N + 2*N*NP. -C (NK <= N.) -C - I2 = NP*NP - I3 = I2 + NK*NP - I4 = I3 + M*M - I5 = I4 + N*M - I6 = I5 + NP*NK - I7 = I6 + M*N -C - IWRK = I7 + ( N + NK )*( N + NK ) -C -C Compute Ip - D*Dk . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) - CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, - $ DWORK, NP ) -C -C -1 -C Compute Bk*(Ip-D*Dk) . -C - CALL DLACPY( 'F', NK, NP, BK, LDBK, DWORK( I2+1 ), NK ) - CALL MB02VD( 'N', NK, NP, DWORK, NP, IWORK, DWORK( I2+1 ), NK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF -C -C Compute Im - Dk*D . -C - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3+1 ), M ) - CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, - $ DWORK( I3+1 ), M ) -C -C -1 -C Compute B*(Im-Dk*D) . -C - CALL DLACPY( 'F', N, M, B, LDB, DWORK( I4+1 ), N ) - CALL MB02VD( 'N', N, M, DWORK( I3+1 ), M, IWORK, DWORK( I4+1 ), N, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF -C -C Compute D*Ck . -C - CALL DGEMM( 'N', 'N', NP, NK, M, ONE, D, LDD, CK, LDCK, ZERO, - $ DWORK( I5+1 ), NP ) -C -C Compute Dk*C . -C - CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, - $ DWORK( I6+1 ), M ) -C -C Compute the closed-loop state matrix. -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N+NK ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4+1 ), N, - $ DWORK( I6+1 ), M, ONE, DWORK( I7+1 ), N+NK ) - CALL DGEMM( 'N', 'N', NK, N, NP, ONE, DWORK( I2+1 ), NK, C, LDC, - $ ZERO, DWORK( I7+N+1 ), N+NK ) - CALL DGEMM( 'N', 'N', N, NK, M, ONE, DWORK( I4+1 ), N, CK, LDCK, - $ ZERO, DWORK( I7+(N+NK)*N+1 ), N+NK ) - CALL DLACPY( 'F', NK, NK, AK, LDAK, DWORK( I7+(N+NK)*N+N+1 ), - $ N+NK ) - CALL DGEMM( 'N', 'N', NK, NK, NP, ONE, DWORK( I2+1 ), NK, - $ DWORK( I5+1 ), NP, ONE, DWORK( I7+(N+NK)*N+N+1 ), - $ N+NK ) -C -C Compute the closed-loop poles. -C Additional workspace: need 3*(N+NK); prefer larger. -C The fact that M > 0, NP > 0, and NK <= N is used here. -C - CALL DGEES( 'N', 'N', SELECT, N+NK, DWORK( I7+1 ), N+NK, SDIM, - $ DWORK, DWORK( N+NK+1 ), DWORK( IWRK+1 ), N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Check the stability of the closed-loop system. -C - NS = 0 - DO 40 I = 1, N+NK - IF( DWORK( I ).GE.ZERO ) NS = NS + 1 - 40 CONTINUE - IF( NS.GT.0 ) THEN - INFO = 6 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10ID *** - END diff --git a/slycot/src/SB10JD.f b/slycot/src/SB10JD.f deleted file mode 100644 index 938b6508..00000000 --- a/slycot/src/SB10JD.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E, - $ LDE, NSYS, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To convert the descriptor state-space system -C -C E*dx/dt = A*x + B*u -C y = C*x + D*u -C -C into regular state-space form -C -C dx/dt = Ad*x + Bd*u -C y = Cd*x + Dd*u . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the descriptor system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state matrix A of the descriptor system. -C On exit, the leading NSYS-by-NSYS part of this array -C contains the state matrix Ad of the converted system. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B of the descriptor system. -C On exit, the leading NSYS-by-M part of this array -C contains the input matrix Bd of the converted system. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading NP-by-N part of this array must -C contain the output matrix C of the descriptor system. -C On exit, the leading NP-by-NSYS part of this array -C contains the output matrix Cd of the converted system. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading NP-by-M part of this array must -C contain the matrix D of the descriptor system. -C On exit, the leading NP-by-M part of this array contains -C the matrix Dd of the converted system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the matrix E of the descriptor system. -C On exit, this array contains no useful information. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= max(1,N). -C -C NSYS (output) INTEGER -C The order of the converted state-space system. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ). -C For good performance, LDWORK must generally be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the iteration for computing singular value -C decomposition did not converge. -C -C METHOD -C -C The routine performs the transformations described in [1]. -C -C REFERENCES -C -C [1] Chiang, R.Y. and Safonov, M.G. -C Robust Control Toolbox User's Guide. -C The MathWorks Inc., Natick, Mass., 1992. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, -C Feb. 2001. -C -C KEYWORDS -C -C Descriptor systems, state-space models. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, - $ NP, NSYS -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), E( LDE, * ) -C .. -C .. Local Scalars .. - INTEGER I, IA12, IA21, IB2, IC2, INFO2, IS, ISA, IU, - $ IV, IWRK, J, K, LWA, LWAMAX, MINWRK, NS1 - DOUBLE PRECISION EPS, SCALE, TOL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, DLACPY, DLASET, DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -13 - END IF -C -C Compute workspace. -C - MINWRK = MAX( 1, 2*N*( N + 1 ) + N*MAX( 5, N + M + NP ) ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -16 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - NSYS = 0 - DWORK( 1 ) = ONE - RETURN - END IF -C -C Set tol. -C - EPS = DLAMCH( 'Epsilon' ) - TOL = SQRT( EPS ) -C -C Workspace usage. -C - IS = 0 - IU = IS + N - IV = IU + N*N -C - IWRK = IV + N*N -C -C Compute the SVD of E. -C Additional workspace: need 5*N; prefer larger. -C - CALL DGESVD( 'S', 'S', N, N, E, LDE, DWORK( IS+1 ), DWORK( IU+1 ), - $ N, DWORK( IV+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( MINWRK, INT( DWORK( IWRK+1 ) + IWRK ) ) -C -C Determine the rank of E. -C - NS1 = 0 - DO 10 I = 1, N - IF( DWORK( IS+I ).GT.TOL ) NS1 = NS1 + 1 - 10 CONTINUE - IF( NS1.GT.0 ) THEN -C -C Transform A. -C Additional workspace: need N*max(N,M,NP). -C - CALL DGEMM( 'T', 'N', N, N, N, ONE, DWORK( IU+1 ), N, A, LDA, - $ ZERO, DWORK( IWRK+1 ), N ) - CALL DGEMM( 'N', 'T', N, N, N, ONE, DWORK( IWRK+1 ), N, - $ DWORK( IV+1 ), N, ZERO, A, LDA ) -C -C Transform B. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IWRK+1 ), N ) - CALL DGEMM( 'T', 'N', N, M, N, ONE, DWORK( IU+1 ), N, - $ DWORK( IWRK+1 ), N, ZERO, B, LDB ) -C -C Transform C. -C - CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWRK+1 ), NP ) - CALL DGEMM( 'N', 'T', NP, N, N, ONE, DWORK( IWRK+1 ), NP, - $ DWORK( IV+1 ), N, ZERO, C, LDC ) -C - K = N - NS1 - IF( K.GT.0 ) THEN - ISA = IU + K*K - IV = ISA + K - IWRK = IV + K*MAX( K, NS1 ) -C -C Compute the SVD of A22. -C Additional workspace: need 5*K; prefer larger. -C - CALL DGESVD( 'S', 'S', K, K, A( NS1+1, NS1+1 ), LDA, - $ DWORK( ISA+1 ), DWORK( IU+1 ), K, - $ DWORK( IV+1 ), K, DWORK( IWRK+1 ), LDWORK-IWRK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - IA12 = IWRK - IB2 = IA12 + NS1*K - IC2 = IB2 + K*M -C - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX, IC2 + K*NP ) -C -C Compute the transformed A12. -C - CALL DGEMM( 'N', 'T', NS1, K, K, ONE, A( 1, NS1+1 ), LDA, - $ DWORK( IV+1 ), K, ZERO, DWORK( IA12+1 ), NS1 ) -C -C Compute CC2. -C - CALL DGEMM( 'N', 'T', NP, K, K, ONE, C( 1, NS1+1 ), LDC, - $ DWORK( IV+1 ), K, ZERO, DWORK( IC2+1 ), NP ) -C -C Compute the transformed A21. -C - IA21 = IV - CALL DGEMM( 'T', 'N', K, NS1, K, ONE, DWORK( IU+1 ), K, - $ A( NS1+1, 1 ), LDA, ZERO, DWORK( IA21+1 ), K ) -C -C Compute BB2. -C - CALL DGEMM( 'T', 'N', K, M, K, ONE, DWORK( IU+1 ), K, - $ B( NS1+1, 1 ), LDB, ZERO, DWORK( IB2+1 ), K ) -C -C Compute A12*pinv(A22) and CC2*pinv(A22). -C - DO 20 J = 1, K - SCALE = ZERO - IF( DWORK( ISA+J ).GT.TOL ) SCALE = ONE/DWORK( ISA+J ) - CALL DSCAL( NS1, SCALE, DWORK( IA12+(J-1)*NS1+1 ), 1 ) - CALL DSCAL( NP, SCALE, DWORK( IC2+(J-1)*NP+1 ), 1 ) - 20 CONTINUE -C -C Compute Ad. -C - CALL DGEMM( 'N', 'N', NS1, NS1, K, -ONE, DWORK( IA12+1 ), - $ NS1, DWORK( IA21+1 ), K, ONE, A, LDA ) -C -C Compute Bd. -C - CALL DGEMM( 'N', 'N', NS1, M, K, -ONE, DWORK( IA12+1 ), NS1, - $ DWORK( IB2+1 ), K, ONE, B, LDB ) -C -C Compute Cd. -C - CALL DGEMM( 'N', 'N', NP, NS1, K, -ONE, DWORK( IC2+1 ), NP, - $ DWORK( IA21+1 ), K, ONE, C, LDC ) -C -C Compute Dd. -C - CALL DGEMM( 'N', 'N', NP, M, K, -ONE, DWORK( IC2+1 ), NP, - $ DWORK( IB2+1 ), K, ONE, D, LDD ) - END IF - DO 30 I = 1, NS1 - SCALE = ONE/SQRT( DWORK( IS+I ) ) - CALL DSCAL( NS1, SCALE, A( I, 1 ), LDA ) - CALL DSCAL( M, SCALE, B( I, 1 ), LDB ) - 30 CONTINUE - DO 40 J = 1, NS1 - SCALE = ONE/SQRT( DWORK( IS+J ) ) - CALL DSCAL( NS1, SCALE, A( 1, J ), 1 ) - CALL DSCAL( NP, SCALE, C( 1, J ), 1 ) - 40 CONTINUE - NSYS = NS1 - ELSE - CALL DLASET( 'F', N, N, ZERO, -ONE/EPS, A, LDA ) - CALL DLASET( 'F', N, M, ZERO, ZERO, B, LDB ) - CALL DLASET( 'F', NP, N, ZERO, ZERO, C, LDC ) - NSYS = N - END IF - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10JD *** - END diff --git a/slycot/src/SB10KD.f b/slycot/src/SB10KD.f deleted file mode 100644 index 38f1cef0..00000000 --- a/slycot/src/SB10KD.f +++ /dev/null @@ -1,650 +0,0 @@ - SUBROUTINE SB10KD( N, M, NP, A, LDA, B, LDB, C, LDC, FACTOR, - $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND, - $ IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the positive feedback controller -C -C | Ak | Bk | -C K = |----|----| -C | Ck | Dk | -C -C for the shaped plant -C -C | A | B | -C G = |---|---| -C | C | 0 | -C -C in the Discrete-Time Loop Shaping Design Procedure. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the plant. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A of the shaped plant. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B of the shaped plant. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C of the shaped plant. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C FACTOR (input) DOUBLE PRECISION -C = 1 implies that an optimal controller is required; -C > 1 implies that a suboptimal controller is required -C achieving a performance FACTOR less than optimal. -C FACTOR >= 1. -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix Ak. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) -C The leading N-by-NP part of this array contains the -C controller input matrix Bk. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading M-by-N part of this array contains the -C controller output matrix Ck. -C -C LDCK INTEGER -C The leading dimension of the array CK. LDCK >= max(1,M). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) -C The leading M-by-NP part of this array contains the -C controller matrix Dk. -C -C LDDK INTEGER -C The leading dimension of the array DK. LDDK >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND(1) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the P-Riccati equation is -C obtained; -C RCOND(2) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the Q-Riccati equation is -C obtained; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the X-Riccati equation is -C obtained; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the matrix Rx + Bx'*X*Bx (see the -C comments in the code). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*max(N,NP+M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 15*N*N + 6*N + -C max( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + -C max( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + -C 4*M*NP + NP ). -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the P-Riccati equation is not solved successfully; -C = 2: the Q-Riccati equation is not solved successfully; -C = 3: the X-Riccati equation is not solved successfully; -C = 4: the iteration to compute eigenvalues failed to -C converge; -C = 5: the matrix Rx + Bx'*X*Bx is singular; -C = 6: the closed-loop system is unstable. -C -C METHOD -C -C The routine implements the method presented in [1]. -C -C REFERENCES -C -C [1] McFarlane, D. and Glover, K. -C A loop shaping design procedure using H_infinity synthesis. -C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, -C 1992. -C -C NUMERICAL ASPECTS -C -C The accuracy of the results depends on the conditioning of the -C two Riccati equations solved in the controller design. For -C better conditioning it is advised to take FACTOR > 1. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. -C -C REVISIONS -C -C V. Sima, Katholieke University Leuven, January 2001, -C February 2001. -C -C KEYWORDS -C -C H_infinity control, Loop-shaping design, Robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK, - $ LDWORK, M, N, NP - DOUBLE PRECISION FACTOR -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - LOGICAL BWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ DK( LDDK, * ), DWORK( * ), RCOND( 4 ) -C .. -C .. Local Scalars .. - INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, - $ I11, I12, I13, I14, I15, I16, I17, I18, I19, - $ I20, I21, I22, I23, I24, I25, I26, INFO2, - $ IWRK, J, LWA, LWAMAX, MINWRK, N2, NS, SDIM - DOUBLE PRECISION GAMMA, RNORM -C .. -C .. External Functions .. - LOGICAL SELECT - DOUBLE PRECISION DLANSY, DLAPY2 - EXTERNAL DLANSY, DLAPY2, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGEES, DLACPY, DLASET, DPOTRF, DPOTRS, - $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, SB02OD, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( FACTOR.LT.ONE ) THEN - INFO = -10 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN - INFO = -18 - END IF -C -C Compute workspace. -C - MINWRK = 15*N*N + 6*N + MAX( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + - $ MAX( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + - $ 4*M*NP + NP ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10KD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C -C Workspace usage. -C - N2 = 2*N - I1 = N*N - I2 = I1 + N*N - I3 = I2 + N*N - I4 = I3 + N*N - I5 = I4 + N2 - I6 = I5 + N2 - I7 = I6 + N2 - I8 = I7 + N2*N2 - I9 = I8 + N2*N2 -C - IWRK = I9 + N2*N2 - LWAMAX = 0 -C -C Compute Cr = C'*C . -C - CALL DSYRK( 'U', 'T', N, NP, ONE, C, LDC, ZERO, DWORK( I2+1 ), N ) -C -C Compute Dr = B*B' . -C - CALL DSYRK( 'U', 'N', N, M, ONE, B, LDB, ZERO, DWORK( I3+1 ), N ) -C -1 -C Solution of the Riccati equation A'*P*(In + Dr*P) *A - P + Cr = 0. -C - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, A, LDA, - $ DWORK( I3+1 ), N, DWORK( I2+1 ), N, DWORK, M, DWORK, - $ N, RCOND( 1 ), DWORK, N, DWORK( I4+1 ), - $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, - $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Transpose A in AK (used as workspace). -C - DO 40 J = 1, N - DO 30 I = 1, N - AK( I,J ) = A( J,I ) - 30 CONTINUE - 40 CONTINUE -C -1 -C Solution of the Riccati equation A*Q*(In + Cr*Q) *A' - Q + Dr = 0. -C - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, AK, LDAK, - $ DWORK( I2+1 ), N, DWORK( I3+1 ), N, DWORK, M, DWORK, - $ N, RCOND( 2 ), DWORK( I1+1 ), N, DWORK( I4+1 ), - $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, - $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Compute gamma. -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, - $ ZERO, AK, LDAK ) - CALL DGEES( 'N', 'N', SELECT, N, AK, LDAK, SDIM, DWORK( I6+1 ), - $ DWORK( I7+1 ), DWORK( IWRK+1 ), N, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) - GAMMA = ZERO - DO 50 I = 1, N - GAMMA = MAX( GAMMA, DWORK( I6+I ) ) - 50 CONTINUE - GAMMA = FACTOR*SQRT( ONE + GAMMA ) -C -C Workspace usage. -C - I3 = I2 + N*NP - I4 = I3 + NP*NP - I5 = I4 + NP*NP - I6 = I5 + NP*NP - I7 = I6 + NP - I8 = I7 + NP*NP - I9 = I8 + NP*NP - I10 = I9 + NP*NP - I11 = I10 + N*NP - I12 = I11 + N*NP - I13 = I12 + ( NP+M )*( NP+M ) - I14 = I13 + N*( NP+M ) - I15 = I14 + N*( NP+M ) - I16 = I15 + N*N - I17 = I16 + N2 - I18 = I17 + N2 - I19 = I18 + N2 - I20 = I19 + ( N2+NP+M )*( N2+NP+M ) - I21 = I20 + ( N2+NP+M )*N2 -C - IWRK = I21 + N2*N2 -C -C Compute Q*C' . -C - CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1+1 ), N, C, LDC, - $ ZERO, DWORK( I2+1 ), N ) -C -C Compute Ip + C*Q*C' . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I3+1 ), NP ) - CALL DGEMM( 'N', 'N', NP, NP, N, ONE, C, LDC, DWORK( I2+1 ), N, - $ ONE, DWORK( I3+1 ), NP ) -C -C Compute the eigenvalues and eigenvectors of Ip + C'*Q*C -C - CALL DLACPY( 'U', NP, NP, DWORK( I3+1 ), NP, DWORK( I5+1 ), NP ) - CALL DSYEV( 'V', 'U', NP, DWORK( I5+1 ), NP, DWORK( I6+1 ), - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -1 -C Compute ( Ip + C'*Q*C ) . -C - DO 70 J = 1, NP - DO 60 I = 1, NP - DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / - $ DWORK( I6+I ) - 60 CONTINUE - 70 CONTINUE - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, - $ DWORK( I9+1 ), NP, ZERO, DWORK( I4+1 ), NP ) -C -C Compute Z2 . -C - DO 90 J = 1, NP - DO 80 I = 1, NP - DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / - $ SQRT( DWORK( I6+I ) ) - 80 CONTINUE - 90 CONTINUE - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, - $ DWORK( I9+1 ), NP, ZERO, DWORK( I7+1 ), NP ) -C -1 -C Compute Z2 . -C - DO 110 J = 1, NP - DO 100 I = 1, NP - DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP )* - $ SQRT( DWORK( I6+I ) ) - 100 CONTINUE - 110 CONTINUE - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, - $ DWORK( I9+1 ), NP, ZERO, DWORK( I8+1 ), NP ) -C -C Compute A*Q*C' . -C - CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, DWORK( I2+1 ), N, - $ ZERO, DWORK( I10+1 ), N ) -C -1 -C Compute H = -A*Q*C'*( Ip + C*Q*C' ) . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I10+1 ), N, - $ DWORK( I4+1 ), NP, ZERO, DWORK( I11+1 ), N ) -C -C Compute Rx . -C - CALL DLASET( 'F', NP+M, NP+M, ZERO, ONE, DWORK( I12+1 ), NP+M ) - DO 130 J = 1, NP - DO 120 I = 1, NP - DWORK( I12+I+(J-1)*(NP+M) ) = DWORK( I3+I+(J-1)*NP ) - 120 CONTINUE - DWORK( I12+J+(J-1)*(NP+M) ) = DWORK( I3+J+(J-1)*NP ) - - $ GAMMA*GAMMA - 130 CONTINUE -C -C Compute Bx . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I11+1 ), N, - $ DWORK( I8+1 ), NP, ZERO, DWORK( I13+1 ), N ) - DO 150 J = 1, M - DO 140 I = 1, N - DWORK( I13+N*NP+I+(J-1)*N ) = B( I, J ) - 140 CONTINUE - 150 CONTINUE -C -C Compute Sx . -C - CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I8+1 ), NP, - $ ZERO, DWORK( I14+1 ), N ) - CALL DLASET( 'F', N, M, ZERO, ZERO, DWORK( I14+N*NP+1 ), N ) -C -C Solve the Riccati equation -C -1 -C X = A'*X*A + Cx - (Sx + A'*X*Bx)*(Rx + Bx'*X*B ) *(Sx'+Bx'*X*A). -C - CALL SB02OD( 'D', 'B', 'C', 'U', 'N', 'S', N, NP+M, NP, A, LDA, - $ DWORK( I13+1 ), N, C, LDC, DWORK( I12+1 ), NP+M, - $ DWORK( I14+1 ), N, RCOND( 3 ), DWORK( I15+1 ), N, - $ DWORK( I16+1 ), DWORK( I17+1 ), DWORK( I18+1 ), - $ DWORK( I19+1 ), N2+NP+M, DWORK( I20+1 ), N2+NP+M, - $ DWORK( I21+1 ), N2, -ONE, IWORK, DWORK( IWRK+1 ), - $ LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C - I22 = I16 - I23 = I22 + ( NP+M )*N - I24 = I23 + ( NP+M )*( NP+M ) - I25 = I24 + ( NP+M )*N - I26 = I25 + M*N -C - IWRK = I25 -C -C Compute Bx'*X . -C - CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I13+1 ), N, - $ DWORK( I15+1 ), N, ZERO, DWORK( I22+1 ), NP+M ) -C -C Compute Rx + Bx'*X*Bx . -C - CALL DLACPY( 'F', NP+M, NP+M, DWORK( I12+1 ), NP+M, - $ DWORK( I23+1 ), NP+M ) - CALL DGEMM( 'N', 'N', NP+M, NP+M, N, ONE, DWORK( I22+1 ), NP+M, - $ DWORK( I13+1 ), N, ONE, DWORK( I23+1 ), NP+M ) -C -C Compute -( Sx' + Bx'*X*A ) . -C - DO 170 J = 1, N - DO 160 I = 1, NP+M - DWORK( I24+I+(J-1)*(NP+M) ) = DWORK( I14+J+(I-1)*N ) - 160 CONTINUE - 170 CONTINUE - CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I22+1 ), NP+M, - $ A, LDA, -ONE, DWORK( I24+1 ), NP+M ) -C -C Factorize Rx + Bx'*X*Bx . -C - RNORM = DLANSY( '1', 'U', NP+M, DWORK( I23+1 ), NP+M, - $ DWORK( IWRK+1 ) ) - CALL DSYTRF( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, - $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) - CALL DSYCON( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, RNORM, - $ RCOND( 4 ), DWORK( IWRK+1 ), IWORK( NP+M+1), INFO2 ) -C -1 -C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . -C - CALL DSYTRS( 'U', NP+M, N, DWORK( I23+1 ), NP+M, IWORK, - $ DWORK( I24+1 ), NP+M, INFO2 ) -C -C Compute B'*X . -C - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15+1 ), N, - $ ZERO, DWORK( I25+1 ), M ) -C -C Compute Im + B'*X*B . -C - CALL DLASET( 'F', M, M, ZERO, ONE, DWORK( I23+1 ), M ) - CALL DGEMM( 'N', 'N', M, M, N, ONE, DWORK( I25+1 ), M, B, LDB, - $ ONE, DWORK( I23+1 ), M ) -C -C Factorize Im + B'*X*B . -C - CALL DPOTRF( 'U', M, DWORK( I23+1 ), M, INFO2 ) -C -1 -C Compute ( Im + B'*X*B ) B'*X . -C - CALL DPOTRS( 'U', M, N, DWORK( I23+1 ), M, DWORK( I25+1 ), M, - $ INFO2 ) -C -1 -C Compute Dk = ( Im + B'*X*B ) B'*X*H . -C - CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I25+1 ), M, - $ DWORK( I11+1 ), N, ZERO, DK, LDDK ) -C -C Compute Bk = -H + B*Dk . -C - CALL DLACPY( 'F', N, NP, DWORK( I11+1 ), N, BK, LDBK ) - CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, -ONE, - $ BK, LDBK ) -C -1 -C Compute Dk*Z2 . -C - CALL DGEMM( 'N', 'N', M, NP, NP, ONE, DK, LDDK, DWORK( I8+1 ), - $ NP, ZERO, DWORK( I26+1 ), M ) -C -C Compute F1 + Z2*C . -C - CALL DLACPY( 'F', NP, N, DWORK( I24+1 ), NP+M, DWORK( I12+1 ), - $ NP ) - CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7+1 ), NP, C, LDC, - $ ONE, DWORK( I12+1 ), NP ) -C -1 -C Compute Ck = F2 - Dk*Z2 *( F1 + Z2*C ) . -C - CALL DLACPY( 'F', M, N, DWORK( I24+NP+1 ), NP+M, CK, LDCK ) - CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DWORK( I26+1 ), M, - $ DWORK( I12+1 ), NP, ONE, CK, LDCK ) -C -C Compute Ak = A + H*C + B*Ck . -C - CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I11+1 ), N, C, LDC, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ONE, AK, - $ LDAK ) -C -C Workspace usage. -C - I1 = M*N - I2 = I1 + N2*N2 - I3 = I2 + N2 -C - IWRK = I3 + N2 -C -C Compute Dk*C . -C - CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, - $ DWORK, M ) -C -C Compute the closed-loop state matrix. -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I1+1 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK, M, ONE, - $ DWORK( I1+1 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, NP, -ONE, BK, LDBK, C, LDC, ZERO, - $ DWORK( I1+N+1 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ZERO, - $ DWORK( I1+N2*N+1 ), N2 ) - CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I1+N2*N+N+1 ), N2 ) -C -C Compute the closed-loop poles. -C - CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I1+1 ), N2, SDIM, - $ DWORK( I2+1 ), DWORK( I3+1 ), DWORK( IWRK+1 ), N, - $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - LWA = INT( DWORK( IWRK+1 ) ) + IWRK - LWAMAX = MAX( LWA, LWAMAX ) -C -C Check the stability of the closed-loop system. -C - NS = 0 - DO 180 I = 1, N2 - IF( DLAPY2( DWORK( I2+I ), DWORK( I3+I ) ).GT.ONE ) NS = NS + 1 - 180 CONTINUE - IF( NS.GT.0 ) THEN - INFO = 6 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10KD *** - END diff --git a/slycot/src/SB10LD.f b/slycot/src/SB10LD.f deleted file mode 100644 index b2d7d06b..00000000 --- a/slycot/src/SB10LD.f +++ /dev/null @@ -1,438 +0,0 @@ - SUBROUTINE SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the closed-loop system -C -C | AC | BC | -C G = |----|----|, -C | CC | DC | -C -C from the matrices of the open-loop system -C -C | A | B | -C P = |---|---| -C | C | D | -C -C and the matrices of the controller -C -C | AK | BK | -C K = |----|----|. -C | CK | DK | -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (input) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array must contain the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (input) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array must contain the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (input) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array must contain the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (input) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array must contain -C the controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) -C The leading 2*N-by-2*N part of this array contains the -C closed-loop system state matrix AC. -C -C LDAC INTEGER -C The leading dimension of the array AC. -C LDAC >= max(1,2*N). -C -C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) -C The leading 2*N-by-(M-NCON) part of this array contains -C the closed-loop system input matrix BC. -C -C LDBC INTEGER -C The leading dimension of the array BC. -C LDBC >= max(1,2*N). -C -C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) -C The leading (NP-NMEAS)-by-2*N part of this array contains -C the closed-loop system output matrix CC. -C -C LDCC INTEGER -C The leading dimension of the array CC. -C LDCC >= max(1,NP-NMEAS). -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) -C The leading (NP-NMEAS)-by-(M-NCON) part of this array -C contains the closed-loop system input/output matrix DC. -C -C LDDC INTEGER -C The leading dimension of the array DC. -C LDDC >= max(1,NP-NMEAS). -C -C Workspace -C -C IWORK INTEGER array, dimension 2*max(NCON,NMEAS) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 2*M*M+NP*NP+2*M*N+M*NP+2*N*NP. -C For good performance, LDWORK must generally be larger. -C -C Error Indicactor -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix Inp2 - D22*DK is singular to working -C precision; -C = 2: if the matrix Im2 - DK*D22 is singular to working -C precision. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C matrices Inp2 - D22*DK and Im2 - DK*D22. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999. -C A. Markovski, Technical University, Sofia, April, 2003. -C -C KEYWORDS -C -C Closed loop systems, feedback control, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAC, LDAK, LDB, LDBC, LDBK, LDC, - $ LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, M, N, - $ NCON, NMEAS, NP -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), - $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), - $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), - $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), - $ DWORK( * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IW2, IW3, IW4, IW5, IW6, IW7, IW8, IWRK, - $ LWAMAX, M1, M2, MINWRK, N2, NP1, NP2 - DOUBLE PRECISION ANORM, EPS, RCOND -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DLACPY, DLASET, - $ XERBLA -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - N2 = 2*N - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE IF( LDAC.LT.MAX( 1, N2 ) ) THEN - INFO = -23 - ELSE IF( LDBC.LT.MAX( 1, N2 ) ) THEN - INFO = -25 - ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN - INFO = -27 - ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN - INFO = -29 - ELSE -C -C Compute workspace. -C - MINWRK = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP - IF( LDWORK.LT.MINWRK ) - $ INFO = -32 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10LD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Workspace usage. -C - IW2 = NP2*NP2 + 1 - IW3 = IW2 + M2*M2 - IW4 = IW3 + NP2*N - IW5 = IW4 + M2*N - IW6 = IW5 + NP2*M1 - IW7 = IW6 + M2*M1 - IW8 = IW7 + M2*N - IWRK = IW8 + NP2*N -C -C Compute inv(Inp2 - D22*DK) . -C - CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK, NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, D( NP1+1, M1+1 ), - $ LDD, DK, LDDK, ONE, DWORK, NP2 ) - ANORM = DLANGE( '1', NP2, NP2, DWORK, NP2, DWORK( IWRK ) ) - CALL DGETRF( NP2, NP2, DWORK, NP2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGECON( '1', NP2, DWORK, NP2, ANORM, RCOND, DWORK( IWRK ), - $ IWORK( NP2+1 ), INFO ) - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF - CALL DGETRI( NP2, DWORK, NP2, IWORK, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute inv(Im2 - DK*D22) . -C - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) - CALL DGEMM( 'N', 'N', M2, M2, NP2, -ONE, DK, LDDK, - $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( M2+1 ), INFO ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 2 - RETURN - END IF - CALL DGETRI( M2, DWORK( IW2 ), M2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute inv(Inp2 - D22*DK)*C2 . -C - CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, DWORK, NP2, C( NP1+1, 1 ), - $ LDC, ZERO, DWORK( IW3 ), NP2 ) -C -C Compute DK*inv(Inp2 - D22*DK)*C2 . -C - CALL DGEMM( 'N', 'N', M2, N, NP2, ONE, DK, LDDK, DWORK( IW3 ), - $ NP2, ZERO, DWORK( IW4 ), M2 ) -C -C Compute inv(Inp2 - D22*DK)*D21 . -C - CALL DGEMM( 'N', 'N', NP2, M1, NP2, ONE, DWORK, NP2, - $ D( NP1+1, 1 ), LDD, ZERO, DWORK( IW5 ), NP2 ) -C -C Compute DK*inv(Inp2 - D22*DK)*D21 . -C - CALL DGEMM( 'N', 'N', M2, M1, NP2, ONE, DK, LDDK, DWORK( IW5 ), - $ NP2, ZERO, DWORK( IW6 ), M2 ) -C -C Compute inv(Im2 - DK*D22)*CK . -C - CALL DGEMM( 'N', 'N', M2, N, M2, ONE, DWORK( IW2 ), M2, CK, LDCK, - $ ZERO, DWORK( IW7 ), M2 ) -C -C Compute D22*inv(Im2 - DK*D22)*CK . -C - CALL DGEMM( 'N', 'N', NP2, N, M2, ONE, D( NP1+1, M1+1 ), LDD, - $ DWORK( IW7 ), M2, ZERO, DWORK( IW8 ), NP2 ) -C -C Compute AC . -C - CALL DLACPY( 'Full', N, N, A, LDA, AC, LDAC ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, - $ DWORK( IW4 ), M2, ONE, AC, LDAC ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, - $ DWORK( IW7 ), M2, ZERO, AC( 1, N+1 ), LDAC ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW3 ), NP2, - $ ZERO, AC( N+1, 1 ), LDAC ) - CALL DLACPY( 'Full', N, N, AK, LDAK, AC( N+1, N+1 ), LDAC ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW8 ), NP2, - $ ONE, AC( N+1, N+1 ), LDAC ) -C -C Compute BC . -C - CALL DLACPY( 'Full', N, M1, B, LDB, BC, LDBC ) - CALL DGEMM( 'N', 'N', N, M1, M2, ONE, B( 1, M1+1 ), LDB, - $ DWORK( IW6 ), M2, ONE, BC, LDBC ) - CALL DGEMM( 'N', 'N', N, M1, NP2, ONE, BK, LDBK, DWORK( IW5 ), - $ NP2, ZERO, BC( N+1, 1 ), LDBC ) -C -C Compute CC . -C - CALL DLACPY( 'Full', NP1, N, C, LDC, CC, LDCC ) - CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, - $ DWORK( IW4 ), M2, ONE, CC, LDCC ) - CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, - $ DWORK( IW7 ), M2, ZERO, CC( 1, N+1 ), LDCC ) -C -C Compute DC . -C - CALL DLACPY( 'Full', NP1, M1, D, LDD, DC, LDDC ) - CALL DGEMM( 'N', 'N', NP1, M1, M2, ONE, D( 1, M1+1 ), LDD, - $ DWORK( IW6 ), M2, ONE, DC, LDDC ) -C - RETURN -C *** Last line of SB10LD *** - END diff --git a/slycot/src/SB10MD.f b/slycot/src/SB10MD.f deleted file mode 100644 index 46ea3d84..00000000 --- a/slycot/src/SB10MD.f +++ /dev/null @@ -1,670 +0,0 @@ - SUBROUTINE SB10MD( NC, MP, LENDAT, F, ORD, MNB, NBLOCK, ITYPE, - $ QUTOL, A, LDA, B, LDB, C, LDC, D, LDD, OMEGA, - $ TOTORD, AD, LDAD, BD, LDBD, CD, LDCD, DD, LDDD, - $ MJU, IWORK, LIWORK, DWORK, LDWORK, ZWORK, - $ LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To perform the D-step in the D-K iteration. It handles -C continuous-time case. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NC (input) INTEGER -C The order of the matrix A. NC >= 0. -C -C MP (input) INTEGER -C The order of the matrix D. MP >= 0. -C -C LENDAT (input) INTEGER -C The length of the vector OMEGA. LENDAT >= 2. -C -C F (input) INTEGER -C The number of the measurements and controls, i.e., -C the size of the block I_f in the D-scaling system. -C F >= 0. -C -C ORD (input/output) INTEGER -C The MAX order of EACH block in the fitting procedure. -C ORD <= LENDAT-1. -C On exit, if ORD < 1 then ORD = 1. -C -C MNB (input) INTEGER -C The number of diagonal blocks in the block structure of -C the uncertainty, and the length of the vectors NBLOCK -C and ITYPE. 1 <= MNB <= MP. -C -C NBLOCK (input) INTEGER array, dimension (MNB) -C The vector of length MNB containing the block structure -C of the uncertainty. NBLOCK(I), I = 1:MNB, is the size of -C each block. -C -C ITYPE (input) INTEGER array, dimension (MNB) -C The vector of length MNB indicating the type of each -C block. -C For I = 1 : MNB, -C ITYPE(I) = 1 indicates that the corresponding block is a -C real block. IN THIS CASE ONLY MJU(JW) WILL BE ESTIMATED -C CORRECTLY, BUT NOT D(S)! -C ITYPE(I) = 2 indicates that the corresponding block is a -C complex block. THIS IS THE ONLY ALLOWED VALUE NOW! -C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. -C -C QUTOL (input) DOUBLE PRECISION -C The acceptable mean relative error between the D(jw) and -C the frequency responce of the estimated block -C [ADi,BDi;CDi,DDi]. When it is reached, the result is -C taken as good enough. -C A good value is QUTOL = 2.0. -C If QUTOL < 0 then only mju(jw) is being estimated, -C not D(s). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,NC) -C On entry, the leading NC-by-NC part of this array must -C contain the A matrix of the closed-loop system. -C On exit, if MP > 0, the leading NC-by-NC part of this -C array contains an upper Hessenberg matrix similar to A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,NC). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,MP) -C On entry, the leading NC-by-MP part of this array must -C contain the B matrix of the closed-loop system. -C On exit, the leading NC-by-MP part of this array contains -C the transformed B matrix corresponding to the Hessenberg -C form of A. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,NC). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) -C On entry, the leading MP-by-NC part of this array must -C contain the C matrix of the closed-loop system. -C On exit, the leading MP-by-NC part of this array contains -C the transformed C matrix corresponding to the Hessenberg -C form of A. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,MP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,MP) -C The leading MP-by-MP part of this array must contain the -C D matrix of the closed-loop system. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,MP). -C -C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) -C The vector with the frequencies. -C -C TOTORD (output) INTEGER -C The TOTAL order of the D-scaling system. -C TOTORD is set to zero, if QUTOL < 0. -C -C AD (output) DOUBLE PRECISION array, dimension (LDAD,MP*ORD) -C The leading TOTORD-by-TOTORD part of this array contains -C the A matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDAD INTEGER -C The leading dimension of the array AD. -C LDAD >= MAX(1,MP*ORD), if QUTOL >= 0; -C LDAD >= 1, if QUTOL < 0. -C -C BD (output) DOUBLE PRECISION array, dimension (LDBD,MP+F) -C The leading TOTORD-by-(MP+F) part of this array contains -C the B matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDBD INTEGER -C The leading dimension of the array BD. -C LDBD >= MAX(1,MP*ORD), if QUTOL >= 0; -C LDBD >= 1, if QUTOL < 0. -C -C CD (output) DOUBLE PRECISION array, dimension (LDCD,MP*ORD) -C The leading (MP+F)-by-TOTORD part of this array contains -C the C matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDCD INTEGER -C The leading dimension of the array CD. -C LDCD >= MAX(1,MP+F), if QUTOL >= 0; -C LDCD >= 1, if QUTOL < 0. -C -C DD (output) DOUBLE PRECISION array, dimension (LDDD,MP+F) -C The leading (MP+F)-by-(MP+F) part of this array contains -C the D matrix of the D-scaling system. -C Not referenced if QUTOL < 0. -C -C LDDD INTEGER -C The leading dimension of the array DD. -C LDDD >= MAX(1,MP+F), if QUTOL >= 0; -C LDDD >= 1, if QUTOL < 0. -C -C MJU (output) DOUBLE PRECISION array, dimension (LENDAT) -C The vector with the upper bound of the structured -C singular value (mju) for each frequency in OMEGA. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C -C LIWORK INTEGER -C The length of the array IWORK. -C LIWORK >= MAX( NC, 4*MNB-2, MP, 2*ORD+1 ), if QUTOL >= 0; -C LIWORK >= MAX( NC, 4*MNB-2, MP ), if QUTOL < 0. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK, DWORK(2) returns the optimal value of LZWORK, -C and DWORK(3) returns an estimate of the minimum reciprocal -C of the condition numbers (with respect to inversion) of -C the generated Hessenberg matrices. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 3, LWM, LWD ), where -C LWM = LWA + MAX( NC + MAX( NC, MP-1 ), -C 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + -C MP*MNB + 11*MP + 33*MNB - 11 ); -C LWD = LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ), -C if QUTOL >= 0; -C LWD = 0, if QUTOL < 0; -C LWA = MP*LENDAT + 2*MNB + MP - 1; -C LWB = LENDAT*(MP + 2) + ORD*(ORD + 2) + 1; -C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; -C LW2 = LENDAT + 6*HNPTS; MN = MIN( 2*LENDAT, 2*ORD+1 ); -C LW3 = 2*LENDAT*(2*ORD + 1) + MAX( 2*LENDAT, 2*ORD + 1 ) + -C MAX( MN + 6*ORD + 4, 2*MN + 1 ); -C LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ). -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( LZM, LZD ), where -C LZM = MAX( MP*MP + NC*MP + NC*NC + 2*NC, -C 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ); -C LZD = MAX( LENDAT*(2*ORD + 3), ORD*ORD + 3*ORD + 1 ), -C if QUTOL >= 0; -C LZD = 0, if QUTOL < 0. -C -C Error indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if one or more values w in OMEGA are (close to -C some) poles of the closed-loop system, i.e., the -C matrix jw*I - A is (numerically) singular; -C = 2: the block sizes must be positive integers; -C = 3: the sum of block sizes must be equal to MP; -C = 4: the size of a real block must be equal to 1; -C = 5: the block type must be either 1 or 2; -C = 6: errors in solving linear equations or in matrix -C inversion; -C = 7: errors in computing eigenvalues or singular values. -C = 1i: INFO on exit from SB10YD is i. (1i means 10 + i.) -C -C METHOD -C -C I. First, W(jw) for the given closed-loop system is being -C estimated. -C II. Now, AB13MD SLICOT subroutine can obtain the D(jw) scaling -C system with respect to NBLOCK and ITYPE, and colaterally, -C mju(jw). -C If QUTOL < 0 then the estimations stop and the routine exits. -C III. Now that we have D(jw), SB10YD subroutine can do block-by- -C block fit. For each block it tries with an increasing order -C of the fit, starting with 1 until the -C (mean quadratic error + max quadratic error)/2 -C between the Dii(jw) and the estimated frequency responce -C of the block becomes less than or equal to the routine -C argument QUTOL, or the order becomes equal to ORD. -C IV. Arrange the obtained blocks in the AD, BD, CD and DD -C matrices and estimate the total order of D(s), TOTORD. -C V. Add the system I_f to the system obtained in IV. -C -C REFERENCES -C -C [1] Balas, G., Doyle, J., Glover, K., Packard, A. and Smith, R. -C Mu-analysis and Synthesis toolbox - User's Guide, -C The Mathworks Inc., Natick, MA, USA, 1998. -C -C CONTRIBUTORS -C -C Asparuh Markovski, Technical University of Sofia, July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C A. Markovski, V. Sima, October 2003. -C -C KEYWORDS -C -C Frequency response, H-infinity optimal control, robust control, -C structured singular value. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, THREE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ THREE = 3.0D+0 ) - INTEGER HNPTS - PARAMETER ( HNPTS = 2048 ) -C .. -C .. Scalar Arguments .. - INTEGER F, INFO, LDA, LDAD, LDB, LDBD, LDC, LDCD, LDD, - $ LDDD, LDWORK, LENDAT, LIWORK, LZWORK, MNB, MP, - $ NC, ORD, TOTORD - DOUBLE PRECISION QUTOL -C .. -C .. Array Arguments .. - INTEGER ITYPE(*), IWORK(*), NBLOCK(*) - DOUBLE PRECISION A(LDA, *), AD(LDAD, *), B(LDB, *), BD(LDBD, *), - $ C(LDC, *), CD(LDCD, *), D(LDD, *), DD(LDDD, *), - $ DWORK(*), MJU(*), OMEGA(*) - COMPLEX*16 ZWORK(*) -C .. -C .. Local Scalars .. - CHARACTER BALEIG, INITA - INTEGER CLWMAX, CORD, DLWMAX, I, IC, ICWRK, IDWRK, II, - $ INFO2, IWAD, IWB, IWBD, IWCD, IWDD, IWGJOM, - $ IWIFRD, IWRFRD, IWX, K, LCSIZE, LDSIZE, LORD, - $ LW1, LW2, LW3, LW4, LWA, LWB, MAXCWR, MAXWRK, - $ MN, W - DOUBLE PRECISION MAQE, MEQE, MOD1, MOD2, RCND, RCOND, RQE, TOL, - $ TOLER - COMPLEX*16 FREQ -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL AB13MD, DCOPY, DLACPY, DLASET, DSCAL, SB10YD, - $ TB05AD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DCMPLX, INT, MAX, MIN, SQRT -C -C Decode and test input parameters. -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C Workspace usage 1. -C -C real -C - IWX = 1 + MP*LENDAT - IWGJOM = IWX + 2*MNB - 1 - IDWRK = IWGJOM + MP - LDSIZE = LDWORK - IDWRK + 1 -C -C complex -C - IWB = MP*MP + 1 - ICWRK = IWB + NC*MP - LCSIZE = LZWORK - ICWRK + 1 -C - INFO = 0 - IF ( NC.LT.0 ) THEN - INFO = -1 - ELSE IF( MP.LT.0 ) THEN - INFO = -2 - ELSE IF( LENDAT.LT.2 ) THEN - INFO = -3 - ELSE IF( F.LT.0 ) THEN - INFO = -4 - ELSE IF( ORD.GT.LENDAT - 1 ) THEN - INFO = -5 - ELSE IF( MNB.LT.1 .OR. MNB.GT.MP ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, NC ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, NC ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, MP ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, MP ) ) THEN - INFO = -17 - ELSE IF( LDAD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDAD.LT.MP*ORD ) ) - $ THEN - INFO = -21 - ELSE IF( LDBD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDBD.LT.MP*ORD ) ) - $ THEN - INFO = -23 - ELSE IF( LDCD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDCD.LT.MP + F ) ) - $ THEN - INFO = -25 - ELSE IF( LDDD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDDD.LT.MP + F ) ) - $ THEN - INFO = -27 - ELSE -C -C Compute workspace. -C - II = MAX( NC, 4*MNB - 2, MP ) - MN = MIN( 2*LENDAT, 2*ORD + 1 ) - LWA = IDWRK - 1 - LWB = LENDAT*( MP + 2 ) + ORD*( ORD + 2 ) + 1 - LW1 = 2*LENDAT + 4*HNPTS - LW2 = LENDAT + 6*HNPTS - LW3 = 2*LENDAT*( 2*ORD + 1 ) + MAX( 2*LENDAT, 2*ORD + 1 ) + - $ MAX( MN + 6*ORD + 4, 2*MN + 1 ) - LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ) -C - DLWMAX = LWA + MAX( NC + MAX( NC, MP - 1 ), - $ 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + MP*MNB + - $ 11*MP + 33*MNB - 11 ) -C - CLWMAX = MAX( ICWRK - 1 + NC*NC + 2*NC, - $ 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ) -C - IF ( QUTOL.GE.ZERO ) THEN - II = MAX( II, 2*ORD + 1 ) - DLWMAX = MAX( DLWMAX, - $ LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ) ) - CLWMAX = MAX( CLWMAX, LENDAT*( 2*ORD + 3 ), - $ ORD*( ORD + 3 ) + 1 ) - END IF - IF ( LIWORK.LT.II ) THEN - INFO = -30 - ELSE IF ( LDWORK.LT.MAX( 3, DLWMAX ) ) THEN - INFO = -32 - ELSE IF ( LZWORK.LT.CLWMAX ) THEN - INFO = -34 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10MD', -INFO ) - RETURN - END IF -C - ORD = MAX( 1, ORD ) - TOTORD = 0 -C -C Quick return if possible. -C - IF( NC.EQ.0 .OR. MP.EQ.0 ) THEN - DWORK(1) = THREE - DWORK(2) = ZERO - DWORK(3) = ONE - RETURN - END IF -C - TOLER = SQRT( DLAMCH( 'Epsilon' ) ) -C - BALEIG = 'C' - RCOND = ONE - MAXCWR = CLWMAX -C -C @@@ 1. Estimate W(jw) for the closed-loop system, @@@ -C @@@ D(jw) and mju(jw) for each frequency. @@@ -C - DO 30 W = 1, LENDAT - FREQ = DCMPLX( ZERO, OMEGA(W) ) - IF ( W.EQ.1 ) THEN - INITA = 'G' - ELSE - INITA = 'H' - END IF -C -C Compute C*inv(jw*I-A)*B. -C Integer workspace: need NC. -C Real workspace: need LWA + NC + MAX(NC,MP-1); -C prefer larger, -C where LWA = MP*LENDAT + 2*MNB + MP - 1. -C Complex workspace: need MP*MP + NC*MP + NC*NC + 2*NC. -C - CALL TB05AD( BALEIG, INITA, NC, MP, MP, FREQ, A, LDA, B, LDB, - $ C, LDC, RCND, ZWORK, MP, DWORK, DWORK, ZWORK(IWB), - $ NC, IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), - $ LCSIZE, INFO2 ) -C - IF ( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - RCOND = MIN( RCOND, RCND ) - IF ( W.EQ.1 ) - $ MAXWRK = INT( DWORK(IDWRK) + IDWRK - 1 ) - IC = 0 -C -C D + C*inv(jw*I-A)*B -C - DO 20 K = 1, MP - DO 10 I = 1, MP - IC = IC + 1 - ZWORK(IC) = ZWORK(IC) + DCMPLX ( D(I,K), ZERO ) - 10 CONTINUE - 20 CONTINUE -C -C Estimate D(jw) and mju(jw). -C Integer workspace: need MAX(4*MNB-2,MP). -C Real workspace: need LWA + 2*MP*MP*MNB - MP*MP + 9*MNB*MNB -C + MP*MNB + 11*MP + 33*MNB - 11; -C prefer larger. -C Complex workspace: need 6*MP*MP*MNB + 13*MP*MP + 6*MNB + -C 6*MP - 3. -C - CALL AB13MD( 'N', MP, ZWORK, MP, MNB, NBLOCK, ITYPE, - $ DWORK(IWX), MJU(W), DWORK((W-1)*MP+1), - $ DWORK(IWGJOM), IWORK, DWORK(IDWRK), LDSIZE, - $ ZWORK(IWB), LZWORK-IWB+1, INFO2 ) -C - IF ( INFO2.NE.0 ) THEN - INFO = INFO2 + 1 - RETURN - END IF -C - IF ( W.EQ.1 ) THEN - MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1 ) - MAXCWR = MAX( MAXCWR, INT( ZWORK(IWB) ) + IWB - 1 ) - END IF -C -C Normalize D(jw) through it's last entry. -C - IF ( DWORK(W*MP).NE.ZERO ) - $ CALL DSCAL( MP, ONE/DWORK(W*MP), DWORK((W-1)*MP+1), 1 ) -C - 30 CONTINUE -C -C Quick return if needed. -C - IF ( QUTOL.LT.ZERO ) THEN - DWORK(1) = MAXWRK - DWORK(2) = MAXCWR - DWORK(3) = RCOND - RETURN - END IF -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C Workspace usage 2. -C -C real -C - IWRFRD = IWX - IWIFRD = IWRFRD + LENDAT - IWAD = IWIFRD + LENDAT - IWBD = IWAD + ORD*ORD - IWCD = IWBD + ORD - IWDD = IWCD + ORD - IDWRK = IWDD + 1 - LDSIZE = LDWORK - IDWRK + 1 -C -C complex -C - ICWRK = ORD + 2 - LCSIZE = LZWORK - ICWRK + 1 - INITA = 'H' -C -C Use default tolerance for SB10YD. -C - TOL = -ONE -C -C @@@ 2. Clear imag parts of D(jw) for SB10YD. @@@ -C - DO 40 I = 1, LENDAT - DWORK(IWIFRD+I-1) = ZERO - 40 CONTINUE -C -C @@@ 3. Clear AD, BD, CD and initialize DD with I_(mp+f). @@@ -C - CALL DLASET( 'Full', MP*ORD, MP*ORD, ZERO, ZERO, AD, LDAD ) - CALL DLASET( 'Full', MP*ORD, MP+F, ZERO, ZERO, BD, LDBD ) - CALL DLASET( 'Full', MP+F, MP*ORD, ZERO, ZERO, CD, LDCD ) - CALL DLASET( 'Full', MP+F, MP+F, ZERO, ONE, DD, LDDD ) -C -C @@@ 4. Block by block frequency identification. @@@ -C - DO 80 II = 1, MP -C - CALL DCOPY( LENDAT, DWORK(II), MP, DWORK(IWRFRD), 1 ) -C -C Increase CORD from 1 to ORD for every block, if needed. -C - CORD = 1 -C - 50 CONTINUE - LORD = CORD -C -C Now, LORD is the desired order. -C Integer workspace: need 2*N+1, where N = LORD. -C Real workspace: need LWB + MAX( 2, LW1, LW2, LW3, LW4), -C where -C LWB = LENDAT*(MP+2) + -C ORD*(ORD+2) + 1, -C HNPTS = 2048, and -C LW1 = 2*LENDAT + 4*HNPTS; -C LW2 = LENDAT + 6*HNPTS; -C MN = min( 2*LENDAT, 2*N+1 ) -C LW3 = 2*LENDAT*(2*N+1) + -C max( 2*LENDAT, 2*N+1 ) + -C max( MN + 6*N + 4, 2*MN+1 ); -C LW4 = max( N*N + 5*N, -C 6*N + 1 + min( 1,N ) ); -C prefer larger. -C Complex workspace: need LENDAT*(2*N+3). -C - CALL SB10YD( 0, 1, LENDAT, DWORK(IWRFRD), DWORK(IWIFRD), - $ OMEGA, LORD, DWORK(IWAD), ORD, DWORK(IWBD), - $ DWORK(IWCD), DWORK(IWDD), TOL, IWORK, - $ DWORK(IDWRK), LDSIZE, ZWORK, LZWORK, INFO2 ) -C -C At this point, LORD is the actual order reached by SB10YD, -C 0 <= LORD <= CORD. -C [ADi,BDi; CDi,DDi] is a minimal realization with ADi in -C upper Hessenberg form. -C The leading LORD-by-LORD part of ORD-by-ORD DWORK(IWAD) -C contains ADi, the leading LORD-by-1 part of ORD-by-1 -C DWORK(IWBD) contains BDi, the leading 1-by-LORD part of -C 1-by-ORD DWORK(IWCD) contains CDi, DWORK(IWDD) contains DDi. -C - IF ( INFO2.NE.0 ) THEN - INFO = 10 + INFO2 - RETURN - END IF -C -C Compare the original D(jw) with the fitted one. -C - MEQE = ZERO - MAQE = ZERO -C - DO 60 W = 1, LENDAT - FREQ = DCMPLX( ZERO, OMEGA(W) ) -C -C Compute CD*inv(jw*I-AD)*BD. -C Integer workspace: need LORD. -C Real workspace: need LWB + 2*LORD; -C prefer larger. -C Complex workspace: need 1 + ORD + LORD*LORD + 2*LORD. -C - CALL TB05AD( BALEIG, INITA, LORD, 1, 1, FREQ, - $ DWORK(IWAD), ORD, DWORK(IWBD), ORD, - $ DWORK(IWCD), 1, RCND, ZWORK, 1, - $ DWORK(IDWRK), DWORK(IDWRK), ZWORK(2), ORD, - $ IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), - $ LCSIZE, INFO2 ) -C - IF ( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - RCOND = MIN( RCOND, RCND ) - IF ( W.EQ.1 ) - $ MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1) -C -C DD + CD*inv(jw*I-AD)*BD -C - ZWORK(1) = ZWORK(1) + DCMPLX( DWORK(IWDD), ZERO ) -C - MOD1 = ABS( DWORK(IWRFRD+W-1) ) - MOD2 = ABS( ZWORK(1) ) - RQE = ABS( ( MOD1 - MOD2 )/( MOD1 + TOLER ) ) - MEQE = MEQE + RQE - MAQE = MAX( MAQE, RQE ) -C - 60 CONTINUE -C - MEQE = MEQE/LENDAT -C - IF ( ( ( MEQE + MAQE )/TWO.LE.QUTOL ) .OR. - $ ( CORD.EQ.ORD ) ) THEN - GOTO 70 - END IF -C - CORD = CORD + 1 - GOTO 50 -C - 70 TOTORD = TOTORD + LORD -C -C Copy ad(ii), bd(ii) and cd(ii) to AD, BD and CD, respectively. -C - CALL DLACPY( 'Full', LORD, LORD, DWORK(IWAD), ORD, - $ AD(TOTORD-LORD+1,TOTORD-LORD+1), LDAD ) - CALL DCOPY( LORD, DWORK(IWBD), 1, BD(TOTORD-LORD+1,II), 1 ) - CALL DCOPY( LORD, DWORK(IWCD), 1, CD(II,TOTORD-LORD+1), LDCD ) -C -C Copy dd(ii) to DD. -C - DD(II,II) = DWORK(IWDD) -C - 80 CONTINUE -C - DWORK(1) = MAXWRK - DWORK(2) = MAXCWR - DWORK(3) = RCOND - RETURN -C -C *** Last line of SB10MD *** - END diff --git a/slycot/src/SB10PD.f b/slycot/src/SB10PD.f deleted file mode 100644 index 617bdd29..00000000 --- a/slycot/src/SB10PD.f +++ /dev/null @@ -1,505 +0,0 @@ - SUBROUTINE SB10PD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices D12 and D21 of the linear time-invariant -C system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C to unit diagonal form, to transform the matrices B, C, and D11 to -C satisfy the formulas in the computation of an H2 and H-infinity -C (sub)optimal controllers and to check the rank conditions. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading NP-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading NP-by-N part of this array contains -C the transformed system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading NP-by-M part of this array must -C contain the system input/output matrix D. The -C NMEAS-by-NCON trailing submatrix D22 is not referenced. -C On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this -C array contains the transformed submatrix D11. -C The transformed submatrices D12 = [ 0 Im2 ]' and -C D21 = [ 0 Inp2 ] are not stored. The corresponding part -C of this array contains no useful information. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array contains the -C control transformation matrix TU. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array contains the -C measurement transformation matrix TY. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C RCOND (output) DOUBLE PRECISION array, dimension (2) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix TU; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix TY. -C RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3, -C then RCOND(2) was not computed, but it is set to 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations. Transformation matrices TU and TY whose -C reciprocal condition numbers are less than TOL are not -C allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1,LW1,LW2,LW3,LW4), where -C LW1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), -C LW2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), -C LW3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), -C LW4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), -C with M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix | A B2 | had not full column rank -C | C1 D12 | -C in respect to the tolerance EPS; -C = 2: if the matrix | A B1 | had not full row rank in -C | C2 D21 | -C respect to the tolerance EPS; -C = 3: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 4: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 5: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of one of -C the matrices |A B2 |, |A B1 |, D12 or D21). -C |C1 D12| |C2 D21| -C -C METHOD -C -C The routine performs the transformations described in [2]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The precision of the transformations can be controlled by the -C condition numbers of the matrices TU and TY as given by the -C values of RCOND(1) and RCOND(2), respectively. An error return -C with INFO = 3 or INFO = 4 will be obtained if the condition -C number of TU or TY, respectively, would exceed 1/TOL. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Feb. 2000. -C -C KEYWORDS -C -C H-infinity optimal control, robust control, singular value -C decomposition. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDTU, LDTY, LDWORK, - $ M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), RCOND( 2 ), - $ TU( LDTU, * ), TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER IEXT, INFO2, IQ, IWRK, J, LWAMAX, M1, M2, - $ MINWRK, ND1, ND2, NP1, NP2 - DOUBLE PRECISION EPS, TOLL -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -15 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -17 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, - $ ( N + NP1 + 1 )*( N + M2 ) + - $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), - $ ( N + NP2 )*( N + M1 + 1 ) + - $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), - $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, - $ 5*M2 ), - $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, - $ 5*NP2 ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -21 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - EPS = DLAMCH( 'Epsilon' ) - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for condition tests. -C - TOLL = SQRT( EPS ) - END IF -C -C Determine if |A-jwI B2 | has full column rank at w = 0. -C | C1 D12| -C Workspace: need (N+NP1+1)*(N+M2) + -C max(3*(N+M2)+N+NP1,5*(N+M2)); -C prefer larger. -C - IEXT = N + M2 + 1 - IWRK = IEXT + ( N + NP1 )*( N + M2 ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP1 ) - CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( IEXT+N ), N+NP1 ) - CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, - $ DWORK( IEXT+(N+NP1)*N ), N+NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( IEXT+(N+NP1)*N+N ), N+NP1 ) - CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK( IEXT ), N+NP1, DWORK, - $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - IF( DWORK( N+M2 )/DWORK( 1 ).LE.EPS ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Determine if |A-jwI B1 | has full row rank at w = 0. -C | C2 D21| -C Workspace: need (N+NP2)*(N+M1+1) + -C max(3*(N+NP2)+N+M1,5*(N+NP2)); -C prefer larger. -C - IEXT = N + NP2 + 1 - IWRK = IEXT + ( N + NP2 )*( N + M1 ) - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP2 ) - CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( IEXT+N ), - $ N+NP2 ) - CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IEXT+(N+NP2)*N ), - $ N+NP2 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( IEXT+(N+NP2)*N+N ), N+NP2 ) - CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK( IEXT ), N+NP2, DWORK, - $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - IF( DWORK( N+NP2 )/DWORK( 1 ).LE.EPS ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has -C full column rank. V12' is stored in TU. -C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); -C prefer larger. -C - IQ = M2 + 1 - IWRK = IQ + NP1*NP1 -C - CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, - $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF -C - RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) - IF( RCOND( 1 ).LE.TOLL ) THEN - RCOND( 2 ) = ZERO - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine Q12. -C - IF( ND1.GT.0 ) THEN - CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), - $ LDD ) - CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, - $ DWORK( IQ ), NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( IQ+NP1*ND1 ), NP1 ) - END IF -C -C Determine Tu by transposing in-situ and scaling. -C - DO 10 J = 1, M2 - 1 - CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) - 10 CONTINUE -C - DO 20 J = 1, M2 - CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) - 20 CONTINUE -C -C Determine C1 =: Q12'*C1. -C Workspace: M2 + NP1*NP1 + NP1*N. -C - CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) - LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) -C -C Determine D11 =: Q12'*D11. -C Workspace: M2 + NP1*NP1 + NP1*M1. -C - CALL DGEMM( 'T', 'N', NP1, M1, NP1, ONE, DWORK( IQ ), NP1, D, LDD, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) - LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) -C -C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has -C full row rank. U21 is stored in TY. -C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); -C prefer larger. -C - IQ = NP2 + 1 - IWRK = IQ + M1*M1 -C - CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, - $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF -C - RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) - IF( RCOND( 2 ).LE.TOLL ) THEN - INFO = 4 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine Q21. -C - IF( ND2.GT.0 ) THEN - CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), - $ LDD ) - CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), - $ M1 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( IQ+ND2 ), M1 ) - END IF -C -C Determine Ty by scaling and transposing in-situ. -C - DO 30 J = 1, NP2 - CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) - 30 CONTINUE -C - DO 40 J = 1, NP2 - 1 - CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) - 40 CONTINUE -C -C Determine B1 =: B1*Q21'. -C Workspace: NP2 + M1*M1 + N*M1. -C - CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, - $ ZERO, DWORK( IWRK ), N ) - CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) - LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) -C -C Determine D11 =: D11*Q21'. -C Workspace: NP2 + M1*M1 + NP1*M1. -C - CALL DGEMM( 'N', 'T', NP1, M1, M1, ONE, D, LDD, DWORK( IQ ), M1, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) - LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) -C -C Determine B2 =: B2*Tu. -C Workspace: N*M2. -C - CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, - $ ZERO, DWORK, N ) - CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) -C -C Determine C2 =: Ty*C2. -C Workspace: NP2*N. -C - CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, - $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) - CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) -C - LWAMAX = MAX( N*MAX( M2, NP2 ), LWAMAX ) - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10PD *** - END diff --git a/slycot/src/SB10QD.f b/slycot/src/SB10QD.f deleted file mode 100644 index 6b64f839..00000000 --- a/slycot/src/SB10QD.f +++ /dev/null @@ -1,602 +0,0 @@ - SUBROUTINE SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, F, LDF, H, LDH, X, LDX, Y, LDY, - $ XYCOND, IWORK, DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the state feedback and the output injection -C matrices for an H-infinity (sub)optimal n-state controller, -C using Glover's and Doyle's 1988 formulas, for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 D22 | -C -C and for a given value of gamma, where B2 has as column size the -C number of control inputs (NCON) and C2 has as row size the number -C of measurements (NMEAS) being provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank with D12 = | 0 | and D21 is -C | I | -C full row rank with D21 = | 0 I | as obtained by the -C subroutine SB10PD, -C -C (A3) | A-j*omega*I B2 | has full column rank for all omega, -C | C1 D12 | -C -C -C (A4) | A-j*omega*I B1 | has full row rank for all omega. -C | C2 D21 | -C -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array contains the state -C feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,M). -C -C H (output) DOUBLE PRECISION array, dimension (LDH,NP) -C The leading N-by-NP part of this array contains the output -C injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the matrix -C Y, solution of the Y-Riccati equation. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C XYCOND (output) DOUBLE PRECISION array, dimension (2) -C XYCOND(1) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C XYCOND(2) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*max(N,M-NCON,NP-NMEAS),N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(1,M*M + max(2*M1,3*N*N + -C max(N*M,10*N*N+12*N+5)), -C NP*NP + max(2*NP1,3*N*N + -C max(N*NP,10*N*N+12*N+5))), -C where M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the controller is not admissible (too small value -C of gamma); -C = 2: if the X-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties); -C = 3: if the Y-Riccati equation was not solved -C successfully (the controller is not admissible or -C there are numerical difficulties). -C -C METHOD -C -C The routine implements the Glover's and Doyle's formulas [1],[2] -C modified as described in [3]. The X- and Y-Riccati equations -C are solved with condition and accuracy estimates [4]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of continuous-time -C linear control systems. -C Rep. 98-14, Department of Engineering, Leicester University, -C Leicester, U.K., 1998. -C -C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortan 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C -C The precision of the solution of the matrix Riccati equations -C can be controlled by the values of the condition numbers -C XYCOND(1) and XYCOND(2) of these equations. -C -C FURTHER COMMENTS -C -C The Riccati equations are solved by the Schur approach -C implementing condition and accuracy estimates. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK, - $ LDX, LDY, M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ), DWORK( * ), F( LDF, * ), - $ H( LDH, * ), X( LDX, * ), XYCOND( 2 ), - $ Y( LDY, * ) - LOGICAL BWORK( * ) -C -C .. -C .. Local Scalars .. - INTEGER INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS, - $ IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, - $ NN, NP1, NP2 - DOUBLE PRECISION ANORM, EPS, FERR, RCOND, SEP -C .. -C .. External Functions .. -C - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK, - $ DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS - NN = N*N -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -20 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN + - $ MAX( N*M, 10*NN + 12*N + 5 ) ), - $ NP*NP + MAX( 2*NP1, 3*NN + - $ MAX( N*NP, 10*NN + 12*N + 5 ) ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -26 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - XYCOND( 1 ) = ONE - XYCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF - ND1 = NP1 - M2 - ND2 = M1 - NP2 - N2 = 2*N -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Workspace usage. -C - IWA = M*M + 1 - IWQ = IWA + NN - IWG = IWQ + NN - IW2 = IWG + NN -C -C Compute |D1111'||D1111 D1112| - gamma^2*Im1 . -C |D1112'| -C - CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M ) - IF( ND1.GT.0 ) - $ CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M ) -C -C Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . -C |D1112'| -C - IWRK = IWA - ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) ) - CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 - CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( M1+1 ), INFO2 ) - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(R) block by block. -C - CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 ) -C -C Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . -C |D1112'| -C - CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD, - $ ZERO, DWORK( M1+1 ), M ) -C -C Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| - -C |D1112'| -C -C gamma^2*Im1)*|D1121'| + Im2 . -C |D1122'| -C - CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M ) - CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE, - $ DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD, - $ DWORK( M1+1 ), M, INFO2 ) -C -C Compute D11'*C1 . -C - CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO, - $ DWORK( IW2 ), M ) -C -C Compute D1D'*C1 . -C - CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ), - $ M ) -C -C Compute inv(R)*D1D'*C1 in F . -C - CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO, - $ F, LDF ) -C -C Compute Ax = A - B*inv(R)*D1D'*C1 . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) - CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE, - $ DWORK( IWA ), N ) -C -C Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 . -C - IF( ND1.EQ.0 ) THEN - CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - ELSE - CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO, - $ DWORK( IWQ ), N ) - CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE, - $ DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 ) - END IF -C -C Compute Dx = B*inv(R)*B' . -C - IWRK = IW2 - CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE, - $ DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ), - $ M*N, INFO2 ) -C -C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . -C Workspace: need M*M + 13*N*N + 12*N + 5; -C prefer larger. -C - IWT = IW2 - IWV = IWT + NN - IWR = IWV + NN - IWI = IWR + N2 - IWS = IWI + N2 - IWRK = IWS + 4*NN -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', - $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute F = -inv(R)*|D1D'*C1 + B'*X| . -C - IWRK = IW2 - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO, - $ DWORK( IWRK ), M ) - CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M, - $ -ONE, F, LDF ) -C -C Workspace usage. -C - IWA = NP*NP + 1 - IWQ = IWA + NN - IWG = IWQ + NN - IW2 = IWG + NN -C -C Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 . -C |D1121| -C - CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP ) - IF( ND2.GT.0 ) - $ CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP ) -C -C Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) . -C |D1121| -C - IWRK = IWA - ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) ) - CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) - CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( NP1+1 ), INFO2 ) - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(RT) . -C - CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 ) -C -C Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| . -C |D1121| |D1122| -C - CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ), - $ LDD, ZERO, DWORK( NP1*NP+1 ), NP ) -C -C Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| - -C |D1121| -C -C gamma^2*Inp1)*|D1112| + Inp2 . -C |D1122| -C - CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ), - $ NP ) - CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE, - $ DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD, - $ DWORK( NP1*NP+1 ), NP, INFO2 ) -C -C Compute B1*D11' . -C - CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO, - $ DWORK( IW2 ), N ) -C -C Compute B1*DD1' . -C - CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, - $ DWORK( IW2+NP1*N ), N ) -C -C Compute B1*DD1'*inv(RT) in H . -C - CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N, - $ ZERO, H, LDH ) -C -C Compute Ay = A - B1*DD1'*inv(RT)*C . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) - CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE, - $ DWORK( IWA ), N ) -C -C Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' . -C - IF( ND2.EQ.0 ) THEN - CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - ELSE - CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ), - $ N ) - CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE, - $ DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 ) - END IF -C -C Compute Dy = C'*inv(RT)*C . -C - IWRK = IW2 - CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ), - $ N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 ) -C -C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . -C Workspace: need NP*NP + 13*N*N + 12*N + 5; -C prefer larger. -C - IWT = IW2 - IWV = IWT + NN - IWR = IWV + NN - IWI = IWR + N2 - IWS = IWI + N2 - IWRK = IWS + 4*NN -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', - $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute H = -|B1*DD1' + Y*C'|*inv(RT) . -C - IWRK = IW2 - CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO, - $ DWORK( IWRK ), N ) - CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N, - $ -ONE, H, LDH ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10QD *** - END diff --git a/slycot/src/SB10RD.f b/slycot/src/SB10RD.f deleted file mode 100644 index 86d483bb..00000000 --- a/slycot/src/SB10RD.f +++ /dev/null @@ -1,706 +0,0 @@ - SUBROUTINE SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, - $ C, LDC, D, LDD, F, LDF, H, LDH, TU, LDTU, TY, - $ LDTY, X, LDX, Y, LDY, AK, LDAK, BK, LDBK, CK, - $ LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of an H-infinity (sub)optimal controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C from the state feedback matrix F and output injection matrix H as -C determined by the SLICOT Library routine SB10QD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C GAMMA (input) DOUBLE PRECISION -C The value of gamma. It is assumed that gamma is -C sufficiently large so that the controller is admissible. -C GAMMA >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C F (input) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array must contain the -C state feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,NP) -C The leading N-by-NP part of this array must contain the -C output injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array must contain the -C control transformation matrix TU, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array must contain the -C measurement transformation matrix TY, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array must contain the -C matrix X, solution of the X-Riccati equation, as obtained -C by the SLICOT Library routine SB10QD. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (input) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array must contain the -C matrix Y, solution of the Y-Riccati equation, as obtained -C by the SLICOT Library routine SB10QD. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK), where -C LIWORK = max(2*(max(NP,M)-M2-NP2,M2,N),NP2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(1, M2*NP2 + NP2*NP2 + M2*M2 + -C max(D1*D1 + max(2*D1, (D1+D2)*NP2), -C D2*D2 + max(2*D2, D2*M2), 3*N, -C N*(2*NP2 + M2) + -C max(2*N*M2, M2*NP2 + -C max(M2*M2+3*M2, NP2*(2*NP2+ -C M2+max(NP2,N)))))) -C where D1 = NP1 - M2, D2 = M1 - NP2, -C NP1 = NP - NP2, M1 = M - M2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is -C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the controller is not admissible (too small value -C of gamma); -C = 2: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero. -C -C METHOD -C -C The routine implements the Glover's and Doyle's formulas [1],[2]. -C -C REFERENCES -C -C [1] Glover, K. and Doyle, J.C. -C State-space formulae for all stabilizing controllers that -C satisfy an Hinf norm bound and relations to risk sensitivity. -C Systems and Control Letters, vol. 11, pp. 167-172, 1988. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Sept. 1999, Oct. 2001. -C -C KEYWORDS -C -C Algebraic Riccati equation, H-infinity optimal control, robust -C control. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDF, LDH, LDTU, LDTY, LDWORK, LDX, LDY, - $ M, N, NCON, NMEAS, NP - DOUBLE PRECISION GAMMA -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ F( LDF, * ), H( LDH, * ), TU( LDTU, * ), - $ TY( LDTY, * ), X( LDX, * ), Y( LDY, * ) -C .. -C .. Local Scalars .. - INTEGER I, ID11, ID12, ID21, IJ, INFO2, IW1, IW2, IW3, - $ IW4, IWB, IWC, IWRK, J, LWAMAX, M1, M2, MINWRK, - $ ND1, ND2, NP1, NP2 - DOUBLE PRECISION ANORM, EPS, RCOND -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DGETRS, DLACPY, - $ DLASET, DPOTRF, DSYCON, DSYRK, DSYTRF, DSYTRS, - $ DTRMM, MA02AD, MB01RX, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( GAMMA.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -14 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -16 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -18 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -20 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -22 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -28 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -30 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -32 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -34 - ELSE -C -C Compute workspace. -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - MINWRK = MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + - $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), - $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, - $ N*( 2*NP2 + M2 ) + - $ MAX( 2*N*M2, M2*NP2 + - $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + - $ M2 + MAX( NP2, N ) ) ) ) ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -37 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C -C Get the machine precision. -C - EPS = DLAMCH( 'Epsilon' ) -C -C Workspace usage. -C - ID11 = 1 - ID21 = ID11 + M2*NP2 - ID12 = ID21 + NP2*NP2 - IW1 = ID12 + M2*M2 - IW2 = IW1 + ND1*ND1 - IW3 = IW2 + ND1*NP2 - IWRK = IW2 -C -C Set D11HAT := -D1122 . -C - IJ = ID11 - DO 20 J = 1, NP2 - DO 10 I = 1, M2 - DWORK( IJ ) = -D( ND1+I, ND2+J ) - IJ = IJ + 1 - 10 CONTINUE - 20 CONTINUE -C -C Set D21HAT := Inp2 . -C - CALL DLASET( 'Upper', NP2, NP2, ZERO, ONE, DWORK( ID21 ), NP2 ) -C -C Set D12HAT := Im2 . -C - CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( ID12 ), M2 ) -C -C Compute D11HAT, D21HAT, D12HAT . -C - LWAMAX = 0 - IF( ND1.GT.0 ) THEN - IF( ND2.EQ.0 ) THEN -C -C Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 . -C - CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE, - $ DWORK( ID21 ), NP2 ) - ELSE -C -C Compute gdum = gamma^2*Ind1 - D1111*D1111' . -C - CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ), - $ ND1 ) - CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE, - $ DWORK( IW1 ), ND1 ) - ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1, - $ DWORK( IWRK ) ) - CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 - CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM, - $ RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(gdum)*D1112 . -C - CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD, - $ DWORK( IW2 ), ND1 ) - CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK, - $ DWORK( IW2 ), ND1, INFO2 ) -C -C Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 . -C - CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD, - $ DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 ) - CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ), - $ LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 ) -C -C Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 . -C - CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE, - $ -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD, - $ DWORK( IW2 ), ND1, INFO2 ) -C - IW2 = IW1 + ND2*ND2 - IWRK = IW2 -C -C Compute gdum = gamma^2*Ind2 - D1111'*D1111 . -C - CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ), - $ ND2 ) - CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE, - $ DWORK( IW1 ), ND2 ) - ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2, - $ DWORK( IWRK ) ) - CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) - CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM, - $ RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C -C Compute inv(gdum)*D1121' . -C - CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD, - $ DWORK( IW2 ), ND2 ) - CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK, - $ DWORK( IW2 ), ND2, INFO2 ) -C -C Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' . -C - CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE, - $ -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD, - $ DWORK( IW2 ), ND2, INFO2 ) - END IF - ELSE - IF( ND2.GT.0 ) THEN -C -C Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 . -C - CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE, - $ DWORK( ID12 ), M2 ) - END IF - END IF -C -C Compute D21HAT using Cholesky decomposition. -C - CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C -C Compute D12HAT using Cholesky decomposition. -C - CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C _ -C Compute Z = In - Y*X/gamma^2 and its LU factorization in AK . -C - IWRK = IW1 - CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX, - $ ONE, AK, LDAK ) - ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) ) - CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ), - $ IWORK( N+1 ), INFO ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 1 - RETURN - END IF -C - IWB = IW1 - IWC = IWB + N*NP2 - IW1 = IWC + ( M2 + NP2 )*N - IW2 = IW1 + N*M2 -C -C Compute C2' + F12' in BK . -C - DO 40 J = 1, N - DO 30 I = 1, NP2 - BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J ) - 30 CONTINUE - 40 CONTINUE -C _ -C Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) . -C - CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK, - $ INFO2 ) -C -C Compute the transpose of F2*Z . -C - CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N ) - CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N, - $ INFO2 ) -C -C Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z . -C - CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ), - $ M2, ONE, DWORK( IW1 ), N ) -C -C Compute CHAT . -C - CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N, - $ ZERO, DWORK( IWC ), M2+NP2 ) - CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 ) - CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2, - $ DWORK( IWC+M2 ), M2+NP2 ) -C -C Compute B2 + H12 . -C - IJ = IW2 - DO 60 J = 1, M2 - DO 50 I = 1, N - DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J ) - IJ = IJ + 1 - 50 CONTINUE - 60 CONTINUE -C -C Compute A + HC in AK . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK, - $ LDAK ) -C -C Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK . -C - CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N, - $ DWORK( IW1 ), N, ONE, AK, LDAK ) -C -C Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK . -C - CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK ) - CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N, - $ DWORK( ID11 ), M2, -ONE, BK, LDBK ) -C -C Compute the first block of BHAT, BHAT1 . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, - $ DWORK( IWB ), N ) -C -C Compute Tu*D11HAT . -C - CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ), - $ M2, ZERO, DWORK( IW1 ), M2 ) -C -C Compute Tu*D11HAT*Ty in DK . -C - CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY, - $ LDTY, ZERO, DK, LDDK ) -C -C Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition. -C - IW2 = IW1 + M2*NP2 - IWRK = IW2 + M2*M2 - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) - CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, - $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, - $ DWORK( IWRK ), IWORK( M2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.EPS ) THEN - INFO = 2 - RETURN - END IF -C -C Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) . -C - CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) - CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK, - $ LDCK, INFO2 ) -C -C Find the controller matrices AK, BK, and DK, exploiting the -C special structure of the relations. -C -C Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization. -C - IW3 = IW2 + NP2*NP2 - IW4 = IW3 + NP2*M2 - IWRK = IW4 + NP2*NP2 - CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD, - $ DK, LDDK, ONE, DWORK( IW2 ), NP2 ) - CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C -C Compute A1 = inv(Q)*D22 and inv(Q) . -C - CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ), - $ NP2 ) - CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK, - $ DWORK( IW3 ), NP2, INFO2 ) - CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) - -C A1*Tu*D11HAT )*inv(D21HAT) . -C - CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 ) - CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 ) - CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) -C - CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ), - $ NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2, - $ DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 ) - CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2, - $ DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 ) - CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2, - $ DWORK( IW4 ), NP2 ) -C -C Compute [ A1 A2 ]*CHAT . -C - CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2, - $ DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 ) -C -C Compute AK := AHAT - BHAT1*[ A1 A2 ]*CHAT . -C - CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N, - $ DWORK( IWRK ), NP2, ONE, AK, LDAK ) -C -C Compute BK := BHAT1*inv(Q) . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N, - $ DWORK( IW2 ), NP2, ZERO, BK, LDBK ) -C -C Compute DK := Tu*D11HAT*Ty*inv(Q) . -C - CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ), - $ NP2, ZERO, DWORK( IW3 ), M2 ) - CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10RD *** - END diff --git a/slycot/src/SB10SD.f b/slycot/src/SB10SD.f deleted file mode 100644 index ee99c78f..00000000 --- a/slycot/src/SB10SD.f +++ /dev/null @@ -1,629 +0,0 @@ - SUBROUTINE SB10SD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ X, LDX, Y, LDY, RCOND, TOL, IWORK, DWORK, - $ LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C for the normalized discrete-time system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | D11 D12 | | C | D | -C | C2 | D21 0 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank with D12 = | 0 | and D21 is -C | I | -C full row rank with D21 = | 0 I | as obtained by the -C SLICOT Library routine SB10PD, -C -C j*Theta -C (A3) | A-e *I B2 | has full column rank for all -C | C1 D12 | -C -C 0 <= Theta < 2*Pi , -C -C -C j*Theta -C (A4) | A-e *I B1 | has full row rank for all -C | C2 D21 | -C -C 0 <= Theta < 2*Pi . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. Only the leading -C (NP-NP2)-by-(M-M2) submatrix D11 is used. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the matrix -C Y, solution of the Y-Riccati equation. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C RCOND (output) DOUBLE PRECISION array, dimension (4) -C RCOND contains estimates of the reciprocal condition -C numbers of the matrices which are to be inverted and the -C reciprocal condition numbers of the Riccati equations -C which have to be solved during the computation of the -C controller. (See the description of the algorithm in [2].) -C RCOND(1) contains the reciprocal condition number of the -C matrix Im2 + B2'*X2*B2; -C RCOND(2) contains the reciprocal condition number of the -C matrix Ip2 + C2*Y2*C2'; -C RCOND(3) contains the reciprocal condition number of the -C X-Riccati equation; -C RCOND(4) contains the reciprocal condition number of the -C Y-Riccati equation. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used in determining the nonsingularity of the -C matrices which must be inverted. If TOL <= 0, then a -C default value equal to sqrt(EPS) is used, where EPS is the -C relative machine precision. -C -C Workspace -C -C IWORK INTEGER array, dimension max(M2,2*N,N*N,NP2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(1, 14*N*N+6*N+max(14*N+23,16*N), -C M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)), -C where M1 = M - M2. -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the X-Riccati equation was not solved -C successfully; -C = 2: if the matrix Im2 + B2'*X2*B2 is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL); -C = 3: if the Y-Riccati equation was not solved -C successfully; -C = 4: if the matrix Ip2 + C2*Y2*C2' is not positive -C definite, or it is numerically singular (with -C respect to the tolerance TOL). -C -C METHOD -C -C The routine implements the formulas given in [1]. The X- and -C Y-Riccati equations are solved with condition estimates. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C matrices which are to be inverted and on the condition numbers of -C the matrix Riccati equations which are to be solved in the -C computation of the controller. (The corresponding reciprocal -C condition numbers are given in the output array RCOND.) -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C January 2003. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, LDX, LDY, M, N, NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( * ), X( LDX, * ), Y( LDY, * ) - LOGICAL BWORK( * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IW2, IWB, IWC, IWG, IWI, IWQ, IWR, IWRK, - $ IWS, IWT, IWU, IWV, J, LWAMAX, M1, M2, MINWRK, - $ ND1, ND2, NP1, NP2 - DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL -C .. -C .. External functions .. - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DPOCON, DPOTRF, DPOTRS, - $ DSWAP, DSYRK, DTRSM, MB01RX, SB02OD, SB02SD, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -21 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -23 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, 14*N*N + 6*N + MAX( 14*N + 23, 16*N ), - $ M2*( N + M2 + MAX( 3, M1 ) ), NP2*( N + NP2 + 3 ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -30 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10SD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for nonsingularity test. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Workspace usage. -C - IWQ = 1 - IWG = IWQ + N*N - IWR = IWG + N*N - IWI = IWR + 2*N - IWB = IWI + 2*N - IWS = IWB + 2*N - IWT = IWS + 4*N*N - IWU = IWT + 4*N*N - IWRK = IWU + 4*N*N - IWC = IWR - IWV = IWC + N*N -C -C Compute Ax = A - B2*D12'*C1 in AK . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, - $ C( ND1+1, 1), LDC, ONE, AK, LDAK ) -C -C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . -C - IF( ND1.GT.0 ) THEN - CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dx = B2*B2' . -C - CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the discrete-time Riccati equation -C Ax'*inv(In + X2*Dx)*X2*Ax - X2 + Cx = 0 . -C Workspace: need 14*N*N + 6*N + max(14*N+23,16*N); -C prefer larger. -C - CALL SB02OD( 'D', 'G', 'N', 'L', 'Z', 'S', N, M2, NP1, AK, LDAK, - $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, - $ DWORK( IWRK ), N, RCOND2, X, LDX, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, - $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Condition estimation. -C Workspace: need 4*N*N + max(N*N+5*N,max(3,2*N*N)+N*N); -C prefer larger. -C - IWRK = IWV + N*N - CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, AK, LDAK, DWORK( IWC ), - $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ X, LDX, SEPD, RCOND( 3 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 3 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IW2 = M2*N + 1 - IWRK = IW2 + M2*M2 -C -C Compute B2'*X2 . -C - CALL DGEMM( 'T', 'N', M2, N, N, ONE, B( 1, M1+1 ), LDB, X, LDX, - $ ZERO, DWORK, M2 ) -C -C Compute Im2 + B2'*X2*B2 . -C - CALL DLASET( 'L', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) - CALL MB01RX( 'Left', 'Lower', 'N', M2, N, ONE, ONE, DWORK( IW2 ), - $ M2, DWORK, M2, B( 1, M1+1 ), LDB, INFO2 ) -C -C Compute the Cholesky factorization of Im2 + B2'*X2*B2 . -C Workspace: need M2*N + M2*M2 + max(3*M2,M2*M1); -C prefer larger. -C - ANORM = DLANSY( 'I', 'L', M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) - CALL DPOTRF( 'L', M2, DWORK( IW2 ), M2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF - CALL DPOCON( 'L', M2, DWORK( IW2 ), M2, ANORM, RCOND( 1 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 1 ).LT.TOLL ) THEN - INFO = 2 - RETURN - END IF -C -C Compute -( B2'*X2*A + D12'*C1 ) in CK . -C - CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, CK, LDCK ) - CALL DGEMM( 'N', 'N', M2, N, N, -ONE, DWORK, M2, A, LDA, -ONE, CK, - $ LDCK ) -C -C Compute F2 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*A + D12'*C1 ) . -C - CALL DPOTRS( 'L', M2, N, DWORK( IW2 ), M2, CK, LDCK, INFO2 ) -C -C Compute -( B2'*X2*B1 + D12'*D11 ) . -C - CALL DLACPY( 'Full', M2, M1, D( ND1+1, 1 ), LDD, DWORK( IWRK ), - $ M2 ) - CALL DGEMM( 'N', 'N', M2, M1, N, -ONE, DWORK, M2, B, LDB, -ONE, - $ DWORK( IWRK ), M2 ) -C -C Compute F0 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*B1 + D12'*D11 ) . -C - CALL DPOTRS( 'L', M2, M1, DWORK( IW2 ), M2, DWORK( IWRK ), M2, - $ INFO2 ) -C -C Save F0*D21' in DK . -C - CALL DLACPY( 'Full', M2, NP2, DWORK( IWRK+ND2*M2 ), M2, DK, - $ LDDK ) -C -C Workspace usage. -C - IWRK = IWU + 4*N*N -C -C Compute Ay = A - B1*D21'*C2 in AK . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, - $ C( NP1+1, 1 ), LDC, ONE, AK, LDAK ) -C -C Transpose Ay in-situ. -C - DO 20 J = 1, N - 1 - CALL DSWAP( J, AK( J+1, 1 ), LDAK, AK( 1, J+1 ), 1 ) - 20 CONTINUE -C -C Compute Cy = B1*B1' - B1*D21'*D21*B1' . -C - IF( ND2.GT.0 ) THEN - CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dy = C2'*C2 . -C - CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the discrete-time Riccati equation -C Ay*inv( In + Y2*Dy )*Y2*Ay' - Y2 + Cy = 0 . -C - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, NP2, M1, AK, LDAK, - $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, - $ DWORK( IWRK ), N, RCOND2, Y, LDY, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, - $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Condition estimation. -C - IWRK = IWV + N*N - CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWC ), - $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Y, LDY, SEPD, RCOND( 4 ), FERR, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.GT.0 ) RCOND( 4 ) = ZERO - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Workspace usage. -C - IW2 = N*NP2 + 1 - IWRK = IW2 + NP2*NP2 -C -C Compute Y2*C2' . -C - CALL DGEMM( 'N', 'T', N, NP2, N, ONE, Y, LDY, C( NP1+1, 1 ), LDC, - $ ZERO, DWORK, N ) -C -C Compute Ip2 + C2*Y2*C2' . -C - CALL DLASET( 'U', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) - CALL MB01RX( 'Left', 'Upper', 'N', NP2, N, ONE, ONE, DWORK( IW2 ), - $ NP2, C( NP1+1, 1 ), LDC, DWORK, N, INFO2 ) -C -C Compute the Cholesky factorization of Ip2 + C2*Y2*C2' . -C - ANORM = DLANSY( 'I', 'U', NP2, DWORK( IW2 ), NP2, DWORK( IWRK ) ) - CALL DPOTRF( 'U', NP2, DWORK( IW2 ), NP2, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DPOCON( 'U', NP2, DWORK( IW2 ), NP2, ANORM, RCOND( 2 ), - $ DWORK( IWRK ), IWORK, INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 2 ).LT.TOLL ) THEN - INFO = 4 - RETURN - END IF -C -C Compute A*Y2*C2' + B1*D21' in BK . -C - CALL DLACPY ( 'Full', N, NP2, B( 1, ND2+1 ), LDB, BK, LDBK ) - CALL DGEMM( 'N', 'N', N, NP2, N, ONE, A, LDA, DWORK, N, ONE, - $ BK, LDBK ) -C -C Compute L2 = -( A*Y2*C2' + B1*D21' )*inv( Ip2 + C2*Y2*C2' ) . -C - CALL DTRSM( 'R', 'U', 'N', 'N', N, NP2, -ONE, DWORK( IW2 ), NP2, - $ BK, LDBK ) - CALL DTRSM( 'R', 'U', 'T', 'N', N, NP2, ONE, DWORK( IW2 ), NP2, - $ BK, LDBK ) -C -C Compute F2*Y2*C2' + F0*D21' . -C - CALL DGEMM( 'N', 'N', M2, NP2, N, ONE, CK, LDCK, DWORK, N, ONE, - $ DK, LDDK ) -C -C Compute DK = L0 = ( F2*Y2*C2' + F0*D21' )*inv( Ip2 + C2*Y2*C2' ) . -C - CALL DTRSM( 'R', 'U', 'N', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, - $ DK, LDDK ) - CALL DTRSM( 'R', 'U', 'T', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, - $ DK, LDDK ) -C -C Compute CK = F2 - L0*C2 . -C - CALL DGEMM( 'N', 'N', M2, N, NP2, -ONE, DK, LDDK, C( NP1+1, 1), - $ LDC, ONE, CK, LDCK ) -C -C Find AK = A + B2*( F2 - L0*C2 ) + L2*C2 . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B(1, M1+1 ), LDB, CK, LDCK, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, C( NP1+1, 1), - $ LDC, ONE, AK, LDAK ) -C -C Find BK = -L2 + B2*L0 . -C - CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, B( 1, M1+1 ), LDB, DK, - $ LDDK, -ONE, BK, LDBK ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10SD *** - END diff --git a/slycot/src/SB10TD.f b/slycot/src/SB10TD.f deleted file mode 100644 index e8d193b4..00000000 --- a/slycot/src/SB10TD.f +++ /dev/null @@ -1,350 +0,0 @@ - SUBROUTINE SB10TD( N, M, NP, NCON, NMEAS, D, LDD, TU, LDTU, TY, - $ LDTY, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, - $ RCOND, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal discrete-time controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C from the matrices of the controller for the normalized system, -C as determined by the SLICOT Library routine SB10SD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. Only the trailing -C NMEAS-by-NCON submatrix D22 is used. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array must contain the -C control transformation matrix TU, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array must contain the -C measurement transformation matrix TY, as obtained by the -C SLICOT Library routine SB10PD. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C AK (input/output) DOUBLE PRECISION array, dimension (LDAK,N) -C On entry, the leading N-by-N part of this array must -C contain controller state matrix for the normalized system -C as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading N-by-N part of this array contains -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (input/output) DOUBLE PRECISION array, dimension -C (LDBK,NMEAS) -C On entry, the leading N-by-NMEAS part of this array must -C contain controller input matrix for the normalized system -C as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading N-by-NMEAS part of this array -C contains controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (input/output) DOUBLE PRECISION array, dimension (LDCK,N) -C On entry, the leading NCON-by-N part of this array must -C contain controller output matrix for the normalized -C system as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading NCON-by-N part of this array contains -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (input/output) DOUBLE PRECISION array, dimension -C (LDDK,NMEAS) -C On entry, the leading NCON-by-NMEAS part of this array -C must contain controller matrix DK for the normalized -C system as obtained by the SLICOT Library routine SB10SD. -C On exit, the leading NCON-by-NMEAS part of this array -C contains controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C RCOND (output) DOUBLE PRECISION -C RCOND contains an estimate of the reciprocal condition -C number of the matrix Im2 + DKHAT*D22 which must be -C inverted in the computation of the controller. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used in determining the nonsingularity of the -C matrix which must be inverted. If TOL <= 0, then a default -C value equal to sqrt(EPS) is used, where EPS is the -C relative machine precision. -C -C Workspace -C -C IWORK INTEGER array, dimension (2*M2) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix Im2 + DKHAT*D22 is singular, or the -C estimated condition number is larger than or equal -C to 1/TOL. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. -C Fortran 77 routines for Hinf and H2 design of linear -C discrete-time control systems. -C Report 99-8, Department of Engineering, Leicester University, -C April 1999. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations and of the matrix Im2 + -C DKHAT*D22. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Jan. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDAK, LDBK, LDCK, LDD, LDDK, LDTU, LDTY, - $ LDWORK, M, N, NCON, NMEAS, NP - DOUBLE PRECISION RCOND, TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION AK( LDAK, * ), BK( LDBK, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ TU( LDTU, * ), TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWRK, M1, M2, MINWRK, NP1, NP2 - DOUBLE PRECISION ANORM, TOLL -C .. -C .. External Functions - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE -C .. -C .. External Subroutines .. - EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, DLACPY, DLASET, - $ XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -7 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -9 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -11 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -17 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE -C -C Compute workspace. -C - MINWRK = MAX ( N*M2, N*NP2, M2*NP2, M2*( M2 + 4 ) ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -24 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for nonsingularity test. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Find BKHAT . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, - $ DWORK, N ) - CALL DLACPY ('Full', N, NP2, DWORK, N, BK, LDBK ) -C -C Find CKHAT . -C - CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, CK, LDCK, ZERO, - $ DWORK, M2 ) - CALL DLACPY ('Full', M2, N, DWORK, M2, CK, LDCK ) -C -C Compute DKHAT . -C - CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DK, LDDK, ZERO, - $ DWORK, M2 ) - CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK, M2, TY, LDTY, - $ ZERO, DK, LDDK ) -C -C Compute Im2 + DKHAT*D22 . -C - IWRK = M2*M2 + 1 - CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) - CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, - $ D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) - ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) - CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF - CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND, DWORK( IWRK ), - $ IWORK( M2+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND.LT.TOLL ) THEN - INFO = 1 - RETURN - END IF -C -C Compute CK . -C - CALL DGETRS( 'N', M2, N, DWORK, M2, IWORK, CK, LDCK, INFO2 ) -C -C Compute DK . -C - CALL DGETRS( 'N', M2, NP2, DWORK, M2, IWORK, DK, LDDK, INFO2 ) -C -C Compute AK . -C - CALL DGEMM( 'N', 'N', N, M2, NP2, ONE, BK, LDBK, D( NP1+1, M1+1 ), - $ LDD, ZERO, DWORK, N ) - CALL DGEMM( 'N', 'N', N, N, M2, -ONE, DWORK, N, CK, LDCK, ONE, AK, - $ LDAK ) -C -C Compute BK . -C - CALL DGEMM( 'N', 'N', N, NP2, M2, -ONE, DWORK, N, DK, LDDK, - $ ONE, BK, LDBK ) - RETURN -C *** Last line of SB10TD *** - END diff --git a/slycot/src/SB10UD.f b/slycot/src/SB10UD.f deleted file mode 100644 index b5919d44..00000000 --- a/slycot/src/SB10UD.f +++ /dev/null @@ -1,419 +0,0 @@ - SUBROUTINE SB10UD( N, M, NP, NCON, NMEAS, B, LDB, C, LDC, D, LDD, - $ TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices D12 and D21 of the linear time-invariant -C system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C to unit diagonal form, and to transform the matrices B and C to -C satisfy the formulas in the computation of the H2 optimal -C controller. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading NP-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading NP-by-N part of this array contains -C the transformed system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading NP-by-M part of this array must -C contain the system input/output matrix D. -C The (NP-NMEAS)-by-(M-NCON) leading submatrix D11 is not -C referenced. -C On exit, the trailing NMEAS-by-NCON part (in the leading -C NP-by-M part) of this array contains the transformed -C submatrix D22. -C The transformed submatrices D12 = [ 0 Im2 ]' and -C D21 = [ 0 Inp2 ] are not stored. The corresponding part -C of this array contains no useful information. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array contains the -C control transformation matrix TU. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array contains the -C measurement transformation matrix TY. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C RCOND (output) DOUBLE PRECISION array, dimension (2) -C RCOND(1) contains the reciprocal condition number of the -C control transformation matrix TU; -C RCOND(2) contains the reciprocal condition number of the -C measurement transformation matrix TY. -C RCOND is set even if INFO = 1 or INFO = 2; if INFO = 1, -C then RCOND(2) was not computed, but it is set to 0. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for controlling the accuracy of the applied -C transformations. Transformation matrices TU and TY whose -C reciprocal condition numbers are less than TOL are not -C allowed. If TOL <= 0, then a default value equal to -C sqrt(EPS) is used, where EPS is the relative machine -C precision. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX( M2 + NP1*NP1 + MAX(NP1*N,3*M2+NP1,5*M2), -C NP2 + M1*M1 + MAX(M1*N,3*NP2+M1,5*NP2), -C N*M2, NP2*N, NP2*M2, 1 ) -C where M1 = M - M2 and NP1 = NP - NP2. -C For good performance, LDWORK must generally be larger. -C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is -C MAX(1,Q*(Q+MAX(N,5)+1)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the matrix D12 had not full column rank in -C respect to the tolerance TOL; -C = 2: if the matrix D21 had not full row rank in respect -C to the tolerance TOL; -C = 3: if the singular value decomposition (SVD) algorithm -C did not converge (when computing the SVD of D12 or -C D21). -C -C METHOD -C -C The routine performs the transformations described in [1], [2]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The precision of the transformations can be controlled by the -C condition numbers of the matrices TU and TY as given by the -C values of RCOND(1) and RCOND(2), respectively. An error return -C with INFO = 1 or INFO = 2 will be obtained if the condition -C number of TU or TY, respectively, would exceed 1/TOL. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999, -C Feb. 2000. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDB, LDC, LDD, LDTU, LDTY, LDWORK, M, N, - $ NCON, NMEAS, NP - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ), C( LDC, * ), D( LDD, * ), - $ DWORK( * ), RCOND( 2 ), TU( LDTU, * ), - $ TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IQ, IWRK, J, LWAMAX, M1, M2, MINWRK, - $ ND1, ND2, NP1, NP2 - DOUBLE PRECISION TOLL -C .. -C .. External Functions - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -13 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -15 - ELSE -C -C Compute workspace. -C - MINWRK = MAX( 1, M2 + NP1*NP1 + MAX( NP1*N, 3*M2 + NP1, - $ 5*M2 ), - $ NP2 + M1*M1 + MAX( M1*N, 3*NP2 + M1, 5*NP2 ), - $ N*M2, NP2*N, NP2*M2 ) - IF( LDWORK.LT.MINWRK ) - $ INFO = -19 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10UD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - TOLL = TOL - IF( TOLL.LE.ZERO ) THEN -C -C Set the default value of the tolerance for condition tests. -C - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - END IF -C -C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has -C full column rank. V12' is stored in TU. -C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); -C prefer larger. -C - IQ = M2 + 1 - IWRK = IQ + NP1*NP1 -C - CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, - $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), - $ LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C - RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) - IF( RCOND( 1 ).LE.TOLL ) THEN - RCOND( 2 ) = ZERO - INFO = 1 - RETURN - END IF - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Determine Q12. -C - IF( ND1.GT.0 ) THEN - CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), - $ LDD ) - CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, - $ DWORK( IQ ), NP1 ) - CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, - $ DWORK( IQ+NP1*ND1 ), NP1 ) - END IF -C -C Determine Tu by transposing in-situ and scaling. -C - DO 10 J = 1, M2 - 1 - CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) - 10 CONTINUE -C - DO 20 J = 1, M2 - CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) - 20 CONTINUE -C -C Determine C1 =: Q12'*C1. -C Workspace: M2 + NP1*NP1 + NP1*N. -C - CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, - $ ZERO, DWORK( IWRK ), NP1 ) - CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) - LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) -C -C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has -C full row rank. U21 is stored in TY. -C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); -C prefer larger. -C - IQ = NP2 + 1 - IWRK = IQ + M1*M1 -C - CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, - $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C - RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) - IF( RCOND( 2 ).LE.TOLL ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Determine Q21. -C - IF( ND2.GT.0 ) THEN - CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), - $ LDD ) - CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), - $ M1 ) - CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, - $ DWORK( IQ+ND2 ), M1 ) - END IF -C -C Determine Ty by scaling and transposing in-situ. -C - DO 30 J = 1, NP2 - CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) - 30 CONTINUE -C - DO 40 J = 1, NP2 - 1 - CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) - 40 CONTINUE -C -C Determine B1 =: B1*Q21'. -C Workspace: NP2 + M1*M1 + N*M1. -C - CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, - $ ZERO, DWORK( IWRK ), N ) - CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) - LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) -C -C Determine B2 =: B2*Tu. -C Workspace: N*M2. -C - CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, - $ ZERO, DWORK, N ) - CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) -C -C Determine C2 =: Ty*C2. -C Workspace: NP2*N. -C - CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, - $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) - CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) -C -C Determine D22 =: Ty*D22*Tu. -C Workspace: NP2*M2. -C - CALL DGEMM( 'N', 'N', NP2, M2, NP2, ONE, TY, LDTY, - $ D( NP1+1, M1+1 ), LDD, ZERO, DWORK, NP2 ) - CALL DGEMM( 'N', 'N', NP2, M2, M2, ONE, DWORK, NP2, TU, LDTU, - $ ZERO, D( NP1+1, M1+1 ), LDD ) -C - LWAMAX = MAX( N*MAX( M2, NP2 ), NP2*M2, LWAMAX ) - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10UD *** - END diff --git a/slycot/src/SB10VD.f b/slycot/src/SB10VD.f deleted file mode 100644 index 913a5ab2..00000000 --- a/slycot/src/SB10VD.f +++ /dev/null @@ -1,393 +0,0 @@ - SUBROUTINE SB10VD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ F, LDF, H, LDH, X, LDX, Y, LDY, XYCOND, IWORK, - $ DWORK, LDWORK, BWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the state feedback and the output injection -C matrices for an H2 optimal n-state controller for the system -C -C | A | B1 B2 | | A | B | -C P = |----|---------| = |---|---| -C | C1 | 0 D12 | | C | D | -C | C2 | D21 D22 | -C -C where B2 has as column size the number of control inputs (NCON) -C and C2 has as row size the number of measurements (NMEAS) being -C provided to the controller. -C -C It is assumed that -C -C (A1) (A,B2) is stabilizable and (C2,A) is detectable, -C -C (A2) D12 is full column rank with D12 = | 0 | and D21 is -C | I | -C full row rank with D21 = | 0 I | as obtained by the -C SLICOT Library routine SB10UD. Matrix D is not used -C explicitly. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0, -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0, -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C F (output) DOUBLE PRECISION array, dimension (LDF,N) -C The leading NCON-by-N part of this array contains the -C state feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,NCON). -C -C H (output) DOUBLE PRECISION array, dimension (LDH,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C output injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C The leading N-by-N part of this array contains the matrix -C X, solution of the X-Riccati equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= max(1,N). -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,N) -C The leading N-by-N part of this array contains the matrix -C Y, solution of the Y-Riccati equation. -C -C LDY INTEGER -C The leading dimension of the array Y. LDY >= max(1,N). -C -C XYCOND (output) DOUBLE PRECISION array, dimension (2) -C XYCOND(1) contains an estimate of the reciprocal condition -C number of the X-Riccati equation; -C XYCOND(2) contains an estimate of the reciprocal condition -C number of the Y-Riccati equation. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2*N,N*N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal -C LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 13*N*N + 12*N + 5. -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the X-Riccati equation was not solved -C successfully; -C = 2: if the Y-Riccati equation was not solved -C successfully. -C -C METHOD -C -C The routine implements the formulas given in [1], [2]. The X- -C and Y-Riccati equations are solved with condition and accuracy -C estimates [3]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. -C DGRSVX and DMSRIC: Fortan 77 subroutines for solving -C continuous-time matrix algebraic Riccati equations with -C condition and accuracy estimates. -C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. -C Chemnitz, May 1998. -C -C NUMERICAL ASPECTS -C -C The precision of the solution of the matrix Riccati equations -C can be controlled by the values of the condition numbers -C XYCOND(1) and XYCOND(2) of these equations. -C -C FURTHER COMMENTS -C -C The Riccati equations are solved by the Schur approach -C implementing condition and accuracy estimates. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDF, LDH, LDWORK, LDX, - $ LDY, M, N, NCON, NMEAS, NP -C .. -C .. Array Arguments .. - LOGICAL BWORK( * ) - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), F( LDF, * ), H( LDH, * ), - $ X( LDX, * ), XYCOND( 2 ), Y( LDY, * ) -C .. -C .. Local Scalars .. - INTEGER INFO2, IWG, IWI, IWQ, IWR, IWRK, IWS, IWT, IWV, - $ LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, NP1, NP2 - DOUBLE PRECISION FERR, SEP -C .. -C .. External Functions .. -C - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, DSYRK, SB02RD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDF.LT.MAX( 1, NCON ) ) THEN - INFO = -13 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDY.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE -C -C Compute workspace. -C - MINWRK = 13*N*N + 12*N + 5 - IF( LDWORK.LT.MINWRK ) - $ INFO = -23 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10VD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN - DWORK( 1 ) = ONE - XYCOND( 1 ) = ONE - XYCOND( 2 ) = ONE - RETURN - END IF -C - ND1 = NP1 - M2 - ND2 = M1 - NP2 - N2 = 2*N -C -C Workspace usage. -C - IWQ = N*N + 1 - IWG = IWQ + N*N - IWT = IWG + N*N - IWV = IWT + N*N - IWR = IWV + N*N - IWI = IWR + N2 - IWS = IWI + N2 - IWRK = IWS + 4*N*N -C -C Compute Ax = A - B2*D12'*C1 . -C - CALL DLACPY ('Full', N, N, A, LDA, DWORK, N ) - CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, - $ C( ND1+1, 1), LDC, ONE, DWORK, N ) -C -C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . -C - IF( ND1.GT.0 ) THEN - CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dx = B2*B2' . -C - CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . -C Workspace: need 13*N*N + 12*N + 5; -C prefer larger. -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', - $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK, N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 1 - RETURN - END IF -C - LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 -C -C Compute F = -D12'*C1 - B2'*X . -C - CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, F, LDF ) - CALL DGEMM( 'T', 'N', M2, N, N, -ONE, B( 1, M1+1 ), LDB, X, LDX, - $ -ONE, F, LDF ) -C -C Compute Ay = A - B1*D21'*C2 . -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) - CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, - $ C( NP1+1, 1 ), LDC, ONE, DWORK, N ) -C -C Compute Cy = B1*B1' - B1*D21'*D21*B1' . -C - IF( ND2.GT.0 ) THEN - CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), - $ N ) - ELSE - CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) - END IF -C -C Compute Dy = C2'*C2 . -C - CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, - $ DWORK( IWG ), N ) -C -C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . -C Workspace: need 13*N*N + 12*N + 5; -C prefer larger. -C - CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', - $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', - $ 'Original', N, DWORK, N, DWORK( IWT ), N, - $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, - $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), - $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 2 - RETURN - END IF -C - LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) -C -C Compute H = -B1*D21' - Y*C2' . -C - CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, H, LDH ) - CALL DGEMM( 'N', 'T', N, NP2, N, -ONE, Y, LDY, C( NP1+1, 1 ), LDC, - $ -ONE, H, LDH ) -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10VD *** - END diff --git a/slycot/src/SB10WD.f b/slycot/src/SB10WD.f deleted file mode 100644 index e2f37b2f..00000000 --- a/slycot/src/SB10WD.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE SB10WD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, - $ D, LDD, F, LDF, H, LDH, TU, LDTU, TY, LDTY, - $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the H2 optimal controller -C -C | AK | BK | -C K = |----|----|, -C | CK | DK | -C -C from the state feedback matrix F and output injection matrix H as -C determined by the SLICOT Library routine SB10VD. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C NCON (input) INTEGER -C The number of control inputs (M2). M >= NCON >= 0. -C NP-NMEAS >= NCON. -C -C NMEAS (input) INTEGER -C The number of measurements (NP2). NP >= NMEAS >= 0. -C M-NCON >= NMEAS. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B. Only the submatrix -C B2 = B(:,M-M2+1:M) is used. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C. Only the submatrix -C C2 = C(NP-NP2+1:NP,:) is used. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D. Only the submatrix -C D22 = D(NP-NP2+1:NP,M-M2+1:M) is used. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C F (input) DOUBLE PRECISION array, dimension (LDF,N) -C The leading NCON-by-N part of this array must contain the -C state feedback matrix F. -C -C LDF INTEGER -C The leading dimension of the array F. LDF >= max(1,NCON). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,NMEAS) -C The leading N-by-NMEAS part of this array must contain the -C output injection matrix H. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,N). -C -C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) -C The leading M2-by-M2 part of this array must contain the -C control transformation matrix TU, as obtained by the -C SLICOT Library routine SB10UD. -C -C LDTU INTEGER -C The leading dimension of the array TU. LDTU >= max(1,M2). -C -C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) -C The leading NP2-by-NP2 part of this array must contain the -C measurement transformation matrix TY, as obtained by the -C SLICOT Library routine SB10UD. -C -C LDTY INTEGER -C The leading dimension of the array TY. -C LDTY >= max(1,NP2). -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix AK. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) -C The leading N-by-NMEAS part of this array contains the -C controller input matrix BK. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading NCON-by-N part of this array contains the -C controller output matrix CK. -C -C LDCK INTEGER -C The leading dimension of the array CK. -C LDCK >= max(1,NCON). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) -C The leading NCON-by-NMEAS part of this array contains the -C controller input/output matrix DK. -C -C LDDK INTEGER -C The leading dimension of the array DK. -C LDDK >= max(1,NCON). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine implements the formulas given in [1], [2]. -C -C REFERENCES -C -C [1] Zhou, K., Doyle, J.C., and Glover, K. -C Robust and Optimal Control. -C Prentice-Hall, Upper Saddle River, NJ, 1996. -C -C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and -C Smith, R. -C mu-Analysis and Synthesis Toolbox. -C The MathWorks Inc., Natick, Mass., 1995. -C -C NUMERICAL ASPECTS -C -C The accuracy of the result depends on the condition numbers of the -C input and output transformations. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 1999. -C -C KEYWORDS -C -C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal -C regulator, robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS, - $ NP -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), - $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), - $ D( LDD, * ), DK( LDDK, * ), F( LDF, * ), - $ H( LDH, * ), TU( LDTU, * ), TY( LDTY, * ) -C .. -C .. Local Scalars .. - INTEGER M1, M2, NP1, NP2 -C .. -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, DLASET, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - M1 = M - NCON - M2 = NCON - NP1 = NP - NMEAS - NP2 = NMEAS -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.LT.0 ) THEN - INFO = -3 - ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN - INFO = -4 - ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) 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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -13 - ELSE IF( LDF.LT.MAX( 1, M2 ) ) THEN - INFO = -15 - ELSE IF( LDH.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN - INFO = -19 - ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN - INFO = -21 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -23 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -25 - ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN - INFO = -27 - ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN - INFO = -29 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 - $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) RETURN -C -C Compute the transpose of D22*F . BK is used as workspace. -C - CALL DGEMM( 'T', 'T', N, NP2, M2, ONE, F, LDF, D( NP1+1, M1+1 ), - $ LDD, ZERO, BK, LDBK ) -C -C Find AK = A + H*C2 + B2*F + H*D22*F . -C - CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP2, ONE, H, LDH, C( NP1+1, 1 ), LDC, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, - $ F, LDF, ONE, AK, LDAK ) - CALL DGEMM( 'N', 'T', N, N, NP2, ONE, H, LDH, BK, LDBK, ONE, AK, - $ LDAK ) -C -C Find BK = -H*Ty . -C - CALL DGEMM( 'N', 'N', N, NP2, NP2, -ONE, H, LDH, TY, LDTY, ZERO, - $ BK, LDBK ) -C -C Find CK = Tu*F . -C - CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, F, LDF, ZERO, CK, - $ LDCK ) -C -C Find DK . -C - CALL DLASET( 'Full', M2, NP2, ZERO, ZERO, DK, LDDK ) -C - RETURN -C *** Last line of SB10WD *** - END diff --git a/slycot/src/SB10YD.f b/slycot/src/SB10YD.f deleted file mode 100644 index fa84e9f0..00000000 --- a/slycot/src/SB10YD.f +++ /dev/null @@ -1,689 +0,0 @@ - SUBROUTINE SB10YD( DISCFL, FLAG, LENDAT, RFRDAT, IFRDAT, OMEGA, N, - $ A, LDA, B, C, D, TOL, IWORK, DWORK, LDWORK, - $ ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To fit a supplied frequency response data with a stable, minimum -C phase SISO (single-input single-output) system represented by its -C matrices A, B, C, D. It handles both discrete- and continuous-time -C cases. -C -C ARGUMENTS -C -C Input/Output parameters -C -C DISCFL (input) INTEGER -C Indicates the type of the system, as follows: -C = 0: continuous-time system; -C = 1: discrete-time system. -C -C FLAG (input) INTEGER -C If FLAG = 0, then the system zeros and poles are not -C constrained. -C If FLAG = 1, then the system zeros and poles will have -C negative real parts in the continuous-time case, or moduli -C less than 1 in the discrete-time case. Consequently, FLAG -C must be equal to 1 in mu-synthesis routines. -C -C LENDAT (input) INTEGER -C The length of the vectors RFRDAT, IFRDAT and OMEGA. -C LENDAT >= 2. -C -C RFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) -C The real part of the frequency data to be fitted. -C -C IFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) -C The imaginary part of the frequency data to be fitted. -C -C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) -C The frequencies corresponding to RFRDAT and IFRDAT. -C These values must be nonnegative and monotonically -C increasing. Additionally, for discrete-time systems -C they must be between 0 and PI. -C -C N (input/output) INTEGER -C On entry, the desired order of the system to be fitted. -C N <= LENDAT-1. -C On exit, the order of the obtained system. The value of N -C could only be modified if N > 0 and FLAG = 1. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the -C matrix A. If FLAG = 1, then A is in an upper Hessenberg -C form, and corresponds to a minimal realization. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (N) -C The computed vector B. -C -C C (output) DOUBLE PRECISION array, dimension (N) -C The computed vector C. If FLAG = 1, the first N-1 elements -C are zero (for the exit value of N). -C -C D (output) DOUBLE PRECISION array, dimension (1) -C The computed scalar D. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used for determining the effective -C rank of matrices. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the reciprocal -C condition number; a (sub)matrix whose estimated condition -C number is less than 1/TOL is considered to be of full -C rank. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by TOLDEF = SIZE*EPS, -C is used instead, where SIZE is the product of the matrix -C dimensions, and EPS is the machine precision (see LAPACK -C Library routine DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension max(2,2*N+1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK and DWORK(2) contains the optimal value of -C LZWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK = max( 2, LW1, LW2, LW3, LW4 ), where -C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; -C LW2 = LENDAT + 6*HNPTS; -C MN = min( 2*LENDAT, 2*N+1 ) -C LW3 = 2*LENDAT*(2*N+1) + max( 2*LENDAT, 2*N+1 ) + -C max( MN + 6*N + 4, 2*MN + 1 ), if N > 0; -C LW3 = 4*LENDAT + 5 , if N = 0; -C LW4 = max( N*N + 5*N, 6*N + 1 + min( 1,N ) ), if FLAG = 1; -C LW4 = 0, if FLAG = 0. -C For optimum performance LDWORK should be larger. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK = LENDAT*(2*N+3), if N > 0; -C LZWORK = LENDAT, if N = 0. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the discrete --> continuous transformation cannot -C be made; -C = 2: if the system poles cannot be found; -C = 3: if the inverse system cannot be found, i.e., D is -C (close to) zero; -C = 4: if the system zeros cannot be found; -C = 5: if the state-space representation of the new -C transfer function T(s) cannot be found; -C = 6: if the continuous --> discrete transformation cannot -C be made. -C -C METHOD -C -C First, if the given frequency data are corresponding to a -C continuous-time system, they are changed to a discrete-time -C system using a bilinear transformation with a scaled alpha. -C Then, the magnitude is obtained from the supplied data. -C Then, the frequency data are linearly interpolated around -C the unit-disc. -C Then, Oppenheim and Schafer complex cepstrum method is applied -C to get frequency data corresponding to a stable, minimum- -C phase system. This is done in the following steps: -C - Obtain LOG (magnitude) -C - Obtain IFFT of the result (DG01MD SLICOT subroutine); -C - halve the data at 0; -C - Obtain FFT of the halved data (DG01MD SLICOT subroutine); -C - Obtain EXP of the result. -C Then, the new frequency data are interpolated back to the -C original frequency. -C Then, based on these newly obtained data, the system matrices -C A, B, C, D are constructed; the very identification is -C performed by Least Squares Method using DGELSY LAPACK subroutine. -C If needed, a discrete-to-continuous time transformation is -C applied on the system matrices by AB04MD SLICOT subroutine. -C Finally, if requested, the poles and zeros of the system are -C checked. If some of them have positive real parts in the -C continuous-time case (or are not inside the unit disk in the -C complex plane in the discrete-time case), they are exchanged with -C their negatives (or reciprocals, respectively), to preserve the -C frequency response, while getting a minimum phase and stable -C system. This is done by SB10ZP SLICOT subroutine. -C -C REFERENCES -C -C [1] Oppenheim, A.V. and Schafer, R.W. -C Discrete-Time Signal Processing. -C Prentice-Hall Signal Processing Series, 1989. -C -C [2] Balas, G., Doyle, J., Glover, K., Packard, A., and Smith, R. -C Mu-analysis and Synthesis toolbox - User's Guide, -C The Mathworks Inc., Natick, MA, USA, 1998. -C -C CONTRIBUTORS -C -C Asparuh Markovski, Technical University of Sofia, July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C A. Markovski, Technical University of Sofia, October 2003. -C -C KEYWORDS -C -C Bilinear transformation, frequency response, least-squares -C approximation, stability. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ZZERO, ZONE - PARAMETER ( ZZERO = ( 0.0D+0, 0.0D+0 ), - $ ZONE = ( 1.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, TEN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ FOUR = 4.0D+0, TEN = 1.0D+1 ) - INTEGER HNPTS - PARAMETER ( HNPTS = 2048 ) -C .. -C .. Scalar Arguments .. - INTEGER DISCFL, FLAG, INFO, LDA, LDWORK, LENDAT, - $ LZWORK, N - DOUBLE PRECISION TOL -C .. -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA, *), B(*), C(*), D(*), DWORK(*), - $ IFRDAT(*), OMEGA(*), RFRDAT(*) - COMPLEX*16 ZWORK(*) -C .. -C .. Local Scalars .. - INTEGER CLWMAX, DLWMAX, I, II, INFO2, IP1, IP2, ISTART, - $ ISTOP, IWA0, IWAB, IWBMAT, IWBP, IWBX, IWDME, - $ IWDOMO, IWMAG, IWS, IWVAR, IWXI, IWXR, IWYMAG, - $ K, LW1, LW2, LW3, LW4, MN, N1, N2, P, RANK - DOUBLE PRECISION P1, P2, PI, PW, RAT, TOLB, TOLL - COMPLEX*16 XHAT(HNPTS/2) -C .. -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - EXTERNAL DLAMCH, DLAPY2 -C .. -C .. External Subroutines .. - EXTERNAL AB04MD, DCOPY, DG01MD, DGELSY, DLASET, DSCAL, - $ SB10ZP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ACOS, ATAN, COS, DBLE, DCMPLX, DIMAG, EXP, LOG, - $ MAX, MIN, SIN, SQRT -C -C Test input parameters and workspace. -C - PI = FOUR*ATAN( ONE ) - PW = OMEGA(1) - N1 = N + 1 - N2 = N + N1 -C - INFO = 0 - IF( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN - INFO = -1 - ELSE IF( FLAG.NE.0 .AND. FLAG.NE.1 ) THEN - INFO = -2 - ELSE IF ( LENDAT.LT.2 ) THEN - INFO = -3 - ELSE IF ( PW.LT.ZERO ) THEN - INFO = -6 - ELSE IF( N.GT.LENDAT - 1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE -C - DO 10 K = 2, LENDAT - IF ( OMEGA(K).LT.PW ) - $ INFO = -6 - PW = OMEGA(K) - 10 CONTINUE -C - IF ( DISCFL.EQ.1 .AND. OMEGA(LENDAT).GT.PI ) - $ INFO = -6 - END IF -C - IF ( INFO.EQ.0 ) THEN -C -C Workspace. -C - LW1 = 2*LENDAT + 4*HNPTS - LW2 = LENDAT + 6*HNPTS - MN = MIN( 2*LENDAT, N2 ) -C - IF ( N.GT.0 ) THEN - LW3 = 2*LENDAT*N2 + MAX( 2*LENDAT, N2 ) + - $ MAX( MN + 6*N + 4, 2*MN + 1 ) - ELSE - LW3 = 4*LENDAT + 5 - END IF -C - IF ( FLAG.EQ.0 ) THEN - LW4 = 0 - ELSE - LW4 = MAX( N*N + 5*N, 6*N + 1 + MIN ( 1, N ) ) - END IF -C - DLWMAX = MAX( 2, LW1, LW2, LW3, LW4 ) -C - IF ( N.GT.0 ) THEN - CLWMAX = LENDAT*( N2 + 2 ) - ELSE - CLWMAX = LENDAT - END IF -C - IF ( LDWORK.LT.DLWMAX ) THEN - INFO = -16 - ELSE IF ( LZWORK.LT.CLWMAX ) THEN - INFO = -18 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10YD', -INFO ) - RETURN - END IF -C -C Set tolerances. -C - TOLB = DLAMCH( 'Epsilon' ) - TOLL = TOL - IF ( TOLL.LE.ZERO ) - $ TOLL = FOUR*DBLE( LENDAT*N )*TOLB -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 1. -C Workspace: need 2*LENDAT + 4*HNPTS. -C - IWDOMO = 1 - IWDME = IWDOMO + LENDAT - IWYMAG = IWDME + 2*HNPTS - IWMAG = IWYMAG + 2*HNPTS -C -C Bilinear transformation. -C - IF ( DISCFL.EQ.0 ) THEN - PW = SQRT( OMEGA(1)*OMEGA(LENDAT) + SQRT( TOLB ) ) -C - DO 20 K = 1, LENDAT - DWORK(IWDME+K-1) = ( OMEGA(K)/PW )**2 - DWORK(IWDOMO+K-1) = - $ ACOS( ( ONE - DWORK(IWDME+K-1) )/ - $ ( ONE + DWORK(IWDME+K-1) ) ) - 20 CONTINUE -C - ELSE - CALL DCOPY( LENDAT, OMEGA, 1, DWORK(IWDOMO), 1 ) - END IF -C -C Linear interpolation. -C - DO 30 K = 1, LENDAT - DWORK(IWMAG+K-1) = DLAPY2( RFRDAT(K), IFRDAT(K) ) - DWORK(IWMAG+K-1) = ( ONE/LOG( TEN ) ) * LOG( DWORK(IWMAG+K-1) ) - 30 CONTINUE -C - DO 40 K = 1, HNPTS - DWORK(IWDME+K-1) = ( K - 1 )*PI/HNPTS - DWORK(IWYMAG+K-1) = ZERO -C - IF ( DWORK(IWDME+K-1).LT.DWORK(IWDOMO) ) THEN - DWORK(IWYMAG+K-1) = DWORK(IWMAG) - ELSE IF ( DWORK(IWDME+K-1).GE.DWORK(IWDOMO+LENDAT-1) ) THEN - DWORK(IWYMAG+K-1) = DWORK(IWMAG+LENDAT-1) - END IF -C - 40 CONTINUE -C - DO 60 I = 2, LENDAT - P1 = HNPTS*DWORK(IWDOMO+I-2)/PI + ONE -C - IP1 = INT( P1 ) - IF ( DBLE( IP1 ).NE.P1 ) - $ IP1 = IP1 + 1 -C - P2 = HNPTS*DWORK(IWDOMO+I-1)/PI + ONE -C - IP2 = INT( P2 ) - IF ( DBLE( IP2 ).NE.P2 ) - $ IP2 = IP2 + 1 -C - DO 50 P = IP1, IP2 - 1 - RAT = DWORK(IWDME+P-1) - DWORK(IWDOMO+I-2) - RAT = RAT/( DWORK(IWDOMO+I-1) - DWORK(IWDOMO+I-2) ) - DWORK(IWYMAG+P-1) = ( ONE - RAT )*DWORK(IWMAG+I-2) + - $ RAT*DWORK(IWMAG+I-1) - 50 CONTINUE -C - 60 CONTINUE -C - DO 70 K = 1, HNPTS - DWORK(IWYMAG+K-1) = EXP( LOG( TEN )*DWORK(IWYMAG+K-1) ) - 70 CONTINUE -C -C Duplicate data around disc. -C - DO 80 K = 1, HNPTS - DWORK(IWDME+HNPTS+K-1) = TWO*PI - DWORK(IWDME+HNPTS-K) - DWORK(IWYMAG+HNPTS+K-1) = DWORK(IWYMAG+HNPTS-K) - 80 CONTINUE -C -C Complex cepstrum to get min phase: -C LOG (Magnitude) -C - DO 90 K = 1, 2*HNPTS - DWORK(IWYMAG+K-1) = TWO*LOG( DWORK(IWYMAG+K-1) ) - 90 CONTINUE -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 2. -C Workspace: need LENDAT + 6*HNPTS. -C - IWXR = IWYMAG - IWXI = IWMAG -C - DO 100 K = 1, 2*HNPTS - DWORK(IWXI+K-1) = ZERO - 100 CONTINUE -C -C IFFT -C - CALL DG01MD( 'I', 2*HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) -C -C Rescale, because DG01MD doesn't do it. -C - CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXR), 1 ) - CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXI), 1 ) -C -C Halve the result at 0. -C - DWORK(IWXR) = DWORK(IWXR)/TWO - DWORK(IWXI) = DWORK(IWXI)/TWO -C -C FFT -C - CALL DG01MD( 'D', HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) -C -C Get the EXP of the result. -C - DO 110 K = 1, HNPTS/2 - XHAT(K) = EXP( DWORK(IWXR+K-1) )* - $ DCMPLX ( COS( DWORK(IWXI+K-1)), SIN( DWORK(IWXI+K-1) ) ) - DWORK(IWDME+K-1) = DWORK(IWDME+2*K-2) - 110 CONTINUE -C -C Interpolate back to original frequency data. -C - ISTART = 1 - ISTOP = LENDAT -C - DO 120 I = 1, LENDAT - ZWORK(I) = ZZERO - IF ( DWORK(IWDOMO+I-1).LE.DWORK(IWDME) ) THEN - ZWORK(I) = XHAT(1) - ISTART = I + 1 - ELSE IF ( DWORK(IWDOMO+I-1).GE.DWORK(IWDME+HNPTS/2-1) ) - $ THEN - ZWORK(I) = XHAT(HNPTS/2) - ISTOP = ISTOP - 1 - END IF - 120 CONTINUE -C - DO 140 I = ISTART, ISTOP - II = HNPTS/2 - 130 CONTINUE - IF ( DWORK(IWDME+II-1).GE.DWORK(IWDOMO+I-1) ) - $ P = II - II = II - 1 - IF ( II.GT.0 ) - $ GOTO 130 - RAT = ( DWORK(IWDOMO+I-1) - DWORK(IWDME+P-2) )/ - $ ( DWORK(IWDME+P-1) - DWORK(IWDME+P-2) ) - ZWORK(I) = RAT*XHAT(P) + ( ONE - RAT )*XHAT(P-1) - 140 CONTINUE -C -C CASE N > 0. -C This is the only allowed case in mu-synthesis subroutines. -C - IF ( N.GT.0 ) THEN -C -C Preparation for frequency identification. -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Complex workspace usage 1. -C Complex workspace: need 2*LENDAT + LENDAT*(N+1). -C - IWA0 = 1 + LENDAT - IWVAR = IWA0 + LENDAT*N1 -C - DO 150 K = 1, LENDAT - IF ( DISCFL.EQ.0 ) THEN - ZWORK(IWVAR+K-1) = DCMPLX( COS( DWORK(IWDOMO+K-1) ), - $ SIN( DWORK(IWDOMO+K-1) ) ) - ELSE - ZWORK(IWVAR+K-1) = DCMPLX( COS( OMEGA(K) ), - $ SIN( OMEGA(K) ) ) - END IF - 150 CONTINUE -C -C Array for DGELSY. -C - DO 160 K = 1, N2 - IWORK(K) = 0 - 160 CONTINUE -C -C Constructing A0. -C - DO 170 K = 1, LENDAT - ZWORK(IWA0+N*LENDAT+K-1) = ZONE - 170 CONTINUE -C - DO 190 I = 1, N - DO 180 K = 1, LENDAT - ZWORK(IWA0+(N-I)*LENDAT+K-1) = - $ ZWORK(IWA0+(N1-I)*LENDAT+K-1)*ZWORK(IWVAR+K-1) - 180 CONTINUE - 190 CONTINUE -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Complex workspace usage 2. -C Complex workspace: need 2*LENDAT + LENDAT*(2*N+1). -C - IWBP = IWVAR - IWAB = IWBP + LENDAT -C -C Constructing BP. -C - DO 200 K = 1, LENDAT - ZWORK(IWBP+K-1) = ZWORK(IWA0+K-1)*ZWORK(K) - 200 CONTINUE -C -C Constructing AB. -C - DO 220 I = 1, N - DO 210 K = 1, LENDAT - ZWORK(IWAB+(I-1)*LENDAT+K-1) = -ZWORK(K)* - $ ZWORK(IWA0+I*LENDAT+K-1) - 210 CONTINUE - 220 CONTINUE -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 3. -C Workspace: need LW3 = 2*LENDAT*(2*N+1) + max(2*LENDAT,2*N+1). -C - IWBX = 1 + 2*LENDAT*N2 - IWS = IWBX + MAX( 2*LENDAT, N2 ) -C -C Constructing AX. -C - DO 240 I = 1, N1 - DO 230 K = 1, LENDAT - DWORK(2*(I-1)*LENDAT+K) = - $ DBLE( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) - DWORK((2*I-1)*LENDAT+K) = - $ DIMAG( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) - 230 CONTINUE - 240 CONTINUE -C - DO 260 I = 1, N - DO 250 K = 1, LENDAT - DWORK(2*N1*LENDAT+2*(I-1)*LENDAT+K) = - $ DBLE( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) - DWORK(2*N1*LENDAT+(2*I-1)*LENDAT+K) = - $ DIMAG( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) - 250 CONTINUE - 260 CONTINUE -C -C Constructing BX. -C - DO 270 K = 1, LENDAT - DWORK(IWBX+K-1) = DBLE( ZWORK(IWBP+K-1) ) - DWORK(IWBX+LENDAT+K-1) = DIMAG( ZWORK(IWBP+K-1) ) - 270 CONTINUE -C -C Estimating X. -C Workspace: need LW3 + max( MN+3*(2*N+1)+1, 2*MN+1 ), -C where MN = min( 2*LENDAT, 2*N+1 ); -C prefer larger. -C - CALL DGELSY( 2*LENDAT, N2, 1, DWORK, 2*LENDAT, DWORK(IWBX), - $ MAX( 2*LENDAT, N2 ), IWORK, TOLL, RANK, - $ DWORK(IWS), LDWORK-IWS+1, INFO2 ) - DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) -C -C Constructing A matrix. -C - DO 280 K = 1, N - A(K,1) = -DWORK(IWBX+N1+K-1) - 280 CONTINUE -C - IF ( N.GT.1 ) - $ CALL DLASET( 'Full', N, N-1, ZERO, ONE, A(1,2), LDA ) -C -C Constructing B matrix. -C - DO 290 K = 1, N - B(K) = DWORK(IWBX+N1+K-1)*DWORK(IWBX) - DWORK(IWBX+K) - 290 CONTINUE -C -C Constructing C matrix. -C - C(1) = -ONE -C - DO 300 K = 2, N - C(K) = ZERO - 300 CONTINUE -C -C Constructing D matrix. -C - D(1) = DWORK(IWBX) -C -C Transform to continuous-time case, if needed. -C Workspace: need max(1,N); -C prefer larger. -C - IF ( DISCFL.EQ.0 ) THEN - CALL AB04MD( 'D', N, 1, 1, ONE, PW, A, LDA, B, LDA, C, 1, - $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) - END IF -C -C Make all the real parts of the poles and the zeros negative. -C - IF ( FLAG.EQ.1 ) THEN -C -C Workspace: need max(N*N + 5*N, 6*N + 1 + min(1,N)); -C prefer larger. - CALL SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, - $ LDWORK, INFO ) - IF ( INFO.NE.0 ) - $ RETURN - DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) - END IF -C - ELSE -C -C CASE N = 0. -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C -C Workspace usage 4. -C Workspace: need 4*LENDAT. -C - IWBMAT = 1 + 2*LENDAT - IWS = IWBMAT + 2*LENDAT -C -C Constructing AMAT and BMAT. -C - DO 310 K = 1, LENDAT - DWORK(K) = ONE - DWORK(K+LENDAT) = ZERO - DWORK(IWBMAT+K-1) = DBLE( ZWORK(K) ) - DWORK(IWBMAT+LENDAT+K-1) = DIMAG( ZWORK(K) ) - 310 CONTINUE -C -C Estimating D matrix. -C Workspace: need 4*LENDAT + 5; -C prefer larger. -C - IWORK(1) = 0 - CALL DGELSY( 2*LENDAT, 1, 1, DWORK, 2*LENDAT, DWORK(IWBMAT), - $ 2*LENDAT, IWORK, TOLL, RANK, DWORK(IWS), - $ LDWORK-IWS+1, INFO2 ) - DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) -C - D(1) = DWORK(IWBMAT) -C - END IF -C -C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -C - DWORK(1) = DLWMAX - DWORK(2) = CLWMAX - RETURN -C -C *** Last line of SB10YD *** - END diff --git a/slycot/src/SB10ZD.f b/slycot/src/SB10ZD.f deleted file mode 100644 index f70c834d..00000000 --- a/slycot/src/SB10ZD.f +++ /dev/null @@ -1,914 +0,0 @@ - SUBROUTINE SB10ZD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, - $ FACTOR, AK, LDAK, BK, LDBK, CK, LDCK, DK, - $ LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the matrices of the positive feedback controller -C -C | Ak | Bk | -C K = |----|----| -C | Ck | Dk | -C -C for the shaped plant -C -C | A | B | -C G = |---|---| -C | C | D | -C -C in the Discrete-Time Loop Shaping Design Procedure. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the plant. N >= 0. -C -C M (input) INTEGER -C The column size of the matrix B. M >= 0. -C -C NP (input) INTEGER -C The row size of the matrix C. NP >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C system state matrix A of the shaped plant. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C system input matrix B of the shaped plant. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading NP-by-N part of this array must contain the -C system output matrix C of the shaped plant. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= max(1,NP). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading NP-by-M part of this array must contain the -C system input/output matrix D of the shaped plant. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= max(1,NP). -C -C FACTOR (input) DOUBLE PRECISION -C = 1 implies that an optimal controller is required -C (not recommended); -C > 1 implies that a suboptimal controller is required -C achieving a performance FACTOR less than optimal. -C FACTOR >= 1. -C -C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) -C The leading N-by-N part of this array contains the -C controller state matrix Ak. -C -C LDAK INTEGER -C The leading dimension of the array AK. LDAK >= max(1,N). -C -C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) -C The leading N-by-NP part of this array contains the -C controller input matrix Bk. -C -C LDBK INTEGER -C The leading dimension of the array BK. LDBK >= max(1,N). -C -C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) -C The leading M-by-N part of this array contains the -C controller output matrix Ck. -C -C LDCK INTEGER -C The leading dimension of the array CK. LDCK >= max(1,M). -C -C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) -C The leading M-by-NP part of this array contains the -C controller matrix Dk. -C -C LDDK INTEGER -C The leading dimension of the array DK. LDDK >= max(1,M). -C -C RCOND (output) DOUBLE PRECISION array, dimension (6) -C RCOND(1) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the P-Riccati equation is -C obtained; -C RCOND(2) contains an estimate of the reciprocal condition -C number of the linear system of equations from -C which the solution of the Q-Riccati equation is -C obtained; -C RCOND(3) contains an estimate of the reciprocal condition -C number of the matrix (gamma^2-1)*In - P*Q; -C RCOND(4) contains an estimate of the reciprocal condition -C number of the matrix Rx + Bx'*X*Bx; -C RCOND(5) contains an estimate of the reciprocal condition -C ^ -C number of the matrix Ip + D*Dk; -C RCOND(6) contains an estimate of the reciprocal condition -C ^ -C number of the matrix Im + Dk*D. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C Tolerance used for checking the nonsingularity of the -C matrices to be inverted. If TOL <= 0, then a default value -C equal to sqrt(EPS) is used, where EPS is the relative -C machine precision. TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension 2*max(N,M+NP) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + -C 7*N*NP + 6*N + 2*(M + NP) + -C max(14*N+23,16*N,2*M-1,2*NP-1). -C For good performance, LDWORK must generally be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Error Indicator -C -C INFO (output) INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the P-Riccati equation is not solved successfully; -C = 2: the Q-Riccati equation is not solved successfully; -C = 3: the iteration to compute eigenvalues or singular -C values failed to converge; -C = 4: the matrix (gamma^2-1)*In - P*Q is singular; -C = 5: the matrix Rx + Bx'*X*Bx is singular; -C ^ -C = 6: the matrix Ip + D*Dk is singular; -C ^ -C = 7: the matrix Im + Dk*D is singular; -C = 8: the matrix Ip - D*Dk is singular; -C = 9: the matrix Im - Dk*D is singular; -C = 10: the closed-loop system is unstable. -C -C METHOD -C -C The routine implements the formulas given in [1]. -C -C REFERENCES -C -C [1] Gu, D.-W., Petkov, P.H., and Konstantinov, M.M. -C On discrete H-infinity loop shaping design procedure routines. -C Technical Report 00-6, Dept. of Engineering, Univ. of -C Leicester, UK, 2000. -C -C NUMERICAL ASPECTS -C -C The accuracy of the results depends on the conditioning of the -C two Riccati equations solved in the controller design. For -C better conditioning it is advised to take FACTOR > 1. -C -C CONTRIBUTORS -C -C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 2001. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 2001. -C -C KEYWORDS -C -C H_infinity control, Loop-shaping design, Robust control. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, - $ LDDK, LDWORK, M, N, NP - DOUBLE PRECISION FACTOR, TOL -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - LOGICAL BWORK( * ) - DOUBLE PRECISION A ( LDA, * ), AK( LDAK, * ), B ( LDB, * ), - $ BK( LDBK, * ), C ( LDC, * ), CK( LDCK, * ), - $ D ( LDD, * ), DK( LDDK, * ), DWORK( * ), - $ RCOND( 6 ) -C .. -C .. Local Scalars .. - INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, - $ I11, I12, I13, I14, I15, I16, I17, I18, I19, - $ I20, I21, I22, I23, I24, I25, I26, INFO2, IWRK, - $ J, LWAMAX, MINWRK, N2, NS, SDIM - DOUBLE PRECISION ANORM, GAMMA, TOLL -C .. -C .. External Functions .. - LOGICAL SELECT - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLANSY, DLAPY2, SELECT -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DGECON, DGEES, DGEMM, DGETRF, DGETRS, - $ DLACPY, DLASCL, DLASET, DPOTRF, DPOTRS, DSWAP, - $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, DTRSM, - $ DTRTRS, MA02AD, MB01RX, MB02VD, SB02OD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Decode and Test input parameters. -C - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( NP.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( LDC.LT.MAX( 1, NP ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN - INFO = -11 - ELSE IF( FACTOR.LT.ONE ) THEN - INFO = -12 - ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN - INFO = -18 - ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN - INFO = -20 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -22 - END IF -C -C Compute workspace. -C - MINWRK = 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + 7*N*NP + - $ 6*N + 2*(M + NP) + MAX( 14*N+23, 16*N, 2*M-1, 2*NP-1 ) - IF( LDWORK.LT.MINWRK ) THEN - INFO = -25 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB10ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C Note that some computation could be made if one or two of the -C dimension parameters N, M, and P are zero, but the results are -C not so meaningful. -C - IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN - RCOND( 1 ) = ONE - RCOND( 2 ) = ONE - RCOND( 3 ) = ONE - RCOND( 4 ) = ONE - RCOND( 5 ) = ONE - RCOND( 6 ) = ONE - DWORK( 1 ) = ONE - RETURN - END IF -C -C Set the default tolerance, if needed. -C - IF( TOL.LE.ZERO ) THEN - TOLL = SQRT( DLAMCH( 'Epsilon' ) ) - ELSE - TOLL = TOL - END IF -C -C Workspace usage. -C - N2 = 2*N - I1 = 1 + N*N - I2 = I1 + N*N - I3 = I2 + NP*NP - I4 = I3 + M*M - I5 = I4 + NP*NP - I6 = I5 + M*M - I7 = I6 + M*N - I8 = I7 + M*N - I9 = I8 + N*N - I10 = I9 + N*N - I11 = I10 + N2 - I12 = I11 + N2 - I13 = I12 + N2 - I14 = I13 + N2*N2 - I15 = I14 + N2*N2 -C - IWRK = I15 + N2*N2 - LWAMAX = 0 -C -C Compute R1 = Ip + D*D' . -C - CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I2 ), NP ) - CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I2 ), NP ) - CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I4 ), NP ) -C -C Factorize R1 = R'*R . -C - CALL DPOTRF( 'U', NP, DWORK( I4 ), NP, INFO2 ) -C -1 -C Compute C'*R in BK . -C - CALL MA02AD( 'F', NP, N, C, LDC, BK, LDBK ) - CALL DTRSM( 'R', 'U', 'N', 'N', N, NP, ONE, DWORK( I4 ), NP, BK, - $ LDBK ) -C -C Compute R2 = Im + D'*D . -C - CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I3 ), M ) - CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I3 ), M ) - CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I5 ), M ) -C -C Factorize R2 = U'*U . -C - CALL DPOTRF( 'U', M, DWORK( I5 ), M, INFO2 ) -C -1 -C Compute (U )'*B' . -C - CALL MA02AD( 'F', N, M, B, LDB, DWORK( I6 ), M ) - CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I6 ), M, - $ INFO2 ) -C -C Compute D'*C . -C - CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, - $ DWORK( I7 ), M ) -C -1 -C Compute (U )'*D'*C . -C - CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I7 ), M, - $ INFO2 ) -C -1 -C Compute Ar = A - B*R2 D'*C . -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I8 ), N ) - CALL DGEMM( 'T', 'N', N, N, M, -ONE, DWORK( I6 ), M, DWORK( I7 ), - $ M, ONE, DWORK( I8 ), N ) -C -1 -C Compute Cr = C'*R1 *C . -C - CALL DSYRK( 'U', 'N', N, NP, ONE, BK, LDBK, ZERO, DWORK( I9 ), N ) -C -1 -C Compute Dr = B*R2 B' in AK . -C - CALL DSYRK( 'U', 'T', N, M, ONE, DWORK( I6 ), M, ZERO, AK, LDAK ) -C -1 -C Solution of the Riccati equation Ar'*P*(In + Dr*P) Ar - P + -C Cr = 0 . - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), - $ N, AK, LDAK, DWORK( I9 ), N, DWORK, M, DWORK, N, - $ RCOND( 1 ), DWORK, N, DWORK( I10 ), DWORK( I11 ), - $ DWORK( I12 ), DWORK( I13 ), N2, DWORK( I14 ), N2, - $ DWORK( I15 ), N2, -ONE, IWORK, DWORK( IWRK ), - $ LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -C Transpose Ar . -C - DO 10 J = 1, N - 1 - CALL DSWAP( J, DWORK( I8+J ), N, DWORK( I8+J*N ), 1 ) - 10 CONTINUE -C -1 -C Solution of the Riccati equation Ar*Q*(In + Cr*Q) *Ar' - Q + -C Dr = 0 . - CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), - $ N, DWORK( I9 ), N, AK, LDAK, DWORK, M, DWORK, N, - $ RCOND( 2 ), DWORK( I1 ), N, DWORK( I10 ), - $ DWORK( I11 ), DWORK( I12 ), DWORK( I13 ), N2, - $ DWORK( I14 ), N2, DWORK( I15 ), N2, -ONE, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -C Compute gamma. -C - CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1 ), N, DWORK, N, - $ ZERO, DWORK( I8 ), N ) - CALL DGEES( 'N', 'N', SELECT, N, DWORK( I8 ), N, SDIM, - $ DWORK( I10 ), DWORK( I11 ), DWORK( IWRK ), N, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) - GAMMA = ZERO -C - DO 20 I = 0, N - 1 - GAMMA = MAX( GAMMA, DWORK( I10+I ) ) - 20 CONTINUE -C - GAMMA = FACTOR*SQRT( ONE + GAMMA ) -C -C Workspace usage. -C - I5 = I4 + NP*NP - I6 = I5 + M*M - I7 = I6 + NP*NP - I8 = I7 + NP*NP - I9 = I8 + NP*NP - I10 = I9 + NP - I11 = I10 + NP*NP - I12 = I11 + M*M - I13 = I12 + M -C - IWRK = I13 + M*M -C -C Compute the eigenvalues and eigenvectors of R1 . -C - CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) - CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -1/2 -C Compute R1 . -C - DO 40 J = 1, NP - DO 30 I = 1, NP - DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / - $ SQRT( DWORK( I9+I-1 ) ) - 30 CONTINUE - 40 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I4 ), NP ) -C -C Compute the eigenvalues and eigenvectors of R2 . -C - CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I11 ), M ) - CALL DSYEV( 'V', 'U', M, DWORK( I11 ), M, DWORK( I12 ), - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -1/2 -C Compute R2 . -C - DO 60 J = 1, M - DO 50 I = 1, M - DWORK( I13-1+I+(J-1)*M ) = DWORK( I11-1+J+(I-1)*M ) / - $ SQRT( DWORK( I12+I-1 ) ) - 50 CONTINUE - 60 CONTINUE -C - CALL DGEMM( 'N', 'N', M, M, M, ONE, DWORK( I11 ), M, DWORK( I13 ), - $ M, ZERO, DWORK( I5 ), M ) -C -C Compute R1 + C*Q*C' . -C - CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1 ), N, C, LDC, - $ ZERO, BK, LDBK ) - CALL MB01RX( 'L', 'U', 'N', NP, N, ONE, ONE, DWORK( I2 ), NP, - $ C, LDC, BK, LDBK, INFO2 ) - CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) -C -C Compute the eigenvalues and eigenvectors of R1 + C*Q*C' . -C - CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), - $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -1 -C Compute ( R1 + C*Q*C' ) . -C - DO 80 J = 1, NP - DO 70 I = 1, NP - DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / - $ DWORK( I9+I-1 ) - 70 CONTINUE - 80 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I6 ), NP ) -C -1 -C Compute Z2 . -C - DO 100 J = 1, NP - DO 90 I = 1, NP - DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP )* - $ SQRT( DWORK( I9+I-1 ) ) - 90 CONTINUE - 100 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I7 ), NP ) -C -C Workspace usage. -C - I9 = I8 + N*NP - I10 = I9 + N*NP - I11 = I10 + NP*M - I12 = I11 + ( NP + M )*( NP + M ) - I13 = I12 + N*( NP + M ) - I14 = I13 + N*( NP + M ) - I15 = I14 + N*N - I16 = I15 + N*N - I17 = I16 + ( NP + M )*N - I18 = I17 + ( NP + M )*( NP + M ) - I19 = I18 + ( NP + M )*N - I20 = I19 + M*N - I21 = I20 + M*NP - I22 = I21 + NP*N - I23 = I22 + N*N - I24 = I23 + N*NP - I25 = I24 + NP*NP - I26 = I25 + M*M -C - IWRK = I26 + N*M -C -C Compute A*Q*C' + B*D' . -C - CALL DGEMM( 'N', 'T', N, NP, M, ONE, B, LDB, D, LDD, ZERO, - $ DWORK( I8 ), N ) - CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, BK, LDBK, - $ ONE, DWORK( I8 ), N ) -C -1 -C Compute H = -( A*Q*C'+B*D' )*( R1 + C*Q*C' ) . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I8 ), N, - $ DWORK( I6 ), NP, ZERO, DWORK( I9 ), N ) -C -1/2 -C Compute R1 D . -C - CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I4 ), NP, D, LDD, - $ ZERO, DWORK( I10 ), NP ) -C -C Compute Rx . -C - DO 110 J = 1, NP - CALL DCOPY( J, DWORK( I2+(J-1)*NP ), 1, - $ DWORK( I11+(J-1)*(NP+M) ), 1 ) - DWORK( I11-1+J+(J-1)*(NP+M) ) = DWORK( I2-1+J+(J-1)*NP ) - - $ GAMMA*GAMMA - 110 CONTINUE -C - CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I7 ), NP, - $ DWORK( I10 ), NP, ZERO, DWORK( I11+(NP+M)*NP ), - $ NP+M ) - CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I11+(NP+M)*NP+NP ), - $ NP+M ) -C -C Compute Bx . -C - CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I9 ), N, - $ DWORK( I7 ), NP, ZERO, DWORK( I12 ), N ) - CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DWORK( I5 ), M, - $ ZERO, DWORK( I12+N*NP ), N ) -C -C Compute Sx . -C - CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I7 ), NP, - $ ZERO, DWORK( I13 ), N ) - CALL DGEMM( 'T', 'N', N, M, NP, ONE, C, LDC, DWORK( I10 ), NP, - $ ZERO, DWORK( I13+N*NP ), N ) -C -C Compute (gamma^2 - 1)*In - P*Q . -C - CALL DLASET( 'F', N, N, ZERO, GAMMA*GAMMA-ONE, DWORK( I14 ), N ) - CALL DGEMM( 'N', 'N', N, N, N, -ONE, DWORK, N, DWORK( I1 ), N, - $ ONE, DWORK( I14 ), N ) -C -1 -C Compute X = ((gamma^2 - 1)*In - P*Q) *gamma^2*P . -C - CALL DLACPY( 'F', N, N, DWORK, N, DWORK( I15 ), N ) - CALL DLASCL( 'G', 0, 0, ONE, GAMMA*GAMMA, N, N, DWORK( I15 ), N, - $ INFO ) - ANORM = DLANGE( '1', N, N, DWORK( I14 ), N, DWORK( IWRK ) ) - CALL DGETRF( N, N, DWORK( I14 ), N, IWORK, INFO2 ) - IF( INFO2.GT.0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGECON( '1', N, DWORK( I14 ), N, ANORM, RCOND( 3 ), - $ DWORK( IWRK ), IWORK( N+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 3 ).LT.TOLL ) THEN - INFO = 4 - RETURN - END IF - CALL DGETRS( 'N', N, N, DWORK( I14 ), N, IWORK, DWORK( I15 ), - $ N, INFO2 ) -C -C Compute Bx'*X . -C - CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I12 ), N, - $ DWORK( I15 ), N, ZERO, DWORK( I16 ), NP+M ) -C -C Compute Rx + Bx'*X*Bx . -C - CALL DLACPY( 'U', NP+M, NP+M, DWORK( I11 ), NP+M, DWORK( I17 ), - $ NP+M ) - CALL MB01RX( 'L', 'U', 'N', NP+M, N, ONE, ONE, DWORK( I17 ), NP+M, - $ DWORK( I16 ), NP+M, DWORK( I12 ), N, INFO2 ) -C -C Compute -( Sx' + Bx'*X*A ) . -C - CALL MA02AD( 'F', N, NP+M, DWORK( I13 ), N, DWORK( I18 ), NP+M ) - CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I16 ), NP+M, - $ A, LDA, -ONE, DWORK( I18 ), NP+M ) -C -C Factorize Rx + Bx'*X*Bx . -C - ANORM = DLANSY( '1', 'U', NP+M, DWORK( I17 ), NP+M, - $ DWORK( IWRK ) ) - CALL DSYTRF( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, - $ DWORK( IWRK ), LDWORK-IWRK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - CALL DSYCON( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, ANORM, - $ RCOND( 4 ), DWORK( IWRK ), IWORK( NP+M+1), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 4 ).LT.TOLL ) THEN - INFO = 5 - RETURN - END IF -C -1 -C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . -C - CALL DSYTRS( 'U', NP+M, N, DWORK( I17 ), NP+M, IWORK, - $ DWORK( I18 ), NP+M, INFO2 ) -C -C Compute B'*X . -C - CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15 ), N, - $ ZERO, DWORK( I19 ), M ) -C -C Compute -( D' - B'*X*H ) . -C - DO 130 J = 1, NP - DO 120 I = 1, M - DWORK( I20-1+I+(J-1)*M ) = -D( J, I ) - 120 CONTINUE - 130 CONTINUE -C - CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I19 ), M, - $ DWORK( I9 ), N, ONE, DWORK( I20 ), M ) -C -1 -C Compute C + Z2 *F1 . -C - CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I21 ), NP ) - CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7 ), NP, - $ DWORK( I18 ), NP+M, ONE, DWORK( I21 ), NP ) -C -C Compute R2 + B'*X*B . -C - CALL MB01RX( 'L', 'U', 'N', M, N, ONE, ONE, DWORK( I3 ), M, - $ DWORK( I19 ), M, B, LDB, INFO2 ) -C -C Factorize R2 + B'*X*B . -C - CALL DPOTRF( 'U', M, DWORK( I3 ), M, INFO2 ) -C ^ -1 -C Compute Dk = -( R2 + B'*X*B ) (D' - B'*X*H) . -C - CALL DLACPY( 'F', M, NP, DWORK( I20 ), M, DK, LDDK ) - CALL DPOTRS( 'U', M, NP, DWORK( I3 ), M, DK, LDDK, INFO2 ) -C ^ ^ -C Compute Bk = -H + B*Dk . -C - CALL DLACPY( 'F', N, NP, DWORK( I9 ), N, DWORK( I23 ), N ) - CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, - $ -ONE, DWORK( I23 ), N ) -C -1/2 -C Compute R2 *F2 . -C - CALL DGEMM( 'N', 'N', M, N, M, ONE, DWORK( I5 ), M, - $ DWORK( I18+NP ), NP+M, ZERO, CK, LDCK ) -C ^ -1/2 ^ -1 -C Compute Ck = R2 *F2 - Dk*( C + Z2 *F1 ) . -C - CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DK, LDDK, - $ DWORK( I21 ), NP, ONE, CK, LDCK ) -C ^ ^ -C Compute Ak = A + H*C + B*Ck . -C - CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I9 ), N, C, LDC, - $ ONE, AK, LDAK ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, - $ ONE, AK, LDAK ) -C ^ -C Compute Ip + D*Dk . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I24 ), NP ) - CALL DGEMM( 'N', 'N', NP, NP, M, ONE, D, LDD, DK, LDDK, - $ ONE, DWORK( I24 ), NP ) -C ^ -C Compute Im + Dk*D . -C - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I25 ), M ) - CALL DGEMM( 'N', 'N', M, M, NP, ONE, DK, LDDK, D, LDD, - $ ONE, DWORK( I25 ), M ) -C ^ ^ ^ ^ -1 -C Compute Ck = M*Ck, M = (Im + Dk*D) . -C - ANORM = DLANGE( '1', M, M, DWORK( I25 ), M, DWORK( IWRK ) ) - CALL DGETRF( M, M, DWORK( I25 ), M, IWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 7 - RETURN - END IF - CALL DGECON( '1', M, DWORK( I25 ), M, ANORM, RCOND( 6 ), - $ DWORK( IWRK ), IWORK( M+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 6 ).LT.TOLL ) THEN - INFO = 7 - RETURN - END IF - CALL DGETRS( 'N', M, N, DWORK( I25 ), M, IWORK, CK, LDCK, INFO2 ) -C ^ ^ -C Compute Dk = M*Dk . -C - CALL DGETRS( 'N', M, NP, DWORK( I25 ), M, IWORK, DK, LDDK, INFO2 ) -C ^ -C Compute Bk*D . -C - CALL DGEMM( 'N', 'N', N, M, NP, ONE, DWORK( I23 ), N, D, LDD, - $ ZERO, DWORK( I26 ), N ) -C ^ ^ -C Compute Ak = Ak - Bk*D*Ck. -C - CALL DGEMM( 'N', 'N', N, N, M, -ONE, DWORK( I26 ), N, CK, LDCK, - $ ONE, AK, LDAK ) -C ^ ^ -1 -C Compute Bk = Bk*(Ip + D*Dk) . -C - ANORM = DLANGE( '1', NP, NP, DWORK( I24 ), NP, DWORK( IWRK ) ) - CALL DLACPY( 'Full', N, NP, DWORK( I23 ), N, BK, LDBK ) - CALL MB02VD( 'N', N, NP, DWORK( I24 ), NP, IWORK, BK, LDBK, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 6 - RETURN - END IF - CALL DGECON( '1', NP, DWORK( I24 ), NP, ANORM, RCOND( 5 ), - $ DWORK( IWRK ), IWORK( NP+1 ), INFO2 ) -C -C Return if the matrix is singular to working precision. -C - IF( RCOND( 5 ).LT.TOLL ) THEN - INFO = 6 - RETURN - END IF -C -C Workspace usage. -C - I2 = 1 + NP*NP - I3 = I2 + N*NP - I4 = I3 + M*M - I5 = I4 + N*M - I6 = I5 + NP*N - I7 = I6 + M*N - I8 = I7 + N2*N2 - I9 = I8 + N2 -C - IWRK = I9 + N2 -C -C Compute Ip - D*Dk . -C - CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) - CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, - $ DWORK, NP ) -C -1 -C Compute Bk*(Ip-D*Dk) . -C - CALL DLACPY( 'Full', N, NP, BK, LDBK, DWORK( I2 ), N ) - CALL MB02VD( 'N', N, NP, DWORK, NP, IWORK, DWORK( I2 ), N, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 8 - RETURN - END IF -C -C Compute Im - Dk*D . -C - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3 ), M ) - CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, - $ DWORK( I3 ), M ) -C -1 -C Compute B*(Im-Dk*D) . -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK( I4 ), N ) - CALL MB02VD( 'N', N, M, DWORK( I3 ), M, IWORK, DWORK( I4 ), N, - $ INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 9 - RETURN - END IF -C -C Compute D*Ck . -C - CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, CK, LDCK, ZERO, - $ DWORK( I5 ), NP ) -C -C Compute Dk*C . -C - CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, - $ DWORK( I6 ), M ) -C -C Compute the closed-loop state matrix. -C - CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, - $ DWORK( I6 ), M, ONE, DWORK( I7 ), N2 ) - CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, CK, LDCK, - $ ZERO, DWORK( I7+N2*N ), N2 ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, C, LDC, - $ ZERO, DWORK( I7+N ), N2 ) - CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I7+N2*N+N ), N2 ) - CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, - $ DWORK( I5 ), NP, ONE, DWORK( I7+N2*N+N ), N2 ) -C -C Compute the closed-loop poles. -C - CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I7 ), N2, SDIM, - $ DWORK( I8 ), DWORK( I9 ), DWORK( IWRK ), N, - $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) - IF( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) -C -C Check the stability of the closed-loop system. -C - NS = 0 -C - DO 140 I = 0, N2 - 1 - IF( DLAPY2( DWORK( I8+I ), DWORK( I9+I ) ).GT.ONE ) - $ NS = NS + 1 - 140 CONTINUE -C - IF( NS.GT.0 ) THEN - INFO = 10 - RETURN - END IF -C - DWORK( 1 ) = DBLE( LWAMAX ) - RETURN -C *** Last line of SB10ZD *** - END diff --git a/slycot/src/SB10ZP.f b/slycot/src/SB10ZP.f deleted file mode 100644 index efaa9ac1..00000000 --- a/slycot/src/SB10ZP.f +++ /dev/null @@ -1,339 +0,0 @@ - SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To transform a SISO (single-input single-output) system [A,B;C,D] -C by mirroring its unstable poles and zeros in the boundary of the -C stability domain, thus preserving the frequency response of the -C system, but making it stable and minimum phase. Specifically, for -C a continuous-time system, the positive real parts of its poles -C and zeros are exchanged with their negatives. Discrete-time -C systems are first converted to continuous-time systems using a -C bilinear transformation, and finally converted back. -C -C ARGUMENTS -C -C Input/Output parameters -C -C DISCFL (input) INTEGER -C Indicates the type of the system, as follows: -C = 0: continuous-time system; -C = 1: discrete-time system. -C -C N (input/output) INTEGER -C On entry, the order of the original system. N >= 0. -C On exit, the order of the transformed, minimal system. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original system matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed matrix A, in an upper Hessenberg form. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the original system -C vector B. -C On exit, this array contains the transformed vector B. -C -C C (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the original system -C vector C. -C On exit, this array contains the transformed vector C. -C The first N-1 elements are zero (for the exit value of N). -C -C D (input/output) DOUBLE PRECISION array, dimension (1) -C On entry, this array must contain the original system -C scalar D. -C On exit, this array contains the transformed scalar D. -C -C Workspace -C -C IWORK INTEGER array, dimension max(2,N+1) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= max(N*N + 5*N, 6*N + 1 + min(1,N)). -C For optimum performance LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the discrete --> continuous transformation cannot -C be made; -C = 2: if the system poles cannot be found; -C = 3: if the inverse system cannot be found, i.e., D is -C (close to) zero; -C = 4: if the system zeros cannot be found; -C = 5: if the state-space representation of the new -C transfer function T(s) cannot be found; -C = 6: if the continuous --> discrete transformation cannot -C be made. -C -C METHOD -C -C First, if the system is discrete-time, it is transformed to -C continuous-time using alpha = beta = 1 in the bilinear -C transformation implemented in the SLICOT routine AB04MD. -C Then the eigenvalues of A, i.e., the system poles, are found. -C Then, the inverse of the original system is found and its poles, -C i.e., the system zeros, are evaluated. -C The obtained system poles Pi and zeros Zi are checked and if a -C positive real part is detected, it is exchanged by -Pi or -Zi. -C Then the polynomial coefficients of the transfer function -C T(s) = Q(s)/P(s) are found. -C The state-space representation of T(s) is then obtained. -C The system matrices B, C, D are scaled so that the transformed -C system has the same system gain as the original system. -C If the original system is discrete-time, then the result (which is -C continuous-time) is converted back to discrete-time. -C -C CONTRIBUTORS -C -C Asparuh Markovski, Technical University of Sofia, July 2003. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. -C -C KEYWORDS -C -C Bilinear transformation, stability, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -C .. -C .. Scalar Arguments .. - INTEGER DISCFL, INFO, LDA, LDWORK, N -C .. -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * ) -C .. -C .. Local Scalars .. - INTEGER I, IDW1, IDW2, IDW3, IMP, IMZ, INFO2, IWA, IWP, - $ IWPS, IWQ, IWQS, LDW1, MAXWRK, REP, REZ - DOUBLE PRECISION RCOND, SCALB, SCALC, SCALD -C .. -C .. Local Arrays .. - INTEGER INDEX(1) -C .. -C .. External Subroutines .. - EXTERNAL AB04MD, AB07ND, DCOPY, DGEEV, DLACPY, DSCAL, - $ MC01PD, TD04AD, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SIGN, SQRT -C -C Test input parameters and workspace. -C - INFO = 0 - IF ( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN - INFO = -1 - ELSE IF ( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF ( LDWORK.LT.MAX( N*N + 5*N, 6*N + 1 + MIN( 1, N ) ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB10ZP', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Workspace usage 1. -C - REP = 1 - IMP = REP + N - REZ = IMP + N - IMZ = REZ + N - IWA = REZ - IDW1 = IWA + N*N - LDW1 = LDWORK - IDW1 + 1 -C -C 1. Discrete --> continuous transformation if needed. -C - IF ( DISCFL.EQ.1 ) THEN -C -C Workspace: need max(1,N); -C prefer larger. -C - CALL AB04MD( 'D', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, - $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 1 - RETURN - END IF - MAXWRK = INT( DWORK(1) ) - ELSE - MAXWRK = 0 - END IF -C -C 2. Determine the factors for restoring system gain. -C - SCALD = D(1) - SCALC = SQRT( ABS( SCALD ) ) - SCALB = SIGN( SCALC, SCALD ) -C -C 3. Find the system poles, i.e., the eigenvalues of A. -C Workspace: need N*N + 2*N + 3*N; -C prefer larger. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IWA), N ) -C - CALL DGEEV( 'N', 'N', N, DWORK(IWA), N, DWORK(REP), DWORK(IMP), - $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, - $ INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 2 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) -C -C 4. Compute the inverse system [Ai, Bi; Ci, Di]. -C Workspace: need N*N + 2*N + 4; -C prefer larger. -C - CALL AB07ND( N, 1, A, LDA, B, LDA, C, 1, D, 1, RCOND, IWORK, - $ DWORK(IDW1), LDW1, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 3 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) -C -C 5. Find the system zeros, i.e., the eigenvalues of Ai. -C Workspace: need 4*N + 3*N; -C prefer larger. -C - IDW1 = IMZ + N - LDW1 = LDWORK - IDW1 + 1 -C - CALL DGEEV( 'N', 'N', N, A, LDA, DWORK(REZ), DWORK(IMZ), - $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, - $ INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 4 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) -C -C 6. Exchange the zeros and the poles with positive real parts with -C their negatives. -C - DO 10 I = 0, N - 1 - IF ( DWORK(REP+I).GT.ZERO ) - $ DWORK(REP+I) = -DWORK(REP+I) - IF ( DWORK(REZ+I).GT.ZERO ) - $ DWORK(REZ+I) = -DWORK(REZ+I) - 10 CONTINUE -C -C Workspace usage 2. -C - IWP = IDW1 - IDW2 = IWP + N + 1 - IWPS = 1 -C -C 7. Construct the nominator and the denominator -C of the system transfer function T( s ) = Q( s )/P( s ). -C 8. Rearrange the coefficients in Q(s) and P(s) because -C MC01PD subroutine produces them in increasing powers of s. -C Workspace: need 6*N + 2. -C - CALL MC01PD( N, DWORK(REP), DWORK(IMP), DWORK(IWP), DWORK(IDW2), - $ INFO2 ) - CALL DCOPY( N+1, DWORK(IWP), -1, DWORK(IWPS), 1 ) -C -C Workspace usage 3. -C - IWQ = IDW1 - IWQS = IWPS + N + 1 - IDW3 = IWQS + N + 1 -C - CALL MC01PD( N, DWORK(REZ), DWORK(IMZ), DWORK(IWQ), DWORK(IDW2), - $ INFO2 ) - CALL DCOPY( N+1, DWORK(IWQ), -1, DWORK(IWQS), 1 ) -C -C 9. Make the conversion T(s) --> [A, B; C, D]. -C Workspace: need 2*N + 2 + N + max(N,3); -C prefer larger. -C - INDEX(1) = N - CALL TD04AD( 'R', 1, 1, INDEX, DWORK(IWPS), 1, DWORK(IWQS), 1, 1, - $ N, A, LDA, B, LDA, C, 1, D, 1, -ONE, IWORK, - $ DWORK(IDW3), LDWORK-IDW3+1, INFO2 ) - IF ( INFO2.NE.0 ) THEN - INFO = 5 - RETURN - END IF - MAXWRK = MAX( MAXWRK, INT( DWORK(IDW3) + IDW3 - 1 ) ) -C -C 10. Scale the transformed system to the previous gain. -C - IF ( N.GT.0 ) THEN - CALL DSCAL( N, SCALB, B, 1 ) - C(N) = SCALC*C(N) - END IF -C - D(1) = SCALD -C -C 11. Continuous --> discrete transformation if needed. -C - IF ( DISCFL.EQ.1 ) THEN - CALL AB04MD( 'C', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, - $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) - - IF ( INFO2.NE.0 ) THEN - INFO = 6 - RETURN - END IF - END IF -C - DWORK(1) = MAXWRK - RETURN -C -C *** Last line of SB10ZP *** - END diff --git a/slycot/src/SB16AD.f b/slycot/src/SB16AD.f deleted file mode 100644 index 565147c9..00000000 --- a/slycot/src/SB16AD.f +++ /dev/null @@ -1,719 +0,0 @@ - SUBROUTINE SB16AD( DICO, JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL, - $ N, M, P, NC, NCR, ALPHA, A, LDA, B, LDB, - $ C, LDC, D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, - $ DC, LDDC, NCS, HSVC, TOL1, TOL2, IWORK, DWORK, - $ LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an -C original state-space controller representation (Ac,Bc,Cc,Dc) by -C using the frequency-weighted square-root or balancing-free -C square-root Balance & Truncate (B&T) or Singular Perturbation -C Approximation (SPA) model reduction methods. The algorithm tries -C to minimize the norm of the frequency-weighted error -C -C ||V*(K-Kr)*W|| -C -C where K and Kr are the transfer-function matrices of the original -C and reduced order controllers, respectively. V and W are special -C frequency-weighting transfer-function matrices constructed -C to enforce closed-loop stability and/or closed-loop performance. -C If G is the transfer-function matrix of the open-loop system, then -C the following weightings V and W can be used: -C -1 -C (a) V = (I-G*K) *G, W = I - to enforce closed-loop stability; -C -1 -C (b) V = I, W = (I-G*K) *G - to enforce closed-loop stability; -C -1 -1 -C (c) V = (I-G*K) *G, W = (I-G*K) - to enforce closed-loop -C stability and performance. -C -C G has the state space representation (A,B,C,D). -C If K is unstable, only the ALPHA-stable part of K is reduced. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the original controller as follows: -C = 'C': continuous-time controller; -C = 'D': discrete-time controller. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified Enns' method of [2]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [2]. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method; -C = 'S': use the square-root SPA method; -C = 'P': use the balancing-free square-root SPA method. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency-weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'O': stability enforcing left (output) weighting -C -1 -C V = (I-G*K) *G is used (W = I); -C = 'I': stability enforcing right (input) weighting -C -1 -C W = (I-G*K) *G is used (V = I); -C = 'P': stability and performance enforcing weightings -C -1 -1 -C V = (I-G*K) *G , W = (I-G*K) are used. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as -C follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting order NCR is fixed; -C = 'A': the resulting order NCR is automatically -C determined on basis of the given tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop system state-space -C representation, i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NC (input) INTEGER -C The order of the controller state-space representation, -C i.e., the order of the matrix AC. NC >= 0. -C -C NCR (input/output) INTEGER -C On entry with ORDSEL = 'F', NCR is the desired order of -C the resulting reduced order controller. 0 <= NCR <= NC. -C On exit, if INFO = 0, NCR is the order of the resulting -C reduced order controller. For a controller with NCU -C ALPHA-unstable eigenvalues and NCS ALPHA-stable -C eigenvalues (NCU+NCS = NC), NCR is set as follows: -C if ORDSEL = 'F', NCR is equal to -C NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired -C order on entry, NCMIN is the number of frequency-weighted -C Hankel singular values greater than NCS*EPS*S1, EPS is the -C machine precision (see LAPACK Library Routine DLAMCH) and -C S1 is the largest Hankel singular value (computed in -C HSVC(1)); NCR can be further reduced to ensure -C HSVC(NCR-NCU) > HSVC(NCR+1-NCU); -C if ORDSEL = 'A', NCR is the sum of NCU and the number of -C Hankel singular values greater than MAX(TOL1,NCS*EPS*S1). -C -C ALPHA (input) DOUBLE PRECISION -C Specifies the ALPHA-stability boundary for the eigenvalues -C of the state dynamics matrix AC. For a continuous-time -C controller (DICO = 'C'), ALPHA <= 0 is the boundary value -C for the real parts of eigenvalues; for a discrete-time -C controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the -C boundary value for the moduli of eigenvalues. -C The ALPHA-stability domain does not include the boundary. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A of the open-loop -C system. -C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N -C part of this array contains the scaled state dynamics -C matrix of the open-loop system. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix B of the open-loop system. -C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M -C part of this array contains the scaled input/state matrix -C of the open-loop system. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C of the open-loop system. -C On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N -C part of this array contains the scaled state/output matrix -C of the open-loop system. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D of the open-loop system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AC (input/output) DOUBLE PRECISION array, dimension (LDAC,NC) -C On entry, the leading NC-by-NC part of this array must -C contain the state dynamics matrix Ac of the original -C controller. -C On exit, if INFO = 0, the leading NCR-by-NCR part of this -C array contains the state dynamics matrix Acr of the -C reduced controller. The resulting Ac has a -C block-diagonal form with two blocks. -C For a system with NCU ALPHA-unstable eigenvalues and -C NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading -C NCU-by-NCU block contains the unreduced part of Ac -C corresponding to the ALPHA-unstable eigenvalues. -C The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains -C the reduced part of Ac corresponding to ALPHA-stable -C eigenvalues. -C -C LDAC INTEGER -C The leading dimension of array AC. LDAC >= MAX(1,NC). -C -C BC (input/output) DOUBLE PRECISION array, dimension (LDBC,P) -C On entry, the leading NC-by-P part of this array must -C contain the input/state matrix Bc of the original -C controller. -C On exit, if INFO = 0, the leading NCR-by-P part of this -C array contains the input/state matrix Bcr of the reduced -C controller. -C -C LDBC INTEGER -C The leading dimension of array BC. LDBC >= MAX(1,NC). -C -C CC (input/output) DOUBLE PRECISION array, dimension (LDCC,NC) -C On entry, the leading M-by-NC part of this array must -C contain the state/output matrix Cc of the original -C controller. -C On exit, if INFO = 0, the leading M-by-NCR part of this -C array contains the state/output matrix Ccr of the reduced -C controller. -C -C LDCC INTEGER -C The leading dimension of array CC. LDCC >= MAX(1,M). -C -C DC (input/output) DOUBLE PRECISION array, dimension (LDDC,P) -C On entry, the leading M-by-P part of this array must -C contain the input/output matrix Dc of the original -C controller. -C On exit, if INFO = 0, the leading M-by-P part of this -C array contains the input/output matrix Dcr of the reduced -C controller. -C -C LDDC INTEGER -C The leading dimension of array DC. LDDC >= MAX(1,M). -C -C NCS (output) INTEGER -C The dimension of the ALPHA-stable part of the controller. -C -C HSVC (output) DOUBLE PRECISION array, dimension (NC) -C If INFO = 0, the leading NCS elements of this array -C contain the frequency-weighted Hankel singular values, -C ordered decreasingly, of the ALPHA-stable part of the -C controller. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of the reduced controller. -C For model reduction, the recommended value is -C TOL1 = c*S1, where c is a constant in the -C interval [0.00001,0.001], and S1 is the largest -C frequency-weighted Hankel singular value of the -C ALPHA-stable part of the original controller -C (computed in HSVC(1)). -C If TOL1 <= 0 on entry, the used default value is -C TOL1 = NCS*EPS*S1, where NCS is the number of -C ALPHA-stable eigenvalues of Ac and EPS is the machine -C precision (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the ALPHA-stable part of the given -C controller. The recommended value is TOL2 = NCS*EPS*S1. -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(1,LIWRK1,LIWRK2) -C LIWRK1 = 0, if JOBMR = 'B'; -C LIWRK1 = NC, if JOBMR = 'F'; -C LIWRK1 = 2*NC, if JOBMR = 'S' or 'P'; -C LIWRK2 = 0, if WEIGHT = 'N'; -C LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'. -C On exit, if INFO = 0, IWORK(1) contains NCMIN, the order -C of the computed minimal realization of the stable part of -C the controller. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ), -C where -C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ -C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) -C if WEIGHT = 'I' or 'O' or 'P'; -C LFREQ = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N'; -C LFREQ = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and -C EQUIL = 'S'; -C LSQRED = MAX( 1, 2*NC*NC+5*NC ); -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NCR is greater -C than NSMIN, the sum of the order of the -C ALPHA-unstable part and the order of a minimal -C realization of the ALPHA-stable part of the given -C controller; in this case, the resulting NCR is set -C equal to NSMIN; -C = 2: with ORDSEL = 'F', the selected order NCR -C corresponds to repeated singular values for the -C ALPHA-stable part of the controller, which are -C neither all included nor all excluded from the -C reduced model; in this case, the resulting NCR is -C automatically decreased to exclude all repeated -C singular values; -C = 3: with ORDSEL = 'F', the selected order NCR is less -C than the order of the ALPHA-unstable part of the -C given controller. In this case NCR is set equal to -C the order of the ALPHA-unstable part. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the closed-loop system is not well-posed; -C its feedthrough matrix is (numerically) singular; -C = 2: the computation of the real Schur form of the -C closed-loop state matrix failed; -C = 3: the closed-loop state matrix is not stable; -C = 4: the solution of a symmetric eigenproblem failed; -C = 5: the computation of the ordered real Schur form of Ac -C failed; -C = 6: the separation of the ALPHA-stable/unstable -C diagonal blocks failed because of very close -C eigenvalues; -C = 7: the computation of Hankel singular values failed. -C -C METHOD -C -C Let K be the transfer-function matrix of the original linear -C controller -C -C d[xc(t)] = Ac*xc(t) + Bc*y(t) -C u(t) = Cc*xc(t) + Dc*y(t), (1) -C -C where d[xc(t)] is dxc(t)/dt for a continuous-time system and -C xc(t+1) for a discrete-time system. The subroutine SB16AD -C determines the matrices of a reduced order controller -C -C d[z(t)] = Acr*z(t) + Bcr*y(t) -C u(t) = Ccr*z(t) + Dcr*y(t), (2) -C -C such that the corresponding transfer-function matrix Kr minimizes -C the norm of the frequency-weighted error -C -C V*(K-Kr)*W, (3) -C -C where V and W are special stable transfer-function matrices -C chosen to enforce stability and/or performance of the closed-loop -C system [3] (see description of the parameter WEIGHT). -C -C The following procedure is used to reduce K in conjunction -C with the frequency-weighted balancing approach of [2] -C (see also [3]): -C -C 1) Decompose additively K, of order NC, as -C -C K = K1 + K2, -C -C such that K1 has only ALPHA-stable poles and K2, of order NCU, -C has only ALPHA-unstable poles. -C -C 2) Compute for K1 a B&T or SPA frequency-weighted approximation -C K1r of order NCR-NCU using the frequency-weighted balancing -C approach of [1] in conjunction with accuracy enhancing -C techniques specified by the parameter JOBMR. -C -C 3) Assemble the reduced model Kr as -C -C Kr = K1r + K2. -C -C For the reduction of the ALPHA-stable part, several accuracy -C enhancing techniques can be employed (see [2] for details). -C -C If JOBMR = 'B', the square-root B&T method of [1] is used. -C -C If JOBMR = 'F', the balancing-free square-root version of the -C B&T method [1] is used. -C -C If JOBMR = 'S', the square-root version of the SPA method [2,3] -C is used. -C -C If JOBMR = 'P', the balancing-free square-root version of the -C SPA method [2,3] is used. -C -C For each of these methods, two left and right truncation matrices -C are determined using the Cholesky factors of an input -C frequency-weighted controllability Grammian P and an output -C frequency-weighted observability Grammian Q. -C P and Q are determined as the leading NC-by-NC diagonal blocks -C of the controllability Grammian of K*W and of the -C observability Grammian of V*K. Special techniques developed in [2] -C are used to compute the Cholesky factors of P and Q directly -C (see also SLICOT Library routine SB16AY). -C The frequency-weighted Hankel singular values HSVC(1), ...., -C HSVC(NC) are computed as the square roots of the eigenvalues -C of the product P*Q. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Varga, A. and Anderson, B.D.O. -C Square-root balancing-free methods for frequency-weighted -C balancing related model reduction. -C (report in preparation) -C -C [3] Anderson, B.D.O and Liu, Y. -C Controller reduction: concepts and approaches. -C IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root -C techniques. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Sept. 2000. -C D. Sima, University of Bucharest, Sept. 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Sept.2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Sep. 2001. -C -C KEYWORDS -C -C Controller reduction, frequency weighting, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION C100, ONE, ZERO - PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT - INTEGER INFO, IWARN, LDA, LDAC, LDB, LDBC, LDC, LDCC, - $ LDD, LDDC, LDWORK, M, N, NC, NCR, NCS, P - DOUBLE PRECISION ALPHA, TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), - $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), - $ DWORK(*), HSVC(*) -C .. Local Scalars .. - LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, ISTAB, LEFTW, - $ OSTAB, PERF, RIGHTW, SPA - INTEGER IERR, IWARNL, KI, KR, KT, KTI, KU, KW, LW, MP, - $ NCU, NCU1, NMR, NNC, NRA, WRKOPT - DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB09IX, SB16AY, TB01ID, TB01KD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) - SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) - BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - ISTAB = LSAME( WEIGHT, 'I' ) - OSTAB = LSAME( WEIGHT, 'O' ) - PERF = LSAME( WEIGHT, 'P' ) - LEFTW = OSTAB .OR. PERF - RIGHTW = ISTAB .OR. PERF - FRWGHT = LEFTW .OR. RIGHTW -C - LW = 1 - NNC = N + NC - MP = M + P - IF( FRWGHT ) THEN - LW = NNC*( NNC + 2*MP ) + - $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) - ELSE - LW = NC*( MAX( M, P ) + 5 ) - IF ( LSAME( EQUIL, 'S' ) ) - $ LW = MAX( N, LW ) - END IF - LW = 2*NC*NC + MAX( 1, LW, NC*( 2*NC + 5 ) ) -C -C Check the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -4 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -6 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -7 - ELSE IF( N.LT.0 ) THEN - INFO = -8 - ELSE IF( M.LT.0 ) THEN - INFO = -9 - ELSE IF( P.LT.0 ) THEN - INFO = -10 - ELSE IF( NC.LT.0 ) THEN - INFO = -11 - ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.NC ) ) THEN - INFO = -12 - ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. - $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN - INFO = -13 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -21 - ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN - INFO = -23 - ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN - INFO = -25 - ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN - INFO = -27 - ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN - INFO = -29 - ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN - INFO = -33 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -36 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( NC, M, P ).EQ.0 ) THEN - NCR = 0 - NCS = 0 - IWORK(1) = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C and AC, BC and CC; -C A <- inv(T1)*A*T1, B <- inv(T1)*B and C <- C*T1, where T1 is a -C diagonal matrix; -C AC <- inv(T2)*AC*T2, BC <- inv(T2)*BC and CC <- CC*T2, where T2 -C is a diagonal matrix. -C -C Real workspace: need MAX(N,NC). -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - MAXRED = C100 - CALL TB01ID( 'All', NC, P, M, MAXRED, AC, LDAC, BC, LDBC, - $ CC, LDCC, DWORK, INFO ) - END IF -C -C Correct the value of ALPHA to ensure stability. -C - ALPWRK = ALPHA - IF( DISCR ) THEN - IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) - ELSE - IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) - END IF -C -C Reduce Ac to a block-diagonal real Schur form, with the -C ALPHA-unstable part in the leading diagonal position, using a -C non-orthogonal similarity transformation, AC <- inv(T)*AC*T, and -C apply the transformation to BC and CC: -C BC <- inv(T)*BC and CC <- CC*T. -C -C Workspace: need NC*(NC+5); -C prefer larger. -C - WRKOPT = 1 - KU = 1 - KR = KU + NC*NC - KI = KR + NC - KW = KI + NC -C - CALL TB01KD( DICO, 'Unstable', 'General', NC, P, M, ALPWRK, - $ AC, LDAC, BC, LDBC, CC, LDCC, NCU, DWORK(KU), NC, - $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) -C - IF( IERR.NE.0 ) THEN - IF( IERR.NE.3 ) THEN - INFO = 5 - ELSE - INFO = 6 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - IWARNL = 0 - NCS = NC - NCU - IF( FIXORD ) THEN - NRA = MAX( 0, NCR-NCU ) - IF( NCR.LT.NCU ) - $ IWARNL = 3 - ELSE - NRA = 0 - END IF -C -C Finish if only unstable part is present. -C - IF( NCS.EQ.0 ) THEN - NCR = NCU - IWORK(1) = 0 - DWORK(1) = WRKOPT - RETURN - END IF -C -C Allocate working storage. -C - KT = 1 - KTI = KT + NC*NC - KW = KTI + NC*NC -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R -C of the frequency-weighted controllability and observability -C Grammians, respectively. -C -C Real workspace: need 2*NC*NC + MAX( 1, LFREQ ), -C where -C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ -C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), -C (M+P)*(M+P+4)) -C if WEIGHT = 'I' or 'O' or 'P'; -C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'; -C prefer larger. -C Integer workspace: 2*(M+P) if WEIGHT = 'I' or 'O' or 'P'; -C 0, if WEIGHT = 'N'. -C - CALL SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, - $ A, LDA, B, LDB, C, LDC, D, LDD, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ SCALEC, SCALEO, DWORK(KTI), NC, DWORK(KT), NC, - $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute a BTA or SPA of the stable part. -C Real workspace: need 2*NC*NC + MAX( 1, 2*NC*NC+5*NC, -C NC*MAX(M,P) ); -C prefer larger. -C Integer workspace: 0, if JOBMR = 'B'; -C NC, if JOBMR = 'F'; -C 2*NC, if JOBMR = 'S' or 'P'. -C - NCU1 = NCU + 1 - CALL AB09IX( DICO, JOBMR, 'Schur', ORDSEL, NCS, P, M, NRA, SCALEC, - $ SCALEO, AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, - $ CC(1,NCU1), LDCC, DC, LDDC, DWORK(KTI), NC, - $ DWORK(KT), NC, NMR, HSVC, TOL1, TOL2, IWORK, - $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IWARN = MAX( IWARN, IWARNL ) - IF( IERR.NE.0 ) THEN - INFO = 7 - RETURN - END IF - NCR = NRA + NCU - IWORK(1) = NMR -C - DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C - RETURN -C *** Last line of SB16AD *** - END diff --git a/slycot/src/SB16AY.f b/slycot/src/SB16AY.f deleted file mode 100644 index 51438021..00000000 --- a/slycot/src/SB16AY.f +++ /dev/null @@ -1,909 +0,0 @@ - SUBROUTINE SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, - $ A, LDA, B, LDB, C, LDC, D, LDD, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ SCALEC, SCALEO, S, LDS, R, LDR, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for given state-space representations (A,B,C,D) and -C (Ac,Bc,Cc,Dc) of the transfer-function matrices of the -C open-loop system G and feedback controller K, respectively, -C the Cholesky factors of the frequency-weighted -C controllability and observability Grammians corresponding -C to a frequency-weighted model reduction problem. -C The controller must stabilize the closed-loop system. -C The state matrix Ac must be in a block-diagonal real Schur form -C Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues -C of Ac and Ac2 contains the stable eigenvalues of Ac. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the systems as follows: -C = 'C': G and K are continuous-time systems; -C = 'D': G and K are discrete-time systems. -C -C JOBC CHARACTER*1 -C Specifies the choice of frequency-weighted controllability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified Enns' method of [2]. -C -C JOBO CHARACTER*1 -C Specifies the choice of frequency-weighted observability -C Grammian as follows: -C = 'S': choice corresponding to standard Enns' method [1]; -C = 'E': choice corresponding to the stability enhanced -C modified combination method of [2]. -C -C WEIGHT CHARACTER*1 -C Specifies the type of frequency-weighting, as follows: -C = 'N': no weightings are used (V = I, W = I); -C = 'O': stability enforcing left (output) weighting -C -1 -C V = (I-G*K) *G is used (W = I); -C = 'I': stability enforcing right (input) weighting -C -1 -C W = (I-G*K) *G is used (V = I); -C = 'P': stability and performance enforcing weightings -C -1 -1 -C V = (I-G*K) *G , W = (I-G*K) are used. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop system state-space -C representation, i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NC (input) INTEGER -C The order of the controller state-space representation, -C i.e., the order of the matrix AC. NC >= 0. -C -C NCS (input) INTEGER -C The dimension of the stable part of the controller, i.e., -C the order of matrix Ac2. NC >= NCS >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system with the transfer-function -C matrix G. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C input/output matrix D of the open-loop system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C AC (input) DOUBLE PRECISION array, dimension (LDAC,NC) -C The leading NC-by-NC part of this array must contain -C the state dynamics matrix Ac of the controller in a -C block diagonal real Schur form Ac = diag(Ac1,Ac2), where -C Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable -C eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains -C the stable eigenvalues of Ac. -C -C LDAC INTEGER -C The leading dimension of array AC. LDAC >= MAX(1,NC). -C -C BC (input) DOUBLE PRECISION array, dimension (LDBC,P) -C The leading NC-by-P part of this array must contain -C the input/state matrix Bc of the controller. -C -C LDBC INTEGER -C The leading dimension of array BC. LDBC >= MAX(1,NC). -C -C CC (input) DOUBLE PRECISION array, dimension (LDCC,NC) -C The leading M-by-NC part of this array must contain -C the state/output matrix Cc of the controller. -C -C LDCC INTEGER -C The leading dimension of array CC. LDCC >= MAX(1,M). -C -C DC (input) DOUBLE PRECISION array, dimension (LDDC,P) -C The leading M-by-P part of this array must contain -C the input/output matrix Dc of the controller. -C -C LDDC INTEGER -C The leading dimension of array DC. LDDC >= MAX(1,M). -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian. -C See METHOD. -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian. See METHOD. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,NCS) -C The leading NCS-by-NCS upper triangular part of this array -C contains the Cholesky factor S of the frequency-weighted -C controllability Grammian P = S*S'. See METHOD. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,NCS). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,NCS) -C The leading NCS-by-NCS upper triangular part of this array -C contains the Cholesky factor R of the frequency-weighted -C observability Grammian Q = R'*R. See METHOD. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,NCS). -C -C Workspace -C -C IWORK INTEGER array, dimension MAX(LIWRK) -C LIWRK = 0, if WEIGHT = 'N'; -C LIWRK = 2(M+P), if WEIGHT = 'O', 'I', or 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, LFREQ ), -C where -C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ -C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) -C if WEIGHT = 'I' or 'O' or 'P'; -C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the closed-loop system is not well-posed; -C its feedthrough matrix is (numerically) singular; -C = 2: the computation of the real Schur form of the -C closed-loop state matrix failed; -C = 3: the closed-loop state matrix is not stable; -C = 4: the solution of a symmetric eigenproblem failed; -C = 5: the NCS-by-NCS trailing part Ac2 of the state -C matrix Ac is not stable or not in a real Schur form. -C -C METHOD -C -C If JOBC = 'S', the controllability Grammian P is determined as -C follows: -C -C - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time -C controller the Lyapunov equation -C -C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0 -C -C and for a discrete-time controller -C -C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0; -C -C - if WEIGHT = 'I' or 'P', let Pi be the solution of the -C continuous-time Lyapunov equation -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0 -C -C or of the discrete-time Lyapunov equation -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, -C -C where Ai and Bi are the state and input matrices of a special -C state-space realization of the input frequency weight (see [2]); -C P results as the trailing NCS-by-NCS part of Pi partitioned as -C -C Pi = ( * * ). -C ( * P ) -C -C If JOBC = 'E', a modified controllability Grammian P1 >= P is -C determined to guarantee stability for a modified Enns' method [2]. -C -C If JOBO = 'S', the observability Grammian Q is determined as -C follows: -C -C - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time -C controller the Lyapunov equation -C -C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0 -C -C and for a discrete-time controller -C -C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0; -C -C - if WEIGHT = 'O' or 'P', let Qo be the solution of the -C continuous-time Lyapunov equation -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0 -C -C or of the discrete-time Lyapunov equation -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, -C -C where Ao and Co are the state and output matrices of a -C special state-space realization of the output frequency weight -C (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS -C part of Qo partitioned as -C -C Qo = ( Q * ) -C ( * * ) -C -C while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS -C part of Qo partitioned as -C -C Qo = ( * * ). -C ( * Q ) -C -C If JOBO = 'E', a modified observability Grammian Q1 >= Q is -C determined to guarantee stability for a modified Enns' method [2]. -C -C The routine computes directly the Cholesky factors S and R -C such that P = S*S' and Q = R'*R according to formulas -C developed in [2]. -C -C REFERENCES -C -C [1] Enns, D. -C Model reduction with balanced realizations: An error bound -C and a frequency weighted generalization. -C Proc. CDC, Las Vegas, pp. 127-132, 1984. -C -C [2] Varga, A. and Anderson, B.D.O. -C Frequency-weighted balancing related controller reduction. -C Proceedings of the 15th IFAC World Congress, July 21-26, 2002, -C Barcelona, Spain, Vol.15, Part 1, 2002-07-21. -C -C CONTRIBUTORS -C -C A. Varga, Australian National University, Canberra, November 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C May 2009. -C A. Varga, DLR Oberpfafenhofen, June 2001. -C -C -C KEYWORDS -C -C Controller reduction, frequency weighting, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBC, JOBO, WEIGHT - INTEGER INFO, LDA, LDAC, LDB, LDBC, LDC, LDCC, LDD, LDDC, - $ LDR, LDS, LDWORK, M, N, NC, NCS, P - DOUBLE PRECISION SCALEC, SCALEO -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), - $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), - $ DWORK(*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - CHARACTER JOBFAC - LOGICAL DISCR, FRWGHT, LEFTW, PERF, RIGHTW - INTEGER I, IERR, J, JJ, KI, KL, KQ, KR, KTAU, KU, KW, - $ KWA, KWB, KWC, KWD, LDU, LW, MBBAR, ME, MP, - $ NCU, NCU1, NE, NNC, NNCU, PCBAR, PE, WRKOPT - DOUBLE PRECISION RCOND, T, TOL -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL AB05PD, AB05QD, AB07ND, DCOPY, DLACPY, DLASET, - $ DSCAL, DSYEV, MB01WD, MB04OD, SB03OD, SB03OU, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, MIN, SQRT -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( WEIGHT, 'O' ) - RIGHTW = LSAME( WEIGHT, 'I' ) - PERF = LSAME( WEIGHT, 'P' ) - FRWGHT = LEFTW .OR. RIGHTW .OR. PERF -C - INFO = 0 - NNC = N + NC - MP = M + P - IF( FRWGHT ) THEN - LW = NNC*( NNC + 2*MP ) + - $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) - ELSE - LW = NCS*( MAX( M, P ) + 5 ) - END IF - LW = MAX( 1, LW ) -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) - $ THEN - INFO = -2 - ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) - $ THEN - INFO = -3 - ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( NC.LT.0 ) THEN - INFO = -8 - ELSE IF( NCS.LT.0 .OR. NCS.GT.NC ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN - INFO = -19 - ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN - INFO = -21 - ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN - INFO = -23 - ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN - INFO = -25 - ELSE IF( LDS.LT.MAX( 1, NCS ) ) THEN - INFO = -29 - ELSE IF( LDR.LT.MAX( 1, NCS ) ) THEN - INFO = -31 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -34 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16AY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - SCALEC = ONE - SCALEO = ONE - IF( MIN( NCS, M, P ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - WRKOPT = 1 - NCU = NC - NCS - NCU1 = NCU + 1 -C - IF( .NOT.PERF ) THEN -C -C Compute the Grammians in the case of no weighting or -C one-sided weighting. -C - IF( LEFTW .OR. LSAME( WEIGHT, 'N' ) ) THEN -C -C Compute the standard controllability Grammian. -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ac2*P + P*Ac2' + scalec^2*Bc2*Bc2' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ac2*P*Ac2' - P + scalec^2*Bc2*Bc2' = 0, -C -C where Bc2 is the matrix formed from the last NCS rows of Bc. -C -C Workspace: need NCS*(P+5); -C prefer larger. - KU = 1 - KTAU = KU + NCS*P - KW = KTAU + NCS -C - CALL DLACPY( 'Full', NCS, P, BC(NCU1,1), LDBC, - $ DWORK(KU), NCS ) - CALL SB03OU( DISCR, .TRUE., NCS, P, AC(NCU1,NCU1), LDAC, - $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, SCALEC, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - IF( RIGHTW .OR. LSAME( WEIGHT, 'N' ) ) THEN -C -C Compute the standard observability Grammian. -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ac2'*Q + Q*Ac2 + scaleo^2*Cc2'*Cc2 = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ac2'*Q*Ac2 - Q + scaleo^2*Cc2'*Cc2 = 0, -C -C where Cc2 is the matrix formed from the last NCS columns -C of Cc. -C -C Workspace: need NCS*(M + 5); -C prefer larger. - KU = 1 - KTAU = KU + M*NCS - KW = KTAU + NCS -C - CALL DLACPY( 'Full', M, NCS, CC(1,NCU1), LDCC, - $ DWORK(KU), M ) - CALL SB03OU( DISCR, .FALSE., NCS, M, AC(NCU1,NCU1), LDAC, - $ DWORK(KU), M, DWORK(KTAU), R, LDR, SCALEO, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C -C Finish if there are no weights. -C - IF( LSAME( WEIGHT, 'N' ) ) THEN - DWORK(1) = WRKOPT - RETURN - END IF - END IF -C - IF( FRWGHT ) THEN -C -C Allocate working storage for computing the weights. -C -C Real workspace: need MAX(1,NNC*NNC+2*NNC*MP+MP*(MP+4)); -C Integer workspace: need 2*MP. -C - KWA = 1 - KWB = KWA + NNC*NNC - KWC = KWB + NNC*MP - KWD = KWC + NNC*MP - KW = KWD + MP*MP - KL = KWD -C - IF( LEFTW ) THEN -C -C Build the extended matrices -C -C Ao = ( Ac+Bc*inv(R)*D*Cc Bc*inv(R)*C ), -C ( B*inv(Rt)*Cc A+B*Dc*inv(R)*C ) -C -C Co = ( -inv(R)*D*Cc -inv(R)*C ) , -C -C where R = I-D*Dc and Rt = I-Dc*D. -C -1 -C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( K -Im ). -C ( Ge21 Ge22 ) ( -Ip G ) -C -C -1 -C Then Ge11 = -(I-G*K) *G . -C -C Construct first Ge = ( K -Im ) such that the stable part -C ( -Ip G ) -C of K is in the leading position (to avoid updating of -C QR factorization). -C - CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KWD), MP ) - CALL AB05PD( 'N', NCS, P, M, NCU, ONE, - $ AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, - $ CC(1,NCU1), LDCC, DWORK(KWD), MP, - $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ NE, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) - CALL AB05QD( 'Over', NC, P, M, N, M, P, DWORK(KWA), NNC, - $ DWORK(KWB), NNC, DWORK(KWC), MP, DWORK(KWD), - $ MP, A, LDA, B, LDB, C, LDC, D, LDD, - $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) - CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+MP*P), MP ) - CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+M), MP ) -C - ELSE -C -C Build the extended matrices -C -C Ai = ( A+B*Dc*inv(R)*C B*inv(Rt)*Cc ) , -C ( Bc*inv(R)*C Ac+Bc*inv(R)*D*Cc ) -C -C Bi = ( B*Dc*inv(R) B*inv(Rt) ) , -C ( Bc*inv(R) Bc*D*inv(Rt) ) -C -C Ci = ( -inv(R)*C -inv(R)*D*Cc ) , where -C -C R = I-D*Dc and Rt = I-Dc*D. -C -C -1 -C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( G -Ip ). -C ( Ge21 Ge22 ) ( -Im K ) -C -C -1 -1 -C Then Ge22 = -(I-G*K) *G and Ge21 = -(I-G*K) . -C -C Construct first Ge = ( G -Ip ). -C ( -Im K ) -C - CALL AB05QD( 'N', N, M, P, NC, P, M, A, LDA, B, LDB, C, LDC, - $ D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, - $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) - CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+MP*M), MP ) - CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+P), MP ) - END IF -C -1 -C Compute Ge = ( Ge11 Ge12 ). -C ( Ge21 Ge22 ) -C -C Additional real workspace: need 4*MP; -C Integer workspace: need 2*MP. -C - CALL AB07ND( NNC, MP, DWORK(KWA), NNC, DWORK(KWB), NNC, - $ DWORK(KWC), MP, DWORK(KWD), MP, RCOND, - $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C -1 ( A1 | B1 B2 ) -C Partition Ge = (--------------) and select appropriate -C ( C1 | D11 D12 ) -C ( C2 | D21 D22 ) -C -C pointers to matrices and column dimensions to define weights. -C - IF( RIGHTW ) THEN -C -C Define B2 for Ge22. -C - ME = M - KWB = KWB + NNC*P - ELSE IF( PERF ) THEN -C -C Define B1 and C2 for Ge21. -C - ME = P - KWC = KWC + M - END IF - END IF -C - IF( LEFTW .OR. PERF ) THEN -C -C Compute the frequency-weighted observability Grammian. -C -C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. -C -C Additional workspace: need NNC*(NNC+MAX(NNC,P)+7); -C prefer larger. -C - LDU = MAX( NNC, P ) - KU = KL - KQ = KU + NNC*LDU - KR = KQ + NNC*NNC - KI = KR + NNC - KW = KI + NNC -C - JOBFAC = 'N' - CALL DLACPY( 'Full', P, NNC, DWORK(KWC), MP, DWORK(KU), LDU ) - CALL SB03OD( DICO, JOBFAC, 'No-transpose', NNC, P, - $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), LDU, - $ SCALEO, DWORK(KR), DWORK(KI), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.6 ) THEN - INFO = 2 - ELSE - INFO = 3 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Ro as Ro = ( R11 R12 ). -C ( 0 R22 ) -C - IF( LEFTW ) THEN -C -C R = R11 (NCS-by-NCS). -C - CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU), LDU, R, LDR ) - ELSE -C -C Compute R such that R'*R = R22'*R22 + R12'*R12, where -C R22 is NCS-by-NCS and R12 is (N+NCU)-by-NCS. -C R22 corresponds to the stable part of the controller. -C - NNCU = N + NCU - CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(LDU+1)*NNCU), LDU, - $ R, LDR ) - KTAU = KU - CALL MB04OD( 'Full', NCS, 0, NNCU, R, LDR, - $ DWORK(KU+LDU*NNCU), LDU, DUM, 1, DUM, 1, - $ DWORK(KTAU), DWORK(KW) ) -C - DO 10 J = 1, NCS - IF( R(J,J).LT.ZERO ) - $ CALL DSCAL( NCS-J+1, -ONE, R(J,J), LDR ) - 10 CONTINUE - END IF - END IF -C - IF( RIGHTW .OR. PERF ) THEN -C -C Compute the frequency-weighted controllability Grammian. -C -C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. -C -C Additional workspace: need NNC*(NNC+MAX(NNC,P,M)+7); -C prefer larger. -C - KU = KL - KQ = KU + NNC*MAX( NNC, ME ) - KR = KQ + NNC*NNC - KI = KR + NNC - KW = KI + NNC -C - CALL DLACPY( 'Full', NNC, ME, DWORK(KWB), NNC, DWORK(KU), NNC ) - JOBFAC = 'F' - IF( RIGHTW ) JOBFAC = 'N' - CALL SB03OD( DICO, JOBFAC, 'Transpose', NNC, ME, - $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), NNC, - $ SCALEC, DWORK(KR), DWORK(KI), DWORK(KW), - $ LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.6 ) THEN - INFO = 2 - ELSE - INFO = 3 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Si as Si = ( S11 S12 ) with S22 NCS-by-NCS and -C ( 0 S22 ) -C set S = S22. -C - NNCU = N + NCU - CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(NNC+1)*NNCU), NNC, - $ S, LDS ) - END IF -C - KU = 1 - IF( LEFTW .OR. PERF ) THEN - IF( LSAME( JOBO, 'E' ) ) THEN -C -C Form Y = -Ac2'*(R'*R)-(R'*R)*Ac2 if DICO = 'C', or -C Y = -Ac2'*(R'*R)*Ac2+(R'*R) if DICO = 'D'. -C -C Workspace: need 2*NCS*NCS. -C - CALL DLACPY( 'Upper', NCS, NCS, R, LDR, DWORK(KU), NCS ) - CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, - $ DWORK(KU+NCS*NCS), NCS ) - CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', - $ NCS, -ONE, ZERO, R, LDR, DWORK(KU+NCS*NCS), - $ NCS, DWORK(KU), NCS, IERR ) -C -C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. -C - KW = KU + NCS - CALL DSYEV( 'Vectors', 'Upper', NCS, R, LDR, DWORK(KU), - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 <= 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form Cc = [ sqrt(Sigma2)*Z2' ] -C - PCBAR = 0 - JJ = KU - DO 20 J = 1, NCS - IF( DWORK(JJ).GT.TOL ) THEN - CALL DSCAL( NCS, SQRT( DWORK(JJ) ), R(1,J), 1 ) - CALL DCOPY( NCS, R(1,J), 1, DWORK(KW+PCBAR), NCS ) - PCBAR = PCBAR + 1 - END IF - JJ = JJ + 1 - 20 CONTINUE -C -C Solve for the Cholesky factor R of Q, Q = R'*R, -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0. -C -C Workspace: need NCS*(NCS + 6); -C prefer larger. -C - KU = KW - KTAU = KU + NCS*NCS - KW = KTAU + NCS -C - CALL SB03OU( DISCR, .FALSE., NCS, PCBAR, AC(NCU1,NCU1), - $ LDAC, DWORK(KU), NCS, DWORK(KTAU), R, LDR, T, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - SCALEO = SCALEO*T - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - END IF -C - IF( RIGHTW .OR. PERF ) THEN - IF( LSAME( JOBC, 'E' ) ) THEN -C -C Form X = -A2c*(S*S')-(S*S')*Ac2' if DICO = 'C', or -C X = -Ac2*(S*S')*Ac2'+(S*S') if DICO = 'D'. -C -C Workspace: need 2*NCS*NCS. -C - CALL DLACPY( 'Upper', NCS, NCS, S, LDS, DWORK(KU), NCS ) - CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, - $ DWORK(KU+NCS*NCS), NCS ) - CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', NCS, - $ -ONE, ZERO, S, LDS, DWORK(KU+NCS*NCS), NCS, - $ DWORK(KU), NCS, IERR ) -C -C Compute the eigendecomposition of X as X = Z*Sigma*Z'. -C - KW = KU + NCS - CALL DSYEV( 'Vectors', 'Upper', NCS, S, LDS, DWORK(KU), - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.GT.0 ) THEN - INFO = 4 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Partition Sigma = (Sigma1,Sigma2), such that -C Sigma1 =< 0, Sigma2 > 0. -C Partition correspondingly Z = [Z1 Z2]. -C - TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) - $ * DLAMCH( 'Epsilon') -C _ -C Form Bc = [ Z2*sqrt(Sigma2) ] -C - MBBAR = 0 - I = KW - JJ = KU - DO 30 J = 1, NCS - IF( DWORK(JJ).GT.TOL ) THEN - MBBAR = MBBAR + 1 - CALL DSCAL( NCS, SQRT( DWORK(JJ) ), S(1,J), 1 ) - CALL DCOPY( NCS, S(1,J), 1, DWORK(I), 1 ) - I = I + NCS - END IF - JJ = JJ + 1 - 30 CONTINUE -C -C Solve for the Cholesky factor S of P, P = S*S', -C the continuous-time Lyapunov equation (if DICO = 'C') -C _ _ -C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C _ _ -C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0. -C -C Workspace: need maximum NCS*(NCS + 6); -C prefer larger. -C - KU = KW - KTAU = KU + MBBAR*NCS - KW = KTAU + NCS -C - CALL SB03OU( DISCR, .TRUE., NCS, MBBAR, AC(NCU1,NCU1), LDAC, - $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, T, - $ DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 5 - RETURN - END IF - SCALEC = SCALEC*T - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C - END IF -C -C Save optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16AY *** - END diff --git a/slycot/src/SB16BD.f b/slycot/src/SB16BD.f deleted file mode 100644 index 0141f1d0..00000000 --- a/slycot/src/SB16BD.f +++ /dev/null @@ -1,652 +0,0 @@ - SUBROUTINE SB16BD( DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL, - $ N, M, P, NCR, A, LDA, B, LDB, C, LDC, D, LDD, - $ F, LDF, G, LDG, DC, LDDC, HSV, TOL1, TOL2, - $ IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given open-loop model (A,B,C,D), and for -C given state feedback gain F and full observer gain G, -C such that A+B*F and A+G*C are stable, a reduced order -C controller model (Ac,Bc,Cc,Dc) using a coprime factorization -C based controller reduction approach. For reduction, -C either the square-root or the balancing-free square-root -C versions of the Balance & Truncate (B&T) or Singular Perturbation -C Approximation (SPA) model reduction methods are used in -C conjunction with stable coprime factorization techniques. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the open-loop system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears -C in the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method; -C = 'S': use the square-root SPA method; -C = 'P': use the balancing-free square-root SPA method. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization is -C to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to perform a -C preliminary equilibration before performing -C order reduction as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting controller order NCR is fixed; -C = 'A': the resulting controller order NCR is -C automatically determined on basis of the given -C tolerance TOL1. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop state-space representation, -C i.e., the order of the matrix A. N >= 0. -C N also represents the order of the original state-feedback -C controller. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NCR (input/output) INTEGER -C On entry with ORDSEL = 'F', NCR is the desired order of -C the resulting reduced order controller. 0 <= NCR <= N. -C On exit, if INFO = 0, NCR is the order of the resulting -C reduced order controller. NCR is set as follows: -C if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR -C is the desired order on entry, and NMIN is the order of a -C minimal realization of an extended system Ge (see METHOD); -C NMIN is determined as the number of -C Hankel singular values greater than N*EPS*HNORM(Ge), -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the -C extended system (computed in HSV(1)); -C if ORDSEL = 'A', NCR is equal to the number of Hankel -C singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NCR-by-NCR part of this -C array contains the state dynamics matrix Ac of the reduced -C controller. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must -C contain the original input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must -C contain the original state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this -C array must contain the system direct input/output -C transmission matrix D. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain a stabilizing state feedback matrix. -C On exit, if INFO = 0, the leading M-by-NCR part of this -C array contains the state/output matrix Cc of the reduced -C controller. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) -C On entry, the leading N-by-P part of this array must -C contain a stabilizing observer gain matrix. -C On exit, if INFO = 0, the leading NCR-by-P part of this -C array contains the input/state matrix Bc of the reduced -C controller. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C DC (output) DOUBLE PRECISION array, dimension (LDDC,P) -C If INFO = 0, the leading M-by-P part of this array -C contains the input/output matrix Dc of the reduced -C controller. -C -C LDDC INTEGER -C The leading dimension of array DC. LDDC >= MAX(1,M). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, it contains the N Hankel singular values -C of the extended system ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C If ORDSEL = 'A', TOL1 contains the tolerance for -C determining the order of the reduced extended system. -C For model reduction, the recommended value is -C TOL1 = c*HNORM(Ge), where c is a constant in the -C interval [0.00001,0.001], and HNORM(Ge) is the -C Hankel norm of the extended system (computed in HSV(1)). -C The value TOL1 = N*EPS*HNORM(Ge) is used by default if -C TOL1 <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL1 is ignored. -C -C TOL2 DOUBLE PRECISION -C The tolerance for determining the order of a minimal -C realization of the coprime factorization controller -C (see METHOD). The recommended value is -C TOL2 = N*EPS*HNORM(Ge) (see METHOD). -C This value is used by default if TOL2 <= 0 on entry. -C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK = 0, if ORDSEL = 'F' and NCR = N. -C Otherwise, -C LIWORK = MAX(PM,M), if JOBCF = 'L', -C LIWORK = MAX(PM,P), if JOBCF = 'R', where -C PM = 0, if JOBMR = 'B', -C PM = N, if JOBMR = 'F', -C PM = MAX(1,2*N), if JOBMR = 'S' or 'P'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise, -C LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L', -C LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R', -C where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NCR is -C greater than the order of a minimal -C realization of the controller. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the reduction of A+G*C to a real Schur form -C failed; -C = 2: the matrix A+G*C is not stable (if DICO = 'C'), -C or not convergent (if DICO = 'D'); -C = 3: the computation of Hankel singular values failed; -C = 4: the reduction of A+B*F to a real Schur form -C failed; -C = 5: the matrix A+B*F is not stable (if DICO = 'C'), -C or not convergent (if DICO = 'D'). -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let Go(d) be the open-loop -C transfer-function matrix -C -1 -C Go(d) = C*(d*I-A) *B + D . -C -C Let F and G be the state feedback and observer gain matrices, -C respectively, chosen so that A+B*F and A+G*C are stable matrices. -C The controller has a transfer-function matrix K(d) given by -C -1 -C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . -C -C The closed-loop transfer-function matrix is given by -C -1 -C Gcl(d) = Go(d)(I+K(d)Go(d)) . -C -C K(d) can be expressed as a left coprime factorization (LCF), -C -1 -C K(d) = M_left(d) *N_left(d) , -C -C or as a right coprime factorization (RCF), -C -1 -C K(d) = N_right(d)*M_right(d) , -C -C where M_left(d), N_left(d), N_right(d), and M_right(d) are -C stable transfer-function matrices. -C -C The subroutine SB16BD determines the matrices of a reduced -C controller -C -C d[z(t)] = Ac*z(t) + Bc*y(t) -C u(t) = Cc*z(t) + Dc*y(t), (2) -C -C with the transfer-function matrix Kr as follows: -C -C (1) If JOBCF = 'L', the extended system -C Ge(d) = [ N_left(d) M_left(d) ] is reduced to -C Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the -C B&T or SPA methods. The reduced order controller Kr(d) -C is computed as -C -1 -C Kr(d) = M_leftr(d) *N_leftr(d) ; -C -C (2) If JOBCF = 'R', the extended system -C Ge(d) = [ N_right(d) ] is reduced to -C [ M_right(d) ] -C Ger(d) = [ N_rightr(d) ] by using either the -C [ M_rightr(d) ] -C B&T or SPA methods. The reduced order controller Kr(d) -C is computed as -C -1 -C Kr(d) = N_rightr(d)* M_rightr(d) . -C -C If ORDSEL = 'A', the order of the controller is determined by -C computing the number of Hankel singular values greater than -C the given tolerance TOL1. The Hankel singular values are -C the square roots of the eigenvalues of the product of -C the controllability and observability Grammians of the -C extended system Ge. -C -C If JOBMR = 'B', the square-root B&T method of [1] is used. -C -C If JOBMR = 'F', the balancing-free square-root version of the -C B&T method [1] is used. -C -C If JOBMR = 'S', the square-root version of the SPA method [2,3] -C is used. -C -C If JOBMR = 'P', the balancing-free square-root version of the -C SPA method [2,3] is used. -C -C REFERENCES -C -C [1] Tombs, M.S. and Postlethwaite, I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [2] Varga, A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, -C pp. 42-46, 1991. -C -C [3] Varga, A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C [4] Liu, Y., Anderson, B.D.O. and Ly, O.L. -C Coprime factorization controller reduction with Bezout -C identity induced frequency weighting. -C Automatica, vol. 26, pp. 233-249, 1990. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. -C D. Sima, University of Bucharest, August 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, -C Aug. 2001. -C -C KEYWORDS -C -C Balancing, controller reduction, coprime factorization, -C minimal realization, multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDDC, - $ LDF, LDG, LDWORK, M, N, NCR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DC(LDDC,*), DWORK(*), F(LDF,*), G(LDG,*), HSV(*) -C .. Local Scalars .. - CHARACTER JOB - LOGICAL BAL, BTA, DISCR, FIXORD, LEFT, LEQUIL, SPA, - $ WITHD - INTEGER KBE, KCE, KDE, KW, LDBE, LDCE, LDDE, LW1, LW2, - $ LWR, MAXMP, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09AD, AB09BD, DGEMM, DLACPY, DLASET, SB08GD, - $ SB08HD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - WITHD = LSAME( JOBD, 'D' ) - BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) - SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) - BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) - LEFT = LSAME( JOBCF, 'L' ) - LEQUIL = LSAME( EQUIL, 'S' ) - FIXORD = LSAME( ORDSEL, 'F' ) - MAXMP = MAX( M, P ) -C - LWR = MAX( 1, N*( 2*N + MAX( N, M+P ) + 5 ) + ( N*(N+1) )/2 ) - LW1 = (N+M)*(M+P) + MAX( LWR, 4*M ) - LW2 = (N+P)*(M+P) + MAX( LWR, 4*P ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -5 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -6 - ELSE IF( N.LT.0 ) THEN - INFO = -7 - ELSE IF( M.LT.0 ) THEN - INFO = -8 - ELSE IF( P.LT.0 ) THEN - INFO = -9 - ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN - INFO = -10 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -18 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -20 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -22 - ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN - INFO = -24 - ELSE IF( .NOT.FIXORD .AND. TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN - INFO = -27 - ELSE IF( ( ( .NOT.FIXORD .OR. NCR.LT.N ) .AND. - $ ( ( LEFT .AND. LDWORK.LT.LW1 ) ) .OR. - $ ( .NOT.LEFT .AND. LDWORK.LT.LW2 ) ) .OR. - $ ( FIXORD .AND. NCR.EQ.N .AND. LDWORK.LT.P*N ) ) THEN - INFO = -30 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16BD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. - $ ( FIXORD .AND. BTA .AND. NCR.EQ.0 ) ) THEN - NCR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF( NCR.EQ.N ) THEN -C -C Form the controller state matrix, -C Ac = A + B*F + G*C + G*D*F = A + B*F + G*(C+D*F) . -C Real workspace: need P*N. -C Integer workspace: need 0. -C - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) - IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, - $ ONE, D, LDD, F, LDF, ONE, - $ DWORK, P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, - $ LDG, DWORK, P, ONE, A, LDA ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, - $ LDB, F, LDF, ONE, A, LDA ) -C - DWORK(1) = P*N - RETURN - END IF -C - IF( BAL ) THEN - JOB = 'B' - ELSE - JOB = 'N' - END IF -C -C Reduce the coprime factors. -C - IF( LEFT ) THEN -C -C Form Ge(d) = [ N_left(d) M_left(d) ] as -C -C ( A+G*C | G B+GD ) -C (------------------) -C ( F | 0 I ) -C -C Real workspace: need (N+M)*(M+P). -C Integer workspace: need 0. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, - $ LDG, C, LDC, ONE, A, LDA ) - KBE = 1 - KDE = KBE + N*(P+M) - LDBE = MAX( 1, N ) - LDDE = M - CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KBE), LDBE ) - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KBE+N*P), LDBE ) - IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, - $ ONE, G, LDG, D, LDD, ONE, - $ DWORK(KBE+N*P), LDBE ) - CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) - CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK(KDE+M*P), LDDE ) -C -C Compute the reduced coprime factors, -C Ger(d) = [ N_leftr(d) M_leftr(d) ] , -C by using either the B&T or SPA methods. -C -C Real workspace: need (N+M)*(M+P) + -C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). -C Integer workspace: need 0, if JOBMR = 'B', -C N, if JOBMR = 'F', and -C MAX(1,2*N) if JOBMR = 'S' or 'P'. -C - KW = KDE + M*(P+M) - IF( BTA ) THEN - CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, - $ LDA, DWORK(KBE), LDBE, F, LDF, HSV, TOL1, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) - ELSE - CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, - $ LDA, DWORK(KBE), LDBE, F, LDF, DWORK(KDE), - $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - END IF - IF( INFO.NE.0 ) - $ RETURN -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute the reduced order controller, -C -1 -C Kr(d) = M_leftr(d) *N_leftr(d). -C -C Real workspace: need (N+M)*(M+P) + MAX(1,4*M). -C Integer workspace: need M. -C - CALL SB08GD( NCR, P, M, A, LDA, DWORK(KBE), LDBE, F, LDF, - $ DWORK(KDE), LDDE, DWORK(KBE+N*P), LDBE, - $ DWORK(KDE+M*P), LDDE, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Bc and Dc. -C - CALL DLACPY( 'Full', NCR, P, DWORK(KBE), LDBE, G, LDG ) - CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) -C - ELSE -C -C Form Ge(d) = [ N_right(d) ] -C [ M_right(d) ] as -C -C ( A+B*F | G ) -C (-----------) -C ( F | 0 ) -C ( C+D*F | I ) -C -C Real workspace: need (N+P)*(M+P). -C Integer workspace: need 0. -C - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, - $ LDB, F, LDF, ONE, A, LDA ) - KCE = 1 - KDE = KCE + N*(P+M) - LDCE = M+P - LDDE = LDCE - CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KCE), LDCE ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KCE+M), LDCE ) - IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, - $ ONE, D, LDD, F, LDF, ONE, - $ DWORK(KCE+M), LDCE ) - CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) - CALL DLASET( 'Full', P, P, ZERO, ONE, DWORK(KDE+M), LDDE ) -C -C Compute the reduced coprime factors, -C Ger(d) = [ N_rightr(d) ] -C [ M_rightr(d) ], -C by using either the B&T or SPA methods. -C -C Real workspace: need (N+P)*(M+P) + -C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). -C Integer workspace: need 0, if JOBMR = 'B', -C N, if JOBMR = 'F', and -C MAX(1,2*N) if JOBMR = 'S' or 'P'. -C - KW = KDE + P*(P+M) - IF( BTA ) THEN - CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, - $ LDA, G, LDG, DWORK(KCE), LDCE, HSV, TOL1, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) - ELSE - CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, - $ LDA, G, LDG, DWORK(KCE), LDCE, DWORK(KDE), - $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), - $ LDWORK-KW+1, IWARN, INFO ) - END IF - IF( INFO.NE.0 ) THEN - IF( INFO.NE.3 ) INFO = INFO + 3 - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute the reduced order controller, -C -1 -C Kr(d) = N_rightr(d)*M_rightr(d) . -C -C Real workspace: need (N+P)*(M+P) + MAX(1,4*P). -C Integer workspace: need P. -C - CALL SB08HD( NCR, P, M, A, LDA, G, LDG, DWORK(KCE), LDCE, - $ DWORK(KDE), LDDE, DWORK(KCE+M), LDCE, - $ DWORK(KDE+M), LDDE, IWORK, DWORK(KW), INFO ) -C -C Copy the reduced system matrices Cc and Dc. -C - CALL DLACPY( 'Full', M, NCR, DWORK(KCE), LDCE, F, LDF ) - CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) -C - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16BD *** - END diff --git a/slycot/src/SB16CD.f b/slycot/src/SB16CD.f deleted file mode 100644 index 677a916d..00000000 --- a/slycot/src/SB16CD.f +++ /dev/null @@ -1,526 +0,0 @@ - SUBROUTINE SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P, NCR, - $ A, LDA, B, LDB, C, LDC, D, LDD, F, LDF, G, LDG, - $ HSV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given open-loop model (A,B,C,D), and for -C given state feedback gain F and full observer gain G, -C such that A+B*F and A+G*C are stable, a reduced order -C controller model (Ac,Bc,Cc) using a coprime factorization -C based controller reduction approach. For reduction of -C coprime factors, a stability enforcing frequency-weighted -C model reduction is performed using either the square-root or -C the balancing-free square-root versions of the Balance & Truncate -C (B&T) model reduction method. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the open-loop system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears -C in the given state space model, as follows: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C JOBMR CHARACTER*1 -C Specifies the model reduction approach to be used -C as follows: -C = 'B': use the square-root B&T method; -C = 'F': use the balancing-free square-root B&T method. -C -C JOBCF CHARACTER*1 -C Specifies whether left or right coprime factorization -C of the controller is to be used as follows: -C = 'L': use left coprime factorization; -C = 'R': use right coprime factorization. -C -C ORDSEL CHARACTER*1 -C Specifies the order selection method as follows: -C = 'F': the resulting controller order NCR is fixed; -C = 'A': the resulting controller order NCR is -C automatically determined on basis of the given -C tolerance TOL. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C N also represents the order of the original state-feedback -C controller. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NCR (input/output) INTEGER -C On entry with ORDSEL = 'F', NCR is the desired order of -C the resulting reduced order controller. 0 <= NCR <= N. -C On exit, if INFO = 0, NCR is the order of the resulting -C reduced order controller. NCR is set as follows: -C if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where -C NCR is the desired order on entry, and NCRMIN is the -C number of Hankel-singular values greater than N*EPS*S1, -C where EPS is the machine precision (see LAPACK Library -C Routine DLAMCH) and S1 is the largest Hankel singular -C value (computed in HSV(1)); NCR can be further reduced -C to ensure HSV(NCR) > HSV(NCR+1); -C if ORDSEL = 'A', NCR is equal to the number of Hankel -C singular values greater than MAX(TOL,N*EPS*S1). -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if INFO = 0, the leading NCR-by-NCR part of this -C array contains the state dynamics matrix Ac of the reduced -C controller. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the open-loop system input/state matrix B. -C On exit, this array is overwritten with a NCR-by-M -C B&T approximation of the matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the open-loop system state/output matrix C. -C On exit, this array is overwritten with a P-by-NCR -C B&T approximation of the matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the system direct input/output -C transmission matrix D. -C The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) -C On entry, the leading M-by-N part of this array must -C contain a stabilizing state feedback matrix. -C On exit, if INFO = 0, the leading M-by-NCR part of this -C array contains the output/state matrix Cc of the reduced -C controller. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) -C On entry, the leading N-by-P part of this array must -C contain a stabilizing observer gain matrix. -C On exit, if INFO = 0, the leading NCR-by-P part of this -C array contains the input/state matrix Bc of the reduced -C controller. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C HSV (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, HSV contains the N frequency-weighted -C Hankel singular values ordered decreasingly (see METHOD). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C If ORDSEL = 'A', TOL contains the tolerance for -C determining the order of reduced controller. -C The recommended value is TOL = c*S1, where c is a constant -C in the interval [0.00001,0.001], and S1 is the largest -C Hankel singular value (computed in HSV(1)). -C The value TOL = N*EPS*S1 is used by default if -C TOL <= 0 on entry, where EPS is the machine precision -C (see LAPACK Library Routine DLAMCH). -C If ORDSEL = 'F', the value of TOL is ignored. -C -C Workspace -C -C IWORK INTEGER array, dimension LIWORK, where -C LIWORK = 0, if JOBMR = 'B'; -C LIWORK = N, if JOBMR = 'F'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P), -C N*(N + MAX(N,MP) + MIN(N,MP) + 6)), -C where MP = M, if JOBCF = 'L'; -C MP = P, if JOBCF = 'R'. -C For optimum performance LDWORK should be larger. -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: with ORDSEL = 'F', the selected order NCR is -C greater than the order of a minimal realization -C of the controller; -C = 2: with ORDSEL = 'F', the selected order NCR -C corresponds to repeated singular values, which are -C neither all included nor all excluded from the -C reduced controller. In this case, the resulting NCR -C is set automatically to the largest value such that -C HSV(NCR) > HSV(NCR+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: eigenvalue computation failure; -C = 2: the matrix A+G*C is not stable; -C = 3: the matrix A+B*F is not stable; -C = 4: the Lyapunov equation for computing the -C observability Grammian is (nearly) singular; -C = 5: the Lyapunov equation for computing the -C controllability Grammian is (nearly) singular; -C = 6: the computation of Hankel singular values failed. -C -C METHOD -C -C Let be the linear system -C -C d[x(t)] = Ax(t) + Bu(t) -C y(t) = Cx(t) + Du(t), (1) -C -C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) -C for a discrete-time system, and let Go(d) be the open-loop -C transfer-function matrix -C -1 -C Go(d) = C*(d*I-A) *B + D . -C -C Let F and G be the state feedback and observer gain matrices, -C respectively, chosen such that A+BF and A+GC are stable matrices. -C The controller has a transfer-function matrix K(d) given by -C -1 -C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . -C -C The closed-loop transfer function matrix is given by -C -1 -C Gcl(d) = Go(d)(I+K(d)Go(d)) . -C -C K(d) can be expressed as a left coprime factorization (LCF) -C -1 -C K(d) = M_left(d) *N_left(d), -C -C or as a right coprime factorization (RCF) -C -1 -C K(d) = N_right(d)*M_right(d) , -C -C where M_left(d), N_left(d), N_right(d), and M_right(d) are -C stable transfer-function matrices. -C -C The subroutine SB16CD determines the matrices of a reduced -C controller -C -C d[z(t)] = Ac*z(t) + Bc*y(t) -C u(t) = Cc*z(t), (2) -C -C with the transfer-function matrix Kr, using the following -C stability enforcing approach proposed in [1]: -C -C (1) If JOBCF = 'L', the frequency-weighted approximation problem -C is solved -C -C min||[M_left(d)-M_leftr(d) N_left(d)-N_leftr(d)][-Y(d)]|| , -C [ X(d)] -C where -C -1 -C G(d) = Y(d)*X(d) -C -C is a RCF of the open-loop system transfer-function matrix. -C The B&T model reduction technique is used in conjunction -C with the method proposed in [1]. -C -C (2) If JOBCF = 'R', the frequency-weighted approximation problem -C is solved -C -C min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || , -C [ M_right(d)-M_rightr(d) ] -C where -C -1 -C G(d) = V(d) *U(d) -C -C is a LCF of the open-loop system transfer-function matrix. -C The B&T model reduction technique is used in conjunction -C with the method proposed in [1]. -C -C If ORDSEL = 'A', the order of the controller is determined by -C computing the number of Hankel singular values greater than -C the given tolerance TOL. The Hankel singular values are -C the square roots of the eigenvalues of the product of -C two frequency-weighted Grammians P and Q, defined as follows. -C -C If JOBCF = 'L', then P is the controllability Grammian of a system -C of the form (A+BF,B,*,*), and Q is the observability Grammian of a -C system of the form (A+GC,*,F,*). This choice corresponds to an -C input frequency-weighted order reduction of left coprime -C factors [1]. -C -C If JOBCF = 'R', then P is the controllability Grammian of a system -C of the form (A+BF,G,*,*), and Q is the observability Grammian of a -C system of the form (A+GC,*,C,*). This choice corresponds to an -C output frequency-weighted order reduction of right coprime -C factors [1]. -C -C For the computation of truncation matrices, the B&T approach -C is used in conjunction with accuracy enhancing techniques. -C If JOBMR = 'B', the square-root B&T method of [2,4] is used. -C If JOBMR = 'F', the balancing-free square-root version of the -C B&T method [3,4] is used. -C -C REFERENCES -C -C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. -C Coprime factorization controller reduction with Bezout -C identity induced frequency weighting. -C Automatica, vol. 26, pp. 233-249, 1990. -C -C [2] Tombs, M.S. and Postlethwaite I. -C Truncated balanced realization of stable, non-minimal -C state-space systems. -C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. -C -C [3] Varga, A. -C Efficient minimal realization procedure based on balancing. -C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, -C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, -C pp. 42-46, 1991. -C -C [4] Varga, A. -C Coprime factors model reduction method based on square-root -C balancing-free techniques. -C System Analysis, Modelling and Simulation, Vol. 11, -C pp. 303-311, 1993. -C -C NUMERICAL ASPECTS -C -C The implemented methods rely on accuracy enhancing square-root or -C balancing-free square-root techniques. -C 3 -C The algorithms require less than 30N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. -C D. Sima, University of Bucharest, October 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2001. -C -C KEYWORDS -C -C Controller reduction, coprime factorization, frequency weighting, -C multivariable system, state-space model. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL - INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, - $ LDF, LDG, LDWORK, M, N, NCR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), F(LDF,*), G(LDG,*), HSV(*) -C .. Local Scalars .. - LOGICAL BAL, DISCR, FIXORD, LEFT, WITHD - INTEGER IERR, KT, KTI, KW, LW, MP, NMR, WRKOPT - DOUBLE PRECISION SCALEC, SCALEO -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB09IX, DGEMM, DLACPY, SB16CY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - IWARN = 0 - DISCR = LSAME( DICO, 'D' ) - WITHD = LSAME( JOBD, 'D' ) - BAL = LSAME( JOBMR, 'B' ) - LEFT = LSAME( JOBCF, 'L' ) - FIXORD = LSAME( ORDSEL, 'F' ) - IF( LEFT ) THEN - MP = M - ELSE - MP = P - END IF - LW = 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX( M, P ), - $ N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) ) -C -C Test the input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( BAL .OR. LSAME( JOBMR, 'F' ) ) ) THEN - INFO = -3 - ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -4 - ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN - INFO = -5 - ELSE IF( N.LT.0 ) THEN - INFO = -6 - ELSE IF( M.LT.0 ) THEN - INFO = -7 - ELSE IF( P.LT.0 ) THEN - INFO = -8 - ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -17 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -19 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -21 - ELSE IF( LDWORK.LT.LW ) THEN - INFO = -26 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 .OR. - $ ( FIXORD .AND. NCR.EQ.0 ) ) THEN - NCR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C Allocate working storage. -C - KT = 1 - KTI = KT + N*N - KW = KTI + N*N -C -C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors Su and Ru -C of the frequency-weighted controllability and observability -C Grammians, respectively. -C -C Workspace: need 2*N*N + MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), -C if JOBCF = 'L'; -C 2*N*N + MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), -C if JOBCF = 'R'. -C prefer larger. -C - CALL SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, - $ F, LDF, G, LDG, SCALEC, SCALEO, DWORK(KTI), N, - $ DWORK(KT), N, DWORK(KW), LDWORK-KW+1, INFO ) -C - IF( INFO.NE.0 ) - $ RETURN - WRKOPT = INT( DWORK(KW) ) + KW - 1 -C -C Compute a B&T approximation (Ar,Br,Cr) of (A,B,C) and -C the corresponding truncation matrices TI and T. -C -C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ); -C prefer larger. -C Integer workspace: 0, if JOBMR = 'B'; -C N, if JOBMR = 'F'. -C - CALL AB09IX( DICO, JOBMR, 'NotSchur', ORDSEL, N, M, P, NCR, - $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, - $ DWORK(KTI), N, DWORK(KT), N, NMR, HSV, TOL, TOL, - $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) - IF( IERR.NE.0 ) THEN - INFO = 6 - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Compute reduced gains Bc = Gr = TI*G and Cc = Fr = F*T. -C Workspace: need N*(2*N+MAX(M,P)). -C - CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KW), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, P, N, ONE, - $ DWORK(KTI), N, DWORK(KW), N, ZERO, G, LDG ) -C - CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KW), M ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NCR, N, ONE, - $ DWORK(KW), M, DWORK(KT), N, ZERO, F, LDF ) -C -C Form the reduced controller state matrix, -C Ac = Ar + Br*Fr + Gr*Cr + Gr*D*Fr = Ar + Br*Fr + Gr*(Cr+D*Fr) . -C -C Workspace: need P*N. -C - CALL DLACPY( 'Full', P, NCR, C, LDC, DWORK, P ) - IF( WITHD) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NCR, M, - $ ONE, D, LDD, F, LDF, ONE, DWORK, P ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, P, ONE, G, - $ LDG, DWORK, P, ONE, A, LDA ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, M, ONE, B, - $ LDB, F, LDF, ONE, A, LDA ) -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16CD *** - END diff --git a/slycot/src/SB16CY.f b/slycot/src/SB16CY.f deleted file mode 100644 index 34ebaae7..00000000 --- a/slycot/src/SB16CY.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, - $ F, LDF, G, LDG, SCALEC, SCALEO, S, LDS, R, LDR, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute, for a given open-loop model (A,B,C,0), and for -C given state feedback gain F and full observer gain G, -C such that A+B*F and A+G*C are stable, the Cholesky factors -C Su and Ru of a controllability Grammian P = Su*Su' and of -C an observability Grammian Q = Ru'*Ru corresponding to a -C frequency-weighted model reduction of the left or right coprime -C factors of the state-feedback controller. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the open-loop system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C JOBCF CHARACTER*1 -C Specifies whether a left or right coprime factorization -C of the state-feedback controller is to be used as follows: -C = 'L': use a left coprime factorization; -C = 'R': use a right coprime factorization. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the open-loop state-space representation, -C i.e., the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the open-loop system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input/state matrix B of the open-loop system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C state/output matrix C of the open-loop system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C F (input) DOUBLE PRECISION array, dimension (LDF,N) -C The leading M-by-N part of this array must contain a -C stabilizing state feedback matrix. -C -C LDF INTEGER -C The leading dimension of array F. LDF >= MAX(1,M). -C -C G (input) DOUBLE PRECISION array, dimension (LDG,P) -C The leading N-by-P part of this array must contain a -C stabilizing observer gain matrix. -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,N). -C -C SCALEC (output) DOUBLE PRECISION -C Scaling factor for the controllability Grammian. -C See METHOD. -C -C SCALEO (output) DOUBLE PRECISION -C Scaling factor for the observability Grammian. -C See METHOD. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Su of frequency-weighted -C cotrollability Grammian P = Su*Su'. See METHOD. -C -C LDS INTEGER -C The leading dimension of the array S. LDS >= MAX(1,N). -C -C R (output) DOUBLE PRECISION array, dimension (LDR,N) -C The leading N-by-N upper triangular part of this array -C contains the Cholesky factor Ru of the frequency-weighted -C observability Grammian Q = Ru'*Ru. See METHOD. -C -C LDR INTEGER -C The leading dimension of the array R. LDR >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), -C if JOBCF = 'L'; -C LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), -C if JOBCF = 'R'. -C For optimum performance LDWORK should be larger. -C An upper bound for both cases is -C LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: eigenvalue computation failure; -C = 2: the matrix A+G*C is not stable; -C = 3: the matrix A+B*F is not stable; -C = 4: the Lyapunov equation for computing the -C observability Grammian is (nearly) singular; -C = 5: the Lyapunov equation for computing the -C controllability Grammian is (nearly) singular. -C -C METHOD -C -C In accordance with the type of the coprime factorization -C of the controller (left or right), the Cholesky factors Su and Ru -C of the frequency-weighted controllability Grammian P = Su*Su' and -C of the frequency-weighted observability Grammian Q = Ru'*Ru are -C computed by solving appropriate Lyapunov or Stein equations [1]. -C -C If JOBCF = 'L' and DICO = 'C', P and Q are computed as the -C solutions of the following Lyapunov equations: -C -C (A+B*F)*P + P*(A+B*F)' + scalec^2*B*B' = 0, (1) -C -C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*F'*F = 0. (2) -C -C If JOBCF = 'L' and DICO = 'D', P and Q are computed as the -C solutions of the following Stein equations: -C -C (A+B*F)*P*(A+B*F)' - P + scalec^2*B*B' = 0, (3) -C -C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*F'*F = 0. (4) -C -C If JOBCF = 'R' and DICO = 'C', P and Q are computed as the -C solutions of the following Lyapunov equations: -C -C (A+B*F)*P + P*(A+B*F)' + scalec^2*G*G' = 0, (5) -C -C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*C'*C = 0. (6) -C -C If JOBCF = 'R' and DICO = 'D', P and Q are computed as the -C solutions of the following Stein equations: -C -C (A+B*F)*P*(A+B*F)' - P + scalec^2*G*G' = 0, (7) -C -C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*C'*C = 0. (8) -C -C REFERENCES -C -C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. -C Coprime factorization controller reduction with Bezout -C identity induced frequency weighting. -C Automatica, vol. 26, pp. 233-249, 1990. -C -C CONTRIBUTORS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. -C D. Sima, University of Bucharest, October 2000. -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. -C -C REVISIONS -C -C A. Varga, Australian National University, Canberra, November 2000. -C -C KEYWORDS -C -C Controller reduction, frequency weighting, multivariable system, -C state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBCF - INTEGER INFO, LDA, LDB, LDC, LDF, LDG, LDR, LDS, LDWORK, - $ M, N, P - DOUBLE PRECISION SCALEC, SCALEO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), - $ F(LDF,*), G(LDG,*), R(LDR,*), S(LDS,*) -C .. Local Scalars .. - LOGICAL DISCR, LEFTW - INTEGER IERR, KAW, KU, KW, KWI, KWR, LDU, LW, ME, MP, - $ WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, SB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - DISCR = LSAME( DICO, 'D' ) - LEFTW = LSAME( JOBCF, 'L' ) -C - INFO = 0 - IF( LEFTW ) THEN - MP = M - ELSE - MP = P - END IF - LW = N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT.( LEFTW .OR. LSAME( JOBCF, 'R' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDF.LT.MAX( 1, M ) ) THEN - INFO = -13 - ELSE IF( LDG.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDS.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE IF( LDR.LT.MAX( 1, N ) ) THEN - INFO = -21 - ELSE IF( LDWORK.LT.MAX( 1, LW ) ) THEN - INFO = -23 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SB16CY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( N, M, P ).EQ.0 ) THEN - SCALEC = ONE - SCALEO = ONE - DWORK(1) = ONE - RETURN - END IF -C -C Allocate storage for work arrays. -C - KAW = 1 - KU = KAW + N*N - KWR = KU + N*MAX( N, MP ) - KWI = KWR + N - KW = KWI + N -C -C Form A+G*C. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) - CALL DGEMM( 'No-transpose', 'No-transpose', N, N, P, ONE, - $ G, LDG, C, LDC, ONE, DWORK(KAW), N ) -C -C Form the factor H of the free term. -C - IF( LEFTW ) THEN -C -C H = F. -C - LDU = MAX( N, M ) - ME = M - CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KU), LDU ) - ELSE -C -C H = C. -C - LDU = MAX( N, P ) - ME = P - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), LDU ) - END IF -C -C Solve for the Cholesky factor Ru of Q, Q = Ru'*Ru, -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*H'*H = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*H'*H = 0. -C -C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; -C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. -C prefer larger. -C - CALL SB03OD( DICO, 'NoFact', 'NoTransp', N, ME, DWORK(KAW), N, - $ R, LDR, DWORK(KU), LDU, SCALEO, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.2 ) THEN - INFO = 2 - ELSE IF( IERR.EQ.1 ) THEN - INFO = 4 - ELSE IF( IERR.EQ.6 ) THEN - INFO = 1 - END IF - RETURN - END IF -C - WRKOPT = INT( DWORK(KW) ) + KW - 1 - CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, R, LDR ) -C -C Form A+B*F. -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) - CALL DGEMM( 'No-transpose', 'No-transpose', N, N, M, ONE, - $ B, LDB, F, LDF, ONE, DWORK(KAW), N ) -C -C Form the factor K of the free term. -C - LDU = N - IF( LEFTW ) THEN -C -C K = B. -C - ME = M - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), LDU ) - ELSE -C -C K = G. -C - ME = P - CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KU), LDU ) - END IF -C -C Solve for the Cholesky factor Su of P, P = Su*Su', -C the continuous-time Lyapunov equation (if DICO = 'C') -C -C (A+B*F)*P + P*(A+B*F)' + scalec^2*K*K' = 0, -C -C or the discrete-time Lyapunov equation (if DICO = 'D') -C -C (A+B*F)*P*(A+B*F)' - P + scalec^2*K*K' = 0. -C -C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; -C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. -C prefer larger. -C - CALL SB03OD( DICO, 'NoFact', 'Transp', N, ME, DWORK(KAW), N, - $ S, LDS, DWORK(KU), LDU, SCALEC, DWORK(KWR), - $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) - IF( IERR.NE.0 ) THEN - IF( IERR.EQ.2 ) THEN - INFO = 3 - ELSE IF( IERR.EQ.1 ) THEN - INFO = 5 - ELSE IF( IERR.EQ.6 ) THEN - INFO = 1 - END IF - RETURN - END IF - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, S, LDS ) -C -C Save the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of SB16CY *** - END diff --git a/slycot/src/SG02AD.f b/slycot/src/SG02AD.f deleted file mode 100644 index e7a9d978..00000000 --- a/slycot/src/SG02AD.f +++ /dev/null @@ -1,939 +0,0 @@ - SUBROUTINE SG02AD( DICO, JOBB, FACT, UPLO, JOBL, SCAL, SORT, ACC, - $ N, M, P, A, LDA, E, LDE, B, LDB, Q, LDQ, R, - $ LDR, L, LDL, RCONDU, X, LDX, ALFAR, ALFAI, - $ BETA, S, LDS, T, LDT, U, LDU, TOL, IWORK, - $ DWORK, LDWORK, BWORK, IWARN, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the continuous-time algebraic Riccati -C equation -C -1 -C Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) -C -C or the discrete-time algebraic Riccati equation -C -1 -C E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) -C -C where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N, -C M-by-M and N-by-M matrices, respectively, such that Q = C'C, -C R = D'D and L = C'D; X is an N-by-N symmetric matrix. -C The routine also returns the computed values of the closed-loop -C spectrum of the system, i.e., the stable eigenvalues -C lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is -C the optimal gain matrix, -C -1 -C F = R (L+E'XB)' , for (1), -C -C and -C -1 -C F = (R+B'XB) (L+A'XB)' , for (2). -C -1 -C Optionally, matrix G = BR B' may be given instead of B and R. -C Other options include the case with Q and/or R given in a -C factored form, Q = C'C, R = D'D, and with L a zero matrix. -C -C The routine uses the method of deflating subspaces, based on -C reordering the eigenvalues in a generalized Schur matrix pair. -C -C It is assumed that E is nonsingular, but this condition is not -C checked. Note that the definition (1) of the continuous-time -C algebraic Riccati equation, and the formula for the corresponding -C optimal gain matrix, require R to be nonsingular, but the -C associated linear quadratic optimal problem could have a unique -C solution even when matrix R is singular, under mild assumptions -C (see METHOD). The routine SG02AD works accordingly in this case. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of Riccati equation to be solved as -C follows: -C = 'C': Equation (1), continuous-time case; -C = 'D': Equation (2), discrete-time case. -C -C JOBB CHARACTER*1 -C Specifies whether or not the matrix G is given, instead -C of the matrices B and R, as follows: -C = 'B': B and R are given; -C = 'G': G is given. -C -C FACT CHARACTER*1 -C Specifies whether or not the matrices Q and/or R (if -C JOBB = 'B') are factored, as follows: -C = 'N': Not factored, Q and R are given; -C = 'C': C is given, and Q = C'C; -C = 'D': D is given, and R = D'D; -C = 'B': Both factors C and D are given, Q = C'C, R = D'D. -C -C UPLO CHARACTER*1 -C If JOBB = 'G', or FACT = 'N', specifies which triangle of -C the matrices G, or Q and R, is stored, as follows: -C = 'U': Upper triangle is stored; -C = 'L': Lower triangle is stored. -C -C JOBL CHARACTER*1 -C Specifies whether or not the matrix L is zero, as follows: -C = 'Z': L is zero; -C = 'N': L is nonzero. -C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. -C SLICOT Library routine SB02MT should be called just before -C SG02AD, for obtaining the results when JOBB = 'G' and -C JOBL = 'N'. -C -C SCAL CHARACTER*1 -C If JOBB = 'B', specifies whether or not a scaling strategy -C should be used to scale Q, R, and L, as follows: -C = 'G': General scaling should be used; -C = 'N': No scaling should be used. -C SCAL is not used if JOBB = 'G'. -C -C SORT CHARACTER*1 -C Specifies which eigenvalues should be obtained in the top -C of the generalized Schur form, as follows: -C = 'S': Stable eigenvalues come first; -C = 'U': Unstable eigenvalues come first. -C -C ACC CHARACTER*1 -C Specifies whether or not iterative refinement should be -C used to solve the system of algebraic equations giving -C the solution matrix X, as follows: -C = 'R': Use iterative refinement; -C = 'N': Do not use iterative refinement. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e., the order of the -C matrices A, E, Q, and X, and the number of rows of the -C matrices B and L. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. If JOBB = 'B', M is the -C order of the matrix R, and the number of columns of the -C matrix B. M >= 0. -C M is not used if JOBB = 'G'. -C -C P (input) INTEGER -C The number of system outputs. If FACT = 'C' or 'D' or 'B', -C P is the number of rows of the matrices C and/or D. -C P >= 0. -C Otherwise, P is not used. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the descriptor system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N part of this array must contain the -C matrix E of the descriptor system. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,*) -C If JOBB = 'B', the leading N-by-M part of this array must -C contain the input matrix B of the system. -C If JOBB = 'G', the leading N-by-N upper triangular part -C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') -C of this array must contain the upper triangular part or -C lower triangular part, respectively, of the matrix -C -1 -C G = BR B'. The stricly lower triangular part (if -C UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) -C If FACT = 'N' or 'D', the leading N-by-N upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C state weighting matrix Q. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'C' or 'B', the leading P-by-N part of this -C array must contain the output matrix C of the system. -C If JOBB = 'B' and SCAL = 'G', then Q is modified -C internally, but is restored on exit. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= MAX(1,N) if FACT = 'N' or 'D'; -C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. -C -C R (input) DOUBLE PRECISION array, dimension (LDR,*) -C If FACT = 'N' or 'C', the leading M-by-M upper triangular -C part (if UPLO = 'U') or lower triangular part (if UPLO = -C 'L') of this array must contain the upper triangular part -C or lower triangular part, respectively, of the symmetric -C input weighting matrix R. The stricly lower triangular -C part (if UPLO = 'U') or stricly upper triangular part (if -C UPLO = 'L') is not referenced. -C If FACT = 'D' or 'B', the leading P-by-M part of this -C array must contain the direct transmission matrix D of the -C system. -C If JOBB = 'B' and SCAL = 'G', then R is modified -C internally, but is restored on exit. -C If JOBB = 'G', this array is not referenced. -C -C LDR INTEGER -C The leading dimension of array R. -C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; -C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; -C LDR >= 1 if JOBB = 'G'. -C -C L (input) DOUBLE PRECISION array, dimension (LDL,*) -C If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of -C this array must contain the cross weighting matrix L. -C If JOBB = 'B' and SCAL = 'G', then L is modified -C internally, but is restored on exit. -C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. -C -C LDL INTEGER -C The leading dimension of array L. -C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; -C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. -C -C RCONDU (output) DOUBLE PRECISION -C If N > 0 and INFO = 0 or INFO = 7, an estimate of the -C reciprocal of the condition number (in the 1-norm) of -C the N-th order system of algebraic equations from which -C the solution matrix X is obtained. -C -C X (output) DOUBLE PRECISION array, dimension (LDX,N) -C If INFO = 0, the leading N-by-N part of this array -C contains the solution matrix X of the problem. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) -C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) -C BETA (output) DOUBLE PRECISION array, dimension (2*N) -C The generalized eigenvalues of the 2N-by-2N matrix pair, -C ordered as specified by SORT (if INFO = 0, or INFO >= 5). -C For instance, if SORT = 'S', the leading N elements of -C these arrays contain the closed-loop spectrum of the -C system. Specifically, -C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for -C k = 1,2,...,N. -C -C S (output) DOUBLE PRECISION array, dimension (LDS,*) -C The leading 2N-by-2N part of this array contains the -C ordered real Schur form S of the first matrix in the -C reduced matrix pencil associated to the optimal problem, -C corresponding to the scaled Q, R, and L, if JOBB = 'B' -C and SCAL = 'G'. That is, -C -C (S S ) -C ( 11 12) -C S = ( ), -C (0 S ) -C ( 22) -C -C where S , S and S are N-by-N matrices. -C 11 12 22 -C Array S must have 2*N+M columns if JOBB = 'B', and 2*N -C columns, otherwise. -C -C LDS INTEGER -C The leading dimension of array S. -C LDS >= MAX(1,2*N+M) if JOBB = 'B'; -C LDS >= MAX(1,2*N) if JOBB = 'G'. -C -C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) -C The leading 2N-by-2N part of this array contains the -C ordered upper triangular form T of the second matrix in -C the reduced matrix pencil associated to the optimal -C problem, corresponding to the scaled Q, R, and L, if -C JOBB = 'B' and SCAL = 'G'. That is, -C -C (T T ) -C ( 11 12) -C T = ( ), -C (0 T ) -C ( 22) -C -C where T , T and T are N-by-N matrices. -C 11 12 22 -C -C LDT INTEGER -C The leading dimension of array T. -C LDT >= MAX(1,2*N+M) if JOBB = 'B'; -C LDT >= MAX(1,2*N) if JOBB = 'G'. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) -C The leading 2N-by-2N part of this array contains the right -C transformation matrix U which reduces the 2N-by-2N matrix -C pencil to the ordered generalized real Schur form (S,T). -C That is, -C -C (U U ) -C ( 11 12) -C U = ( ), -C (U U ) -C ( 21 22) -C -C where U , U , U and U are N-by-N matrices. -C 11 12 21 22 -C If JOBB = 'B' and SCAL = 'G', then U corresponds to the -C scaled pencil. If a basis for the stable deflating -C subspace of the original problem is needed, then the -C submatrix U must be multiplied by the scaling factor -C 21 -C contained in DWORK(4). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,2*N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used to test for near singularity of -C the original matrix pencil, specifically of the triangular -C M-by-M factor obtained during the reduction process. If -C the user sets TOL > 0, then the given value of TOL is used -C as a lower bound for the reciprocal condition number of -C that matrix; a matrix whose estimated condition number is -C less than 1/TOL is considered to be nonsingular. If the -C user sets TOL <= 0, then a default tolerance, defined by -C TOLDEF = EPS, is used instead, where EPS is the machine -C precision (see LAPACK Library routine DLAMCH). -C This parameter is not referenced if JOBB = 'G'. -C -C Workspace -C -C IWORK INTEGER array, dimension (LIWORK) -C LIWORK >= MAX(1,M,2*N) if JOBB = 'B'; -C LIWORK >= MAX(1,2*N) if JOBB = 'G'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the -C reciprocal of the condition number of the M-by-M bottom -C right lower triangular matrix obtained while compressing -C the matrix pencil of order 2N+M to obtain a pencil of -C order 2N. If ACC = 'R', and INFO = 0 or INFO = 7, DWORK(3) -C returns the reciprocal pivot growth factor (see SLICOT -C Library routine MB02PD) for the LU factorization of the -C coefficient matrix of the system of algebraic equations -C giving the solution matrix X; if DWORK(3) is much -C less than 1, then the computed X and RCONDU could be -C unreliable. If INFO = 0 or INFO = 7, DWORK(4) returns the -C scaling factor used to scale Q, R, and L. DWORK(4) is set -C to 1 if JOBB = 'G' or SCAL = 'N'. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; -C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. -C For optimum performance LDWORK should be larger. -C -C BWORK LOGICAL array, dimension (2*N) -C -C Warning Indicator -C -C IWARN INTEGER -C = 0: no warning; -C = 1: the computed solution may be inaccurate due to poor -C scaling or eigenvalues too close to the boundary of -C the stability domain (the imaginary axis, if -C DICO = 'C', or the unit circle, if DICO = 'D'). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the computed extended matrix pencil is singular, -C possibly due to rounding errors; -C = 2: if the QZ algorithm failed; -C = 3: if reordering of the generalized eigenvalues failed; -C = 4: if after reordering, roundoff changed values of -C some complex eigenvalues so that leading eigenvalues -C in the generalized Schur form no longer satisfy the -C stability condition; this could also be caused due -C to scaling; -C = 5: if the computed dimension of the solution does not -C equal N; -C = 6: if the spectrum is too close to the boundary of -C the stability domain; -C = 7: if a singular matrix was encountered during the -C computation of the solution matrix X. -C -C METHOD -C -C The routine uses a variant of the method of deflating subspaces -C proposed by van Dooren [1]. See also [2], [3], [4]. -C It is assumed that E is nonsingular, the triple (E,A,B) is -C strongly stabilizable and detectable (see [3]); if, in addition, -C -C - [ Q L ] -C R := [ ] >= 0 , -C [ L' R ] -C -C then the pencils -C -C discrete-time continuous-time -C -C |A 0 B| |E 0 0| |A 0 B| |E 0 0| -C |Q -E' L| - z |0 -A' 0| , |Q A' L| - s |0 -E' 0| , (3) -C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| -C -C are dichotomic, i.e., they have no eigenvalues on the boundary of -C the stability domain. The above conditions are sufficient for -C regularity of these pencils. A necessary condition is that -C rank([ B' L' R']') = m. -C -C Under these assumptions the algebraic Riccati equation is known to -C have a unique non-negative definite solution. -C The first step in the method of deflating subspaces is to form the -C extended matrices in (3), of order 2N + M. Next, these pencils are -C compressed to a form of order 2N (see [1]) -C -C lambda x A - B . -C f f -C -C This generalized eigenvalue problem is then solved using the QZ -C algorithm and the stable deflating subspace Ys is determined. -C If [Y1'|Y2']' is a basis for Ys, then the required solution is -C -1 -C X = Y2 x Y1 . -C -C REFERENCES -C -C [1] Van Dooren, P. -C A Generalized Eigenvalue Approach for Solving Riccati -C Equations. -C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. -C -C [2] Arnold, III, W.F. and Laub, A.J. -C Generalized Eigenproblem Algorithms and Software for -C Algebraic Riccati Equations. -C Proc. IEEE, 72, 1746-1754, 1984. -C -C [3] Mehrmann, V. -C The Autonomous Linear Quadratic Control Problem. Theory and -C Numerical Solution. -C Lect. Notes in Control and Information Sciences, vol. 163, -C Springer-Verlag, Berlin, 1991. -C -C [4] Sima, V. -C Algorithms for Linear-Quadratic Optimization. -C Pure and Applied Mathematics: A Series of Monographs and -C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. -C -C NUMERICAL ASPECTS -C -C This routine is particularly suited for systems where the matrix R -C is ill-conditioned, or even singular. -C -C FURTHER COMMENTS -C -C To obtain a stabilizing solution of the algebraic Riccati -C equations set SORT = 'S'. -C -C The routine can also compute the anti-stabilizing solutions of -C the algebraic Riccati equations, by specifying SORT = 'U'. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, June 2002. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, September 2002, -C December 2002. -C -C KEYWORDS -C -C Algebraic Riccati equation, closed loop system, continuous-time -C system, discrete-time system, optimal regulator, Schur form. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE, P1, FOUR - PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, - $ P1 = 0.1D0, FOUR = 4.0D0 ) -C .. Scalar Arguments .. - CHARACTER ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO - INTEGER INFO, IWARN, LDA, LDB, LDE, LDL, LDQ, LDR, LDS, - $ LDT, LDU, LDWORK, LDX, M, N, P - DOUBLE PRECISION RCONDU, TOL -C .. Array Arguments .. - LOGICAL BWORK(*) - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), - $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), - $ R(LDR,*), S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) -C .. Local Scalars .. - CHARACTER EQUED, QTYPE, RTYPE - LOGICAL COLEQU, DISCR, LFACB, LFACN, LFACQ, LFACR, - $ LJOBB, LJOBL, LJOBLN, LSCAL, LSORT, LUPLO, - $ REFINE, ROWEQU - INTEGER I, INFO1, IW, IWB, IWC, IWF, IWR, J, LDW, MP, - $ NDIM, NN, NNM, NP, NP1, WRKOPT - DOUBLE PRECISION ASYM, EPS, PIVOTU, RCONDL, RNORM, SCALE, SEPS, - $ U12M, UNORM -C .. External Functions .. - LOGICAL LSAME, SB02OU, SB02OV, SB02OW - DOUBLE PRECISION DLAMCH, DLANGE, DLANSY - EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02OU, SB02OV, - $ SB02OW -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEQRF, DGGES, - $ DLACPY, DLASCL, DLASET, DORGQR, DSCAL, DSWAP, - $ MB01SD, MB02PD, MB02VD, SB02OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, INT, MAX, SQRT -C .. Executable Statements .. -C - IWARN = 0 - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBB = LSAME( JOBB, 'B' ) - LFACN = LSAME( FACT, 'N' ) - LFACQ = LSAME( FACT, 'C' ) - LFACR = LSAME( FACT, 'D' ) - LFACB = LSAME( FACT, 'B' ) - LUPLO = LSAME( UPLO, 'U' ) - LSORT = LSAME( SORT, 'S' ) - REFINE = LSAME( ACC, 'R' ) - NN = 2*N - IF ( LJOBB ) THEN - LJOBL = LSAME( JOBL, 'Z' ) - LJOBLN = LSAME( JOBL, 'N' ) - LSCAL = LSAME( SCAL, 'G' ) - NNM = NN + M - LDW = MAX( NNM, 3*M ) - ELSE - LSCAL = .FALSE. - NNM = NN - LDW = 1 - END IF - NP1 = N + 1 -C -C Test the input scalar arguments. -C - IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB - $ .AND. .NOT.LFACN ) THEN - INFO = -3 - ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) - $ INFO = -4 - END IF - IF( INFO.EQ.0 .AND. LJOBB ) THEN - IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) THEN - INFO = -5 - ELSE IF( .NOT.LSCAL .AND. .NOT. LSAME( SCAL, 'N' ) ) THEN - INFO = -6 - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN - INFO = -7 - ELSE IF( .NOT.REFINE .AND. .NOT.LSAME( ACC, 'N' ) ) THEN - INFO = -8 - ELSE IF( N.LT.0 ) THEN - INFO = -9 - ELSE IF( LJOBB ) THEN - IF( M.LT.0 ) - $ INFO = -10 - END IF - END IF - IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN - IF( P.LT.0 ) - $ INFO = -11 - END IF - IF( INFO.EQ.0 ) THEN - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. - $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN - INFO = -19 - ELSE IF( LJOBB ) THEN - IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.MAX( 1, M ) .OR. - $ ( LFACR.OR.LFACB ) .AND. LDR.LT.MAX( 1, P ) ) THEN - INFO = -21 - ELSE IF( ( LJOBLN .AND. LDL.LT.MAX( 1, N ) ) .OR. - $ ( LJOBL .AND. LDL.LT.1 ) ) THEN - INFO = -23 - END IF - ELSE - IF( LDR.LT.1 ) THEN - INFO = -21 - ELSE IF( LDL.LT.1 ) THEN - INFO = -23 - END IF - END IF - END IF - IF( INFO.EQ.0 ) THEN - IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -26 - ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN - INFO = -31 - ELSE IF( LDT.LT.MAX( 1, NNM ) ) THEN - INFO = -33 - ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN - INFO = -35 - ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN - INFO = -39 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'SG02AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - DWORK(1) = FOUR - DWORK(4) = ONE - RETURN - END IF -C -C Start computations. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - LSCAL = LSCAL .AND. LJOBB - IF ( LSCAL ) THEN -C -C Scale the matrices Q, R (or G), and L so that -C norm(Q) + norm(R) + norm(L) = 1, -C using the 1-norm. If Q and/or R are factored, the norms of -C the factors are used. -C Workspace: need max(N,M), if FACT = 'N'; -C N, if FACT = 'D'; -C M, if FACT = 'C'. -C - IF ( LFACN .OR. LFACR ) THEN - SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) - QTYPE = UPLO - NP = N - ELSE - SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) - QTYPE = 'G' - NP = P - END IF -C - IF ( LFACN .OR. LFACQ ) THEN - RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) - RTYPE = UPLO - MP = M - ELSE - RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) - RTYPE = 'G' - MP = P - END IF - SCALE = SCALE + RNORM -C - IF ( LJOBLN ) - $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) - IF ( SCALE.EQ.ZERO ) - $ SCALE = ONE -C - CALL DLASCL( QTYPE, 0, 0, SCALE, ONE, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, SCALE, ONE, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) - ELSE - SCALE = ONE - END IF -C -C Construct the extended matrix pair. -C Workspace: need 1, if JOBB = 'G', -C max(1,2*N+M,3*M), if JOBB = 'B'; -C prefer larger. -C - CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, - $ 'Not identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, - $ LDR, L, LDL, E, LDE, S, LDS, T, LDT, TOL, IWORK, - $ DWORK, LDWORK, INFO ) -C - IF ( LSCAL ) THEN -C -C Undo scaling of the data arrays. -C - CALL DLASCL( QTYPE, 0, 0, ONE, SCALE, NP, N, Q, LDQ, INFO1 ) - CALL DLASCL( RTYPE, 0, 0, ONE, SCALE, MP, M, R, LDR, INFO1 ) - IF ( LJOBLN ) - $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) - END IF -C - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = DWORK(1) - IF ( LJOBB ) - $ RCONDL = DWORK(2) -C -C Workspace: need max(7*(2*N+1)+16,16*N); -C prefer larger. -C - IF ( DISCR ) THEN - IF ( LSORT ) THEN -C -C The natural tendency of the QZ algorithm to get the largest -C eigenvalues in the leading part of the matrix pair is -C exploited, by computing the unstable eigenvalues of the -C permuted matrix pair. -C - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, - $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) - CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) - CALL DSWAP( N, BETA (NP1), 1, BETA , 1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - ELSE - IF ( LSORT ) THEN - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - ELSE - CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, S, - $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, - $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) - END IF - END IF - IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN - INFO = 2 - ELSE IF ( INFO1.EQ.NN+2 ) THEN - INFO = 4 - ELSE IF ( INFO1.EQ.NN+3 ) THEN - INFO = 3 - ELSE IF ( NDIM.NE.N ) THEN - INFO = 5 - END IF - IF ( INFO.NE.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Take the non-identity matrix E into account and orthogonalize the -C basis. Use the array X as workspace. -C Workspace: need N; -C prefer N*NB. -C - CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, E, LDE, - $ U, LDU, ZERO, X, LDX ) - CALL DLACPY( 'Full', N, N, X, LDX, U, LDU ) - CALL DGEQRF( NN, N, U, LDU, X, DWORK, LDWORK, INFO1 ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - CALL DORGQR( NN, N, N, U, LDU, X, DWORK, LDWORK, INFO1 ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Check for the symmetry of the solution. The array X is again used -C as workspace. -C - CALL DGEMM( 'Transpose', 'No transpose', N, N, N, ONE, U, LDU, - $ U(NP1,1), LDU, ZERO, X, LDX ) - U12M = ZERO - ASYM = ZERO -C - DO 20 J = 1, N -C - DO 10 I = 1, N - U12M = MAX( U12M, ABS( X(I,J) ) ) - ASYM = MAX( ASYM, ABS( X(I,J) - X(J,I) ) ) - 10 CONTINUE -C - 20 CONTINUE -C - EPS = DLAMCH( 'Epsilon' ) - SEPS = SQRT( EPS ) - ASYM = ASYM - SEPS - IF ( ASYM.GT.P1*U12M ) THEN - INFO = 6 - RETURN - ELSE IF ( ASYM.GT.SEPS ) THEN - IWARN = 1 - END IF -C -C Compute the solution of X*U(1,1) = U(2,1). Use the (2,1) block -C of S as a workspace for factoring U(1,1). -C - IF ( REFINE ) THEN -C -C Use LU factorization and iterative refinement for finding X. -C Workspace: need 8*N. -C -C First transpose U(2,1) in-situ. -C - DO 30 I = 1, N - 1 - CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) - 30 CONTINUE -C - IWR = 1 - IWC = IWR + N - IWF = IWC + N - IWB = IWF + N - IW = IWB + N -C - CALL MB02PD( 'Equilibrate', 'Transpose', N, N, U, LDU, - $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), - $ DWORK(IWC), U(NP1,1), LDU, X, LDX, RCONDU, - $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), - $ INFO1 ) -C -C Transpose U(2,1) back in-situ. -C - DO 40 I = 1, N - 1 - CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) - 40 CONTINUE -C - IF( .NOT.LSAME( EQUED, 'N' ) ) THEN -C -C Undo the equilibration of U(1,1) and U(2,1). -C - ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) - COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) -C - IF( ROWEQU ) THEN -C - DO 50 I = 0, N - 1 - DWORK(IWR+I) = ONE / DWORK(IWR+I) - 50 CONTINUE -C - CALL MB01SD( 'Row scaling', N, N, U, LDU, DWORK(IWR), - $ DWORK(IWC) ) - END IF -C - IF( COLEQU ) THEN -C - DO 60 I = 0, N - 1 - DWORK(IWC+I) = ONE / DWORK(IWC+I) - 60 CONTINUE -C - CALL MB01SD( 'Column scaling', NN, N, U, LDU, DWORK(IWR), - $ DWORK(IWC) ) - END IF - END IF -C - PIVOTU = DWORK(IW) -C - IF ( INFO1.GT.0 ) THEN -C -C Singular matrix. Set INFO and DWORK for error return. -C - INFO = 7 - GO TO 80 - END IF -C - ELSE -C -C Use LU factorization and a standard solution algorithm. -C - CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) - CALL DLACPY( 'Full', N, N, U(NP1,1), LDU, X, LDX ) -C -C Solve the system X*U(1,1) = U(2,1). -C - CALL MB02VD( 'No Transpose', N, N, S(NP1,1), LDS, IWORK, X, - $ LDX, INFO1 ) -C - IF ( INFO1.NE.0 ) THEN - INFO = 7 - RCONDU = ZERO - GO TO 80 - ELSE -C -C Compute the norm of U(1,1). -C - UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) -C -C Estimate the reciprocal condition of U(1,1). -C Workspace: need 4*N. -C - CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCONDU, - $ DWORK, IWORK(NP1), INFO ) -C - IF ( RCONDU.LT.EPS ) THEN -C -C Nearly singular matrix. Set IWARN for warning indication. -C - IWARN = 1 - END IF - WRKOPT = MAX( WRKOPT, 4*N ) - END IF - END IF -C -C Set S(2,1) to zero. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) -C -C Make sure the solution matrix X is symmetric. -C - DO 70 I = 1, N - 1 - CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) - CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) - CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) - 70 CONTINUE -C - IF ( LSCAL ) THEN -C -C Undo scaling for the solution X. -C - CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, N, X, LDX, INFO1 ) - END IF -C - DWORK(1) = WRKOPT -C - 80 CONTINUE - IF ( LJOBB ) - $ DWORK(2) = RCONDL - IF ( REFINE ) - $ DWORK(3) = PIVOTU - DWORK(4) = SCALE -C - RETURN -C *** Last line of SG02AD *** - END diff --git a/slycot/src/SG03AD.f b/slycot/src/SG03AD.f deleted file mode 100644 index 92b5eaf1..00000000 --- a/slycot/src/SG03AD.f +++ /dev/null @@ -1,640 +0,0 @@ - SUBROUTINE SG03AD( DICO, JOB, FACT, TRANS, UPLO, N, A, LDA, E, - $ LDE, Q, LDQ, Z, LDZ, X, LDX, SCALE, SEP, FERR, - $ ALPHAR, ALPHAI, BETA, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the generalized continuous-time Lyapunov -C equation -C -C T T -C op(A) X op(E) + op(E) X op(A) = SCALE * Y, (1) -C -C or the generalized discrete-time Lyapunov equation -C -C T T -C op(A) X op(A) - op(E) X op(E) = SCALE * Y, (2) -C -C where op(M) is either M or M**T for M = A, E and the right hand -C side Y is symmetric. A, E, Y, and the solution X are N-by-N -C matrices. SCALE is an output scale factor, set to avoid overflow -C in X. -C -C Estimates of the separation and the relative forward error norm -C are provided. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies which type of the equation is considered: -C = 'C': Continuous-time equation (1); -C = 'D': Discrete-time equation (2). -C -C JOB CHARACTER*1 -C Specifies if the solution is to be computed and if the -C separation is to be estimated: -C = 'X': Compute the solution only; -C = 'S': Estimate the separation only; -C = 'B': Compute the solution and estimate the separation. -C -C FACT CHARACTER*1 -C Specifies whether the generalized real Schur -C factorization of the pencil A - lambda * E is supplied -C on entry or not: -C = 'N': Factorization is not supplied; -C = 'F': Factorization is supplied. -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': op(A) = A, op(E) = E; -C = 'T': op(A) = A**T, op(E) = E**T. -C -C UPLO CHARACTER*1 -C Specifies whether the lower or the upper triangle of the -C array X is needed on input: -C = 'L': Only the lower triangle is needed on input; -C = 'U': Only the upper triangle is needed on input. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C Hessenberg part of this array must contain the -C generalized Schur factor A_s of the matrix A (see -C definition (3) in section METHOD). A_s must be an upper -C quasitriangular matrix. The elements below the upper -C Hessenberg part of the array A are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor A_s of the matrix A. (A_s is -C an upper quasitriangular matrix.) -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C triangular part of this array must contain the -C generalized Schur factor E_s of the matrix E (see -C definition (4) in section METHOD). The elements below the -C upper triangular part of the array E are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the coefficient matrix E of the -C equation. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor E_s of the matrix E. (E_s is -C an upper triangular matrix.) -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Q from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Q need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Q from the generalized Schur -C factorization. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Z from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Z need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Z from the generalized Schur -C factorization. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if JOB = 'B' or 'X', then the leading N-by-N -C part of this array must contain the right hand side matrix -C Y of the equation. Either the lower or the upper -C triangular part of this array is needed (see mode -C parameter UPLO). -C If JOB = 'S', X is not referenced. -C On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then -C the leading N-by-N part of this array contains the -C solution matrix X of the equation. -C If JOB = 'S', X is not referenced. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C (0 < SCALE <= 1) -C -C SEP (output) DOUBLE PRECISION -C If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then -C SEP contains an estimate of the separation of the -C Lyapunov operator. -C -C FERR (output) DOUBLE PRECISION -C If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an -C estimated forward error bound for the solution X. If XTRUE -C is the true solution, FERR estimates the relative error -C in the computed solution, measured in the Frobenius norm: -C norm(X - XTRUE) / norm(XTRUE) -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C If FACT = 'N' and INFO = 0, 3, or 4, then -C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the -C eigenvalues of the matrix pencil A - lambda * E. -C If FACT = 'F', ALPHAR, ALPHAI, and BETA are not -C referenced. -C -C Workspace -C -C IWORK INTEGER array, dimension (N**2) -C IWORK is not referenced if JOB = 'X'. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. The following table -C contains the minimal work space requirements depending -C on the choice of JOB and FACT. -C -C JOB FACT | LDWORK -C -------------------+------------------- -C 'X' 'F' | MAX(1,N) -C 'X' 'N' | MAX(1,4*N,8*N+16) -C 'B', 'S' 'F' | MAX(1,2*N**2) -C 'B', 'S' 'N' | MAX(1,2*N**2,4*N,8*N+16) -C -C For optimum performance, LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: FACT = 'F' and the matrix contained in the upper -C Hessenberg part of the array A is not in upper -C quasitriangular form; -C = 2: FACT = 'N' and the pencil A - lambda * E cannot be -C reduced to generalized Schur form: LAPACK routine -C DGGES has failed to converge; -C = 3: DICO = 'D' and the pencil A - lambda * E has a -C pair of reciprocal eigenvalues. That is, lambda_i = -C 1/lambda_j for some i and j, where lambda_i and -C lambda_j are eigenvalues of A - lambda * E. Hence, -C equation (2) is singular; perturbed values were -C used to solve the equation (but the matrices A and -C E are unchanged); -C = 4: DICO = 'C' and the pencil A - lambda * E has a -C degenerate pair of eigenvalues. That is, lambda_i = -C -lambda_j for some i and j, where lambda_i and -C lambda_j are eigenvalues of A - lambda * E. Hence, -C equation (1) is singular; perturbed values were -C used to solve the equation (but the matrices A and -C E are unchanged). -C -C METHOD -C -C A straightforward generalization [3] of the method proposed by -C Bartels and Stewart [1] is utilized to solve (1) or (2). -C -C First the pencil A - lambda * E is reduced to real generalized -C Schur form A_s - lambda * E_s by means of orthogonal -C transformations (QZ-algorithm): -C -C A_s = Q**T * A * Z (upper quasitriangular) (3) -C -C E_s = Q**T * E * Z (upper triangular). (4) -C -C If FACT = 'F', this step is omitted. Assuming SCALE = 1 and -C defining -C -C ( Z**T * Y * Z : TRANS = 'N' -C Y_s = < -C ( Q**T * Y * Q : TRANS = 'T' -C -C -C ( Q**T * X * Q if TRANS = 'N' -C X_s = < (5) -C ( Z**T * X * Z if TRANS = 'T' -C -C leads to the reduced Lyapunov equation -C -C T T -C op(A_s) X_s op(E_s) + op(E_s) X_s op(A_s) = Y_s, (6) -C -C or -C T T -C op(A_s) X_s op(A_s) - op(E_s) X_s op(E_s) = Y_s, (7) -C -C which are equivalent to (1) or (2), respectively. The solution X_s -C of (6) or (7) is computed via block back substitution (if TRANS = -C 'N') or block forward substitution (if TRANS = 'T'), where the -C block order is at most 2. (See [1] and [3] for details.) -C Equation (5) yields the solution matrix X. -C -C For fast computation the estimates of the separation and the -C forward error are gained from (6) or (7) rather than (1) or -C (2), respectively. We consider (6) and (7) as special cases of the -C generalized Sylvester equation -C -C R * X * S + U * X * V = Y, (8) -C -C whose separation is defined as follows -C -C sep = sep(R,S,U,V) = min || R * X * S + U * X * V || . -C ||X|| = 1 F -C F -C -C Equation (8) is equivalent to the system of linear equations -C -C K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y), -C -C where kron is the Kronecker product of two matrices and vec -C is the mapping that stacks the columns of a matrix. If K is -C nonsingular then -C -C sep = 1 / ||K**(-1)|| . -C 2 -C -C We estimate ||K**(-1)|| by a method devised by Higham [2]. Note -C that this method yields an estimation for the 1-norm but we use it -C as an approximation for the 2-norm. Estimates for the forward -C error norm are provided by -C -C FERR = 2 * EPS * ||A_s|| * ||E_s|| / sep -C F F -C -C in the continuous-time case (1) and -C -C FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep -C F F -C -C in the discrete-time case (2). -C The reciprocal condition number, RCOND, of the Lyapunov equation -C can be estimated by FERR/EPS. -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Higham, N.J. -C FORTRAN codes for estimating the one-norm of a real or complex -C matrix, with applications to condition estimation. -C A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988. -C -C [3] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The number of flops required by the routine is given by the -C following table. Note that we count a single floating point -C arithmetic operation as one flop. c is an integer number of modest -C size (say 4 or 5). -C -C | FACT = 'F' FACT = 'N' -C -----------+------------------------------------------ -C JOB = 'B' | (26+8*c)/3 * N**3 (224+8*c)/3 * N**3 -C JOB = 'S' | 8*c/3 * N**3 (198+8*c)/3 * N**3 -C JOB = 'X' | 26/3 * N**3 224/3 * N**3 -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if DICO = 'D' and the pencil A - lambda * E has a pair of almost -C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost -C degenerate pair of eigenvalues, then the Lyapunov equation will be -C ill-conditioned. Perturbed values were used to solve the equation. -C Ill-conditioning can be detected by a very small value of the -C reciprocal condition number RCOND. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, TWO, ZERO - PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER DICO, FACT, JOB, TRANS, UPLO - DOUBLE PRECISION FERR, SCALE, SEP - INTEGER INFO, LDA, LDE, LDQ, LDWORK, LDX, LDZ, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), BETA(*), - $ DWORK(*), E(LDE,*), Q(LDQ,*), X(LDX,*), - $ Z(LDZ,*) - INTEGER IWORK(*) -C .. Local Scalars .. - CHARACTER ETRANS - DOUBLE PRECISION EST, EPS, NORMA, NORME, SCALE1 - INTEGER I, INFO1, KASE, MINWRK, OPTWRK - LOGICAL ISDISC, ISFACT, ISTRAN, ISUPPR, WANTBH, WANTSP, - $ WANTX -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DNRM2 - LOGICAL LSAME - EXTERNAL DLAMCH, DNRM2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGGES, DLACON, MB01RD, MB01RW, SG03AX, - $ SG03AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. Executable Statements .. -C -C Decode input parameters. -C - ISDISC = LSAME( DICO, 'D' ) - WANTX = LSAME( JOB, 'X' ) - WANTSP = LSAME( JOB, 'S' ) - WANTBH = LSAME( JOB, 'B' ) - ISFACT = LSAME( FACT, 'F' ) - ISTRAN = LSAME( TRANS, 'T' ) - ISUPPR = LSAME( UPLO, 'U' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( WANTX .OR. WANTSP .OR. WANTBH ) ) THEN - INFO = -2 - ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN - INFO = -3 - ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -4 - ELSEIF ( .NOT.( ISUPPR .OR. LSAME( UPLO, 'L' ) ) ) THEN - INFO = -5 - ELSEIF ( N .LT. 0 ) THEN - INFO = -6 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -10 - ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN - INFO = -12 - ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN - INFO = -14 - ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN - INFO = -16 - ELSE - INFO = 0 - END IF - IF ( INFO .EQ. 0 ) THEN -C -C Compute minimal workspace. -C - IF ( WANTX ) THEN - IF ( ISFACT ) THEN - MINWRK = MAX( N, 1 ) - ELSE - MINWRK = MAX( 8*N+16, 1 ) - END IF - ELSE - IF ( ISFACT ) THEN - MINWRK = MAX( 2*N*N, 1 ) - ELSE - MINWRK = MAX( 2*N*N, 8*N+16, 1 ) - END IF - END IF - IF ( MINWRK .GT. LDWORK ) THEN - INFO = -25 - END IF - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) THEN - SCALE = ONE - IF ( .NOT.WANTX ) SEP = ZERO - IF ( WANTBH ) FERR = ZERO - DWORK(1) = ONE - RETURN - END IF -C - IF ( ISFACT ) THEN -C -C Make sure the upper Hessenberg part of A is quasitriangular. -C - DO 20 I = 1, N-2 - IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN - INFO = 1 - RETURN - END IF - 20 CONTINUE - END IF -C - IF ( .NOT.ISFACT ) THEN -C -C Reduce A - lambda * E to generalized Schur form. -C -C A := Q**T * A * Z (upper quasitriangular) -C E := Q**T * E * Z (upper triangular) -C -C ( Workspace: >= MAX(1,4*N) ) -C - CALL DGGES( 'Vectors', 'Vectors', 'N', 0, N, A, LDA, E, LDE, - $ SDIM, ALPHAR, - $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, - $ 0, INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 2 - RETURN - END IF - OPTWRK = INT( DWORK(1) ) - ELSE - OPTWRK = MINWRK - END IF -C - IF ( WANTBH .OR. WANTX ) THEN -C -C Transform right hand side. -C -C X := Z**T * X * Z or X := Q**T * X * Q -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: >= N ) -C - IF ( LDWORK .LT. N*N ) THEN - IF ( ISTRAN ) THEN - CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Q, LDQ, - $ DWORK, INFO1 ) - ELSE - CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Z, LDZ, - $ DWORK, INFO1 ) - END IF - ELSE - IF ( ISTRAN ) THEN - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, - $ Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) - ELSE - CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, - $ Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) - END IF - END IF - IF ( .NOT.ISUPPR ) THEN - DO 40 I = 1, N-1 - CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) - 40 CONTINUE - END IF - OPTWRK = MAX( OPTWRK, N*N ) -C -C Solve reduced generalized Lyapunov equation. -C - IF ( ISDISC ) THEN - CALL SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) - IF ( INFO1 .NE. 0 ) - $ INFO = 3 - ELSE - CALL SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) - IF ( INFO1 .NE. 0 ) - $ INFO = 4 - END IF -C -C Transform the solution matrix back. -C -C X := Q * X * Q**T or X := Z * X * Z**T. -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: >= N ) -C - IF ( LDWORK .LT. N*N ) THEN - IF ( ISTRAN ) THEN - CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Z, - $ LDZ, DWORK, INFO1 ) - ELSE - CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Q, - $ LDQ, DWORK, INFO1 ) - END IF - ELSE - IF ( ISTRAN ) THEN - CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, - $ LDX, Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) - ELSE - CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, - $ LDX, Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) - END IF - END IF - DO 60 I = 1, N-1 - CALL DCOPY( N-I, X(I,I+1), LDX, X(I+1,I), 1 ) - 60 CONTINUE - END IF -C - IF ( WANTBH .OR. WANTSP ) THEN -C -C Estimate the 1-norm of the inverse Kronecker product matrix -C belonging to the reduced generalized Lyapunov equation. -C -C ( Workspace: 2*N*N ) -C - EST = ZERO - KASE = 0 - 80 CONTINUE - CALL DLACON( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE ) - IF ( KASE .NE. 0 ) THEN - IF ( ( KASE.EQ.1 .AND. .NOT.ISTRAN ) .OR. - $ ( KASE.NE.1 .AND. ISTRAN ) ) THEN - ETRANS = 'N' - ELSE - ETRANS = 'T' - END IF - IF ( ISDISC ) THEN - CALL SG03AX( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 3 - ELSE - CALL SG03AY( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 4 - END IF - GOTO 80 - END IF - SEP = SCALE1/EST - END IF -C -C Estimate the relative forward error. -C -C ( Workspace: 2*N ) -C - IF ( WANTBH ) THEN - EPS = DLAMCH( 'Precision' ) - DO 100 I = 1, N - DWORK(I) = DNRM2( MIN( I+1, N ), A(1,I), 1 ) - DWORK(N+I) = DNRM2( I, E(1,I), 1 ) - 100 CONTINUE - NORMA = DNRM2( N, DWORK, 1 ) - NORME = DNRM2( N, DWORK(N+1), 1 ) - IF ( ISDISC ) THEN - FERR = ( NORMA**2 + NORME**2 )*EPS/SEP - ELSE - FERR = TWO*NORMA*NORME*EPS/SEP - END IF - END IF -C - DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) - RETURN -C *** Last line of SG03AD *** - END diff --git a/slycot/src/SG03AX.f b/slycot/src/SG03AX.f deleted file mode 100644 index 872ed028..00000000 --- a/slycot/src/SG03AX.f +++ /dev/null @@ -1,687 +0,0 @@ - SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the reduced generalized discrete-time -C Lyapunov equation -C -C T T -C A * X * A - E * X * E = SCALE * Y (1) -C -C or -C -C T T -C A * X * A - E * X * E = SCALE * Y (2) -C -C where the right hand side Y is symmetric. A, E, Y, and the -C solution X are N-by-N matrices. The pencil A - lambda * E must be -C in generalized Schur form (A upper quasitriangular, E upper -C triangular). SCALE is an output scale factor, set to avoid -C overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading N-by-N part of this array must -C contain the right hand side matrix Y of the equation. Only -C the upper triangular part of this matrix need be given. -C On exit, the leading N-by-N part of this array contains -C the solution matrix X of the equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C (0 < SCALE <= 1) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: equation is (almost) singular to working precision; -C perturbed values were used to solve the equation -C (but the matrices A and E are unchanged). -C -C METHOD -C -C The solution X of (1) or (2) is computed via block back -C substitution or block forward substitution, respectively. (See -C [1] and [2] for details.) -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C 8/3 * N**3 flops are required by the routine. Note that we count a -C single floating point arithmetic operation as one flop. -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDE, LDX, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) -C .. Local Scalars .. - DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, - $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 - INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) - INTEGER PIV1(4), PIV2(4) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, - $ MB02UV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Decode input parameter. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03AX', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) RETURN -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number -C of rows in this block row. -C - KL = 0 - KB = 1 -C WHILE ( KL+KB .LE. N ) DO - 20 IF ( KL+KB .LE. N ) THEN - KL = KL + KB - IF ( KL .EQ. N ) THEN - KB = 1 - ELSE - IF ( A(KL+1,KL) .NE. ZERO ) THEN - KB = 2 - ELSE - KB = 1 - END IF - END IF - KH = KL + KB - 1 -C -C Copy elements of solution already known by symmetry. -C -C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' -C - IF ( KL .GT. 1 ) THEN - DO 40 I = KL, KH - CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) - 40 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the -C number of columns in this block. -C - LL = KL - 1 - LB = 1 -C WHILE ( LL+LB .LE. N ) DO - 60 IF ( LL+LB .LE. N ) THEN - LL = LL + LB - IF ( LL .EQ. N ) THEN - LB = 1 - ELSE - IF ( A(LL+1,LL) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LH = LL + LB - 1 -C -C Update right hand sides (I). -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - -C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) + -C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) -C - IF ( LL .GT. 1 ) THEN - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, - $ A(1,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), - $ LDA, TM, 2, ONE, X(KL,LL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), - $ LDX, E(1,LL), LDE, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, ONE, E(KL,KH), - $ LDE, TM, 2, ONE, X(KH,LL), LDX ) - IF ( KB .EQ. 2 ) CALL DAXPY( LB, E(KL,KL), TM, 2, - $ X(KL,LL), LDX ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK21 - MAT(2,1) = AL11*AK12 - EL11*EK12 - MAT(2,2) = AL11*AK22 - EL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL21*AK11 - MAT(2,1) = AL12*AK11 - EL12*EK11 - MAT(2,2) = AL22*AK11 - EL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK21 - MAT(1,3) = AL21*AK11 - MAT(1,4) = AL21*AK21 -C - MAT(2,1) = AL11*AK12 - EL11*EK12 - MAT(2,2) = AL11*AK22 - EL11*EK22 - MAT(2,3) = AL21*AK12 - MAT(2,4) = AL21*AK22 -C - MAT(3,1) = AL12*AK11 - EL12*EK11 - MAT(3,2) = AL12*AK21 - MAT(3,3) = AL22*AK11 - EL22*EK11 - MAT(3,4) = AL22*AK21 -C - MAT(4,1) = AL12*AK12 - EL12*EK12 - MAT(4,2) = AL12*AK22 - EL12*EK22 - MAT(4,3) = AL22*AK12 - EL22*EK12 - MAT(4,4) = AL22*AK22 - EL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 80 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 80 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - -C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) + -C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) -C - IF ( KL .LT. LL ) THEN - CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, - $ A(LL,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), - $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) - IF ( LB .EQ. 2 ) THEN - CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) - CALL DSCAL( KB, E(LL,LL), TM, 1 ) - END IF - CALL DGEMV( 'N', KB, LB, ONE, X(KL,LL), LDX, E(LL,LH), - $ 1, ZERO, TM(1,LB), 1 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, ONE, E(KL,KH+1), - $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) - END IF -C - GOTO 60 - END IF -C END WHILE 60 -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Outer Loop. Compute block column X(:,LL:LH). LB denotes the -C number of columns in this block column. -C - LL = N + 1 -C WHILE ( LL .GT. 1 ) DO - 100 IF ( LL .GT. 1 ) THEN - LH = LL - 1 - IF ( LH .EQ. 1 ) THEN - LB = 1 - ELSE - IF ( A(LL-1,LL-2) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LL = LL - LB -C -C Copy elements of solution already known by symmetry. -C -C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' -C - IF ( LH .LT. N ) THEN - DO 120 I = LL, LH - CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) - 120 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the -C number of rows in this block. -C - KL = LH + 1 -C WHILE ( KL .GT. 1 ) DO - 140 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KB = 1 - ELSE - IF ( A(KL-1,KL-2) .NE. ZERO ) THEN - KB =2 - ELSE - KB = 1 - END IF - END IF - KL = KL - KB -C -C Update right hand sides (I). -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - -C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) + -C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' -C - IF ( KH .LT. N ) THEN - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), - $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), - $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, ONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - IF ( LB .EQ. 2 ) CALL DAXPY( KB, E(LH,LH), TM(1,2), 1, - $ X(KL,LH), 1 ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK12 - EL11*EK12 - MAT(2,1) = AL11*AK21 - MAT(2,2) = AL11*AK22 - EL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL12*AK11 - EL12*EK11 - MAT(2,1) = AL21*AK11 - MAT(2,2) = AL22*AK11 - EL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = AL11*AK11 - EL11*EK11 - MAT(1,2) = AL11*AK12 - EL11*EK12 - MAT(1,3) = AL12*AK11 - EL12*EK11 - MAT(1,4) = AL12*AK12 - EL12*EK12 -C - MAT(2,1) = AL11*AK21 - MAT(2,2) = AL11*AK22 - EL11*EK22 - MAT(2,3) = AL12*AK21 - MAT(2,4) = AL12*AK22 - EL12*EK22 -C - MAT(3,1) = AL21*AK11 - MAT(3,2) = AL21*AK12 - MAT(3,3) = AL22*AK11 - EL22*EK11 - MAT(3,4) = AL22*AK12 - EL22*EK12 -C - MAT(4,1) = AL21*AK21 - MAT(4,2) = AL21*AK22 - MAT(4,3) = AL22*AK21 - MAT(4,4) = AL22*AK22 - EL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 160 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 160 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - -C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) + -C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' -C - IF ( KL .LT. LL ) THEN - CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, - $ X(KL,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), - $ LDE, ZERO, TM, 2 ) - IF ( KB .EQ. 2 ) THEN - CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) - CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) - END IF - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, ONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - END IF -C - GOTO 140 - END IF -C END WHILE 140 -C - GOTO 100 - END IF -C END WHILE 100 -C - END IF -C - RETURN -C *** Last line of SG03AX *** - END diff --git a/slycot/src/SG03AY.f b/slycot/src/SG03AY.f deleted file mode 100644 index 4f2dfe5a..00000000 --- a/slycot/src/SG03AY.f +++ /dev/null @@ -1,686 +0,0 @@ - SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X either the reduced generalized continuous-time -C Lyapunov equation -C -C T T -C A * X * E + E * X * A = SCALE * Y (1) -C -C or -C -C T T -C A * X * E + E * X * A = SCALE * Y (2) -C -C where the right hand side Y is symmetric. A, E, Y, and the -C solution X are N-by-N matrices. The pencil A - lambda * E must be -C in generalized Schur form (A upper quasitriangular, E upper -C triangular). SCALE is an output scale factor, set to avoid -C overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading N-by-N part of this array must -C contain the right hand side matrix Y of the equation. Only -C the upper triangular part of this matrix need be given. -C On exit, the leading N-by-N part of this array contains -C the solution matrix X of the equation. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C (0 < SCALE <= 1) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: equation is (almost) singular to working precision; -C perturbed values were used to solve the equation -C (but the matrices A and E are unchanged). -C -C METHOD -C -C The solution X of (1) or (2) is computed via block back -C substitution or block forward substitution, respectively. (See -C [1] and [2] for details.) -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C 8/3 * N**3 flops are required by the routine. Note that we count a -C single floating point arithmetic operation as one flop. -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDE, LDX, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) -C .. Local Scalars .. - INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL - DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, - $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) - INTEGER PIV1(4), PIV2(4) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, - $ MB02UV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Decode input parameters. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03AY', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) RETURN -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number -C of rows in this block row. -C - KL = 0 - KB = 1 -C WHILE ( KL+KB .LE. N ) DO - 20 IF ( KL+KB .LE. N ) THEN - KL = KL + KB - IF ( KL .EQ. N ) THEN - KB = 1 - ELSE - IF ( A(KL+1,KL) .NE. ZERO ) THEN - KB = 2 - ELSE - KB = 1 - END IF - END IF - KH = KL + KB - 1 -C -C Copy elements of solution already known by symmetry. -C -C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' -C - IF ( KL .GT. 1 ) THEN - DO 40 I = KL, KH - CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) - 40 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the -C number of columns in this block. -C - LL = KL - 1 - LB = 1 -C WHILE ( LL+LB .LE. N ) DO - 60 IF ( LL+LB .LE. N ) THEN - LL = LL + LB - IF ( LL .EQ. N ) THEN - LB = 1 - ELSE - IF ( A(LL+1,LL) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LH = LL + LB - 1 -C -C Update right hand sides (I). -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - -C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) -C -C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - -C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) -C - IF ( LL .GT. 1 ) THEN - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, - $ E(1,LL), LDE, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), - $ LDA, TM, 2, ONE, X(KL,LL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, - $ A(1,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, MONE, E(KL,KH), - $ LDE, TM, 2, ONE, X(KH,LL), LDX ) - IF ( KB .EQ. 2 ) CALL DAXPY( LB, -E(KL,KL), TM, 2, - $ X(KL,LL), LDX ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK21 - MAT(2,1) = EL11*AK12 + AL11*EK12 - MAT(2,2) = EL11*AK22 + AL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = AL21*EK11 - MAT(2,1) = EL12*AK11 + AL12*EK11 - MAT(2,2) = EL22*AK11 + AL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK21 - MAT(1,3) = AL21*EK11 - MAT(1,4) = ZERO -C - MAT(2,1) = EL11*AK12 + AL11*EK12 - MAT(2,2) = EL11*AK22 + AL11*EK22 - MAT(2,3) = AL21*EK12 - MAT(2,4) = AL21*EK22 -C - MAT(3,1) = EL12*AK11 + AL12*EK11 - MAT(3,2) = EL12*AK21 - MAT(3,3) = EL22*AK11 + AL22*EK11 - MAT(3,4) = EL22*AK21 -C - MAT(4,1) = EL12*AK12 + AL12*EK12 - MAT(4,2) = EL12*AK22 + AL12*EK22 - MAT(4,3) = EL22*AK12 + AL22*EK12 - MAT(4,4) = EL22*AK22 + AL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 80 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 80 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - -C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) -C -C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - -C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) -C - IF ( KL .LT. LL ) THEN - IF ( LB .EQ. 2 ) - $ CALL DGEMV( 'N', KB, 2, ONE, X(KL,LL), LDX, - $ E(LL,LH), 1, ZERO, TM(1,2), 1 ) - CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) - CALL DSCAL( KB, E(LL,LL), TM, 1 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), - $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) - CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, - $ A(LL,LL), LDA, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, E(KL,KH+1), - $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) - END IF -C - GOTO 60 - END IF -C END WHILE 60 -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Outer Loop. Compute block column X(:,LL:LH). LB denotes the -C number of columns in this block column. -C - LL = N + 1 -C WHILE ( LL .GT. 1 ) DO - 100 IF ( LL .GT. 1 ) THEN - LH = LL - 1 - IF ( LH .EQ. 1 ) THEN - LB = 1 - ELSE - IF ( A(LL-1,LL-2) .NE. ZERO ) THEN - LB = 2 - ELSE - LB = 1 - END IF - END IF - LL = LL - LB -C -C Copy elements of solution already known by symmetry. -C -C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' -C - IF ( LH .LT. N ) THEN - DO 120 I = LL, LH - CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) - 120 CONTINUE - END IF -C -C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the -C number of rows in this block. -C - KL = LH + 1 -C WHILE ( KL .GT. 1 ) DO - 140 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KB = 1 - ELSE - IF ( A(KL-1,KL-2) .NE. ZERO ) THEN - KB = 2 - ELSE - KB = 1 - END IF - END IF - KL = KL - KB -C -C Update right hand sides (I). -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - -C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' -C -C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - -C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' -C - IF ( KH .LT. N ) THEN - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), - $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, MONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - IF ( LB .EQ. 2 ) CALL DAXPY( KB, -E(LH,LH), TM(1,2), - $ 1, X(KL,LH), 1 ) - CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), - $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - END IF -C -C Solve small Sylvester equations of order at most (2,2). -C - IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 1 -C - MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) -C - RHS(1) = X(KL,LL) -C - ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK12 + AL11*EK12 - MAT(2,1) = EL11*AK21 - MAT(2,2) = EL11*AK22 + AL11*EK22 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KH,LL) -C - ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN -C - DIMMAT = 2 -C - AK11 = A(KL,KL) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL12*AK11 + AL12*EK11 - MAT(2,1) = AL21*EK11 - MAT(2,2) = EL22*AK11 + AL22*EK11 -C - RHS(1) = X(KL,LL) - RHS(2) = X(KL,LH) -C - ELSE -C - DIMMAT = 4 -C - AK11 = A(KL,KL) - AK12 = A(KL,KH) - AK21 = A(KH,KL) - AK22 = A(KH,KH) -C - AL11 = A(LL,LL) - AL12 = A(LL,LH) - AL21 = A(LH,LL) - AL22 = A(LH,LH) -C - EK11 = E(KL,KL) - EK12 = E(KL,KH) - EK22 = E(KH,KH) -C - EL11 = E(LL,LL) - EL12 = E(LL,LH) - EL22 = E(LH,LH) -C - MAT(1,1) = EL11*AK11 + AL11*EK11 - MAT(1,2) = EL11*AK12 + AL11*EK12 - MAT(1,3) = EL12*AK11 + AL12*EK11 - MAT(1,4) = EL12*AK12 + AL12*EK12 -C - MAT(2,1) = EL11*AK21 - MAT(2,2) = EL11*AK22 + AL11*EK22 - MAT(2,3) = EL12*AK21 - MAT(2,4) = EL12*AK22 + AL12*EK22 -C - MAT(3,1) = AL21*EK11 - MAT(3,2) = AL21*EK12 - MAT(3,3) = EL22*AK11 + AL22*EK11 - MAT(3,4) = EL22*AK12 + AL22*EK12 -C - MAT(4,1) = ZERO - MAT(4,2) = AL21*EK22 - MAT(4,3) = EL22*AK21 - MAT(4,4) = EL22*AK22 + AL22*EK22 -C - RHS(1) = X(KL,LL) - IF ( KL .EQ. LL ) THEN - RHS(2) = X(KL,KH) - ELSE - RHS(2) = X(KH,LL) - END IF - RHS(3) = X(KL,LH) - RHS(4) = X(KH,LH) -C - END IF -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) -C -C Scaling. -C - IF ( SCALE1 .NE. ONE ) THEN - DO 160 I = 1, N - CALL DSCAL( N, SCALE1, X(1,I), 1 ) - 160 CONTINUE - SCALE = SCALE*SCALE1 - END IF -C - IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN - X(KL,LL) = RHS(1) - X(KL,LH) = RHS(2) - ELSE - X(KL,LL) = RHS(1) - X(KH,LL) = RHS(2) - X(KL,LH) = RHS(3) - X(KH,LH) = RHS(4) - END IF -C -C Update right hand sides (II). -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - -C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' -C -C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - -C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' -C - IF ( KL .LT. LL ) THEN - CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, - $ X(KL,LL), LDX, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, - $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) - CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), - $ LDE, ZERO, TM, 2 ) - IF ( KB .EQ. 2 ) THEN - CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) - CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) - END IF - CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, - $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) - END IF -C - GOTO 140 - END IF -C END WHILE 140 -C - GOTO 100 - END IF -C END WHILE 100 -C - END IF -C - RETURN -C *** Last line of SG03AY *** - END diff --git a/slycot/src/SG03BD.f b/slycot/src/SG03BD.f deleted file mode 100644 index 36579be1..00000000 --- a/slycot/src/SG03BD.f +++ /dev/null @@ -1,818 +0,0 @@ - SUBROUTINE SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, - $ LDQ, Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, - $ BETA, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor U of the matrix X, -C -C T -C X = op(U) * op(U), -C -C which is the solution of either the generalized -C c-stable continuous-time Lyapunov equation -C -C T T -C op(A) * X * op(E) + op(E) * X * op(A) -C -C 2 T -C = - SCALE * op(B) * op(B), (1) -C -C or the generalized d-stable discrete-time Lyapunov equation -C -C T T -C op(A) * X * op(A) - op(E) * X * op(E) -C -C 2 T -C = - SCALE * op(B) * op(B), (2) -C -C without first finding X and without the need to form the matrix -C op(B)**T * op(B). -C -C op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N -C matrices, op(B) is an M-by-N matrix. The resulting matrix U is an -C N-by-N upper triangular matrix with non-negative entries on its -C main diagonal. SCALE is an output scale factor set to avoid -C overflow in U. -C -C In the continuous-time case (1) the pencil A - lambda * E must be -C c-stable (that is, all eigenvalues must have negative real parts). -C In the discrete-time case (2) the pencil A - lambda * E must be -C d-stable (that is, the moduli of all eigenvalues must be smaller -C than one). -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies which type of the equation is considered: -C = 'C': Continuous-time equation (1); -C = 'D': Discrete-time equation (2). -C -C FACT CHARACTER*1 -C Specifies whether the generalized real Schur -C factorization of the pencil A - lambda * E is supplied -C on entry or not: -C = 'N': Factorization is not supplied; -C = 'F': Factorization is supplied. -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': op(A) = A, op(E) = E; -C = 'T': op(A) = A**T, op(E) = E**T. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of rows in the matrix op(B). M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C Hessenberg part of this array must contain the -C generalized Schur factor A_s of the matrix A (see -C definition (3) in section METHOD). A_s must be an upper -C quasitriangular matrix. The elements below the upper -C Hessenberg part of the array A are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the matrix A. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor A_s of the matrix A. (A_s is -C an upper quasitriangular matrix.) -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, if FACT = 'F', then the leading N-by-N upper -C triangular part of this array must contain the -C generalized Schur factor E_s of the matrix E (see -C definition (4) in section METHOD). The elements below the -C upper triangular part of the array E are not referenced. -C If FACT = 'N', then the leading N-by-N part of this -C array must contain the coefficient matrix E of the -C equation. -C On exit, the leading N-by-N part of this array contains -C the generalized Schur factor E_s of the matrix E. (E_s is -C an upper triangular matrix.) -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Q from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Q need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Q from the generalized Schur -C factorization. -C -C LDQ INTEGER -C The leading dimension of the array Q. LDQ >= MAX(1,N). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C On entry, if FACT = 'F', then the leading N-by-N part of -C this array must contain the orthogonal matrix Z from -C the generalized Schur factorization (see definitions (3) -C and (4) in section METHOD). -C If FACT = 'N', Z need not be set on entry. -C On exit, the leading N-by-N part of this array contains -C the orthogonal matrix Z from the generalized Schur -C factorization. -C -C LDZ INTEGER -C The leading dimension of the array Z. LDZ >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N1) -C On entry, if TRANS = 'T', the leading N-by-M part of this -C array must contain the matrix B and N1 >= MAX(M,N). -C If TRANS = 'N', the leading M-by-N part of this array -C must contain the matrix B and N1 >= N. -C On exit, the leading N-by-N part of this array contains -C the Cholesky factor U of the solution matrix X of the -C problem, X = op(U)**T * op(U). -C If M = 0 and N > 0, then U is set to zero. -C -C LDB INTEGER -C The leading dimension of the array B. -C If TRANS = 'T', LDB >= MAX(1,N). -C If TRANS = 'N', LDB >= MAX(1,M,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C If INFO = 0, 3, 5, 6, or 7, then -C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the -C eigenvalues of the matrix pencil A - lambda * E. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= MAX(1,4*N,6*N-6), if FACT = 'N'; -C LDWORK >= MAX(1,2*N,6*N-6), if FACT = 'F'. -C For good performance, LDWORK should be larger. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the pencil A - lambda * E is (nearly) singular; -C perturbed values were used to solve the equation -C (but the reduced (quasi)triangular matrices A and E -C are unchanged); -C = 2: FACT = 'F' and the matrix contained in the upper -C Hessenberg part of the array A is not in upper -C quasitriangular form; -C = 3: FACT = 'F' and there is a 2-by-2 block on the main -C diagonal of the pencil A_s - lambda * E_s whose -C eigenvalues are not conjugate complex; -C = 4: FACT = 'N' and the pencil A - lambda * E cannot be -C reduced to generalized Schur form: LAPACK routine -C DGEGS has failed to converge; -C = 5: DICO = 'C' and the pencil A - lambda * E is not -C c-stable; -C = 6: DICO = 'D' and the pencil A - lambda * E is not -C d-stable; -C = 7: the LAPACK routine DSYEVX utilized to factorize M3 -C failed to converge in the discrete-time case (see -C section METHOD for SLICOT Library routine SG03BU). -C This error is unlikely to occur. -C -C METHOD -C -C An extension [2] of Hammarling's method [1] to generalized -C Lyapunov equations is utilized to solve (1) or (2). -C -C First the pencil A - lambda * E is reduced to real generalized -C Schur form A_s - lambda * E_s by means of orthogonal -C transformations (QZ-algorithm): -C -C A_s = Q**T * A * Z (upper quasitriangular) (3) -C -C E_s = Q**T * E * Z (upper triangular). (4) -C -C If the pencil A - lambda * E has already been factorized prior to -C calling the routine however, then the factors A_s, E_s, Q and Z -C may be supplied and the initial factorization omitted. -C -C Depending on the parameters TRANS and M the N-by-N upper -C triangular matrix B_s is defined as follows. In any case Q_B is -C an M-by-M orthogonal matrix, which need not be accumulated. -C -C 1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix -C from the QR-factorization -C -C ( Q_B O ) ( B * Z ) -C ( ) * B_s = ( ), -C ( O I ) ( O ) -C -C where the O's are zero matrices of proper size and I is the -C identity matrix of order N-M. -C -C 2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix -C from the (rectangular) QR-factorization -C -C ( B_s ) -C Q_B * ( ) = B * Z, -C ( O ) -C -C where O is the (M-N)-by-N zero matrix. -C -C 3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix -C from the RQ-factorization -C -C ( Q_B O ) -C (B_s O ) * ( ) = ( Q**T * B O ). -C ( O I ) -C -C 4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix -C from the (rectangular) RQ-factorization -C -C ( B_s O ) * Q_B = Q**T * B, -C -C where O is the N-by-(M-N) zero matrix. -C -C Assuming SCALE = 1, the transformation of A, E and B described -C above leads to the reduced continuous-time equation -C -C T T -C op(A_s) op(U_s) op(U_s) op(E_s) -C -C T T -C + op(E_s) op(U_s) op(U_s) op(A_s) -C -C T -C = - op(B_s) op(B_s) (5) -C -C or to the reduced discrete-time equation -C -C T T -C op(A_s) op(U_s) op(U_s) op(A_s) -C -C T T -C - op(E_s) op(U_s) op(U_s) op(E_s) -C -C T -C = - op(B_s) op(B_s). (6) -C -C For brevity we restrict ourself to equation (5) and the case -C TRANS = 'N'. The other three cases can be treated in a similar -C fashion. -C -C We use the following partitioning for the matrices A_s, E_s, B_s -C and U_s -C -C ( A11 A12 ) ( E11 E12 ) -C A_s = ( ), E_s = ( ), -C ( 0 A22 ) ( 0 E22 ) -C -C ( B11 B12 ) ( U11 U12 ) -C B_s = ( ), U_s = ( ). (7) -C ( 0 B22 ) ( 0 U22 ) -C -C The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or -C 2-by-2. -C -C We compute U11 and U12**T in three steps. -C -C Step I: -C -C From (5) and (7) we get the 1-by-1 or 2-by-2 equation -C -C T T T T -C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 -C -C T -C = - B11 * B11. -C -C For brevity, details are omitted here. See [2]. The technique -C for computing U11 is similar to those applied to standard -C Lyapunov equations in Hammarling's algorithm ([1], section 6). -C -C Furthermore, the auxiliary matrices M1 and M2 defined as -C follows -C -C -1 -1 -C M1 = U11 * A11 * E11 * U11 -C -C -1 -1 -C M2 = B11 * E11 * U11 -C -C are computed in a numerically reliable way. -C -C Step II: -C -C The generalized Sylvester equation -C -C T T T T -C A22 * U12 + E22 * U12 * M1 = -C -C T T T T T -C - B12 * M2 - A12 * U11 - E12 * U11 * M1 -C -C is solved for U12**T. -C -C Step III: -C -C It can be shown that -C -C T T T T -C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = -C -C T T -C - B22 * B22 - y * y (8) -C -C holds, where y is defined as -C -C T T T T T T -C y = B12 - ( E12 * U11 + E22 * U12 ) * M2 . -C -C If B22_tilde is the square triangular matrix arising from the -C (rectangular) QR-factorization -C -C ( B22_tilde ) ( B22 ) -C Q_B_tilde * ( ) = ( ), -C ( O ) ( y**T ) -C -C where Q_B_tilde is an orthogonal matrix of order N, then -C -C T T T -C - B22 * B22 - y * y = - B22_tilde * B22_tilde. -C -C Replacing the right hand side in (8) by the term -C - B22_tilde**T * B22_tilde leads to a reduced generalized -C Lyapunov equation of lower dimension compared to (5). -C -C The recursive application of the steps I to III yields the -C solution U_s of the equation (5). -C -C It remains to compute the solution matrix U of the original -C problem (1) or (2) from the matrix U_s. To this end we transform -C the solution back (with respect to the transformation that led -C from (1) to (5) (from (2) to (6)) and apply the QR-factorization -C (RQ-factorization). The upper triangular solution matrix U is -C obtained by -C -C Q_U * U = U_s * Q**T (if TRANS = 'N') -C -C or -C -C U * Q_U = Z * U_s (if TRANS = 'T') -C -C where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal -C matrix Q_U need not be accumulated. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The number of flops required by the routine is given by the -C following table. Note that we count a single floating point -C arithmetic operation as one flop. -C -C | FACT = 'F' FACT = 'N' -C ---------+-------------------------------------------------- -C M <= N | (13*N**3+6*M*N**2 (211*N**3+6*M*N**2 -C | +6*M**2*N-2*M**3)/3 +6*M**2*N-2*M**3)/3 -C | -C M > N | (11*N**3+12*M*N**2)/3 (209*N**3+12*M*N**2)/3 -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if DICO = 'D' and the pencil A - lambda * E has a pair of almost -C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost -C degenerate pair of eigenvalues, then the Lyapunov equation will be -C ill-conditioned. Perturbed values were used to solve the equation. -C A condition estimate can be obtained from the routine SG03AD. -C When setting the error indicator INFO, the routine does not test -C for near instability in the equation but only for exact -C instability. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C May 1999 (V. Sima). -C March 2002 (A. Varga). -C Feb. 2004 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, TWO, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, LDQ, LDWORK, LDZ, M, N - CHARACTER DICO, FACT, TRANS -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) - LOGICAL BWORK -C .. Local Scalars .. - DOUBLE PRECISION S1, S2, SAFMIN, WI, WR1, WR2 - INTEGER I, INFO1, MINMN, MINWRK, OPTWRK, SDIM - LOGICAL ISDISC, ISFACT, ISTRAN -C .. Local Arrays .. - DOUBLE PRECISION E1(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - LOGICAL LSAME - EXTERNAL DLAMCH, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGGES, DGEMM, DGEMV, DGEQRF, DGERQF, - $ DLACPY, DLAG2, DLASET, DSCAL, DTRMM, SG03BU, - $ SG03BV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN, SIGN -C .. Executable Statements .. -C -C Decode input parameters. -C - ISDISC = LSAME( DICO, 'D' ) - ISFACT = LSAME( FACT, 'F' ) - ISTRAN = LSAME( TRANS, 'T' ) -C -C Compute minimal workspace. -C - IF (ISFACT ) THEN - MINWRK = MAX( 1, 2*N, 6*N-6 ) - ELSE - MINWRK = MAX( 1, 4*N, 6*N-6 ) - END IF -C -C Check the scalar input parameters. -C - IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN - INFO = -1 - ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN - INFO = -2 - ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN - INFO = -3 - ELSEIF ( N .LT. 0 ) THEN - INFO = -4 - ELSEIF ( M .LT. 0 ) THEN - INFO = -5 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -7 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -9 - ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN - INFO = -11 - ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN - INFO = -13 - ELSEIF ( ( ISTRAN .AND. ( LDB .LT. MAX( 1, N ) ) ) .OR. - $ ( .NOT.ISTRAN .AND. ( LDB .LT. MAX( 1, M, N ) ) ) ) THEN - INFO = -15 - ELSEIF ( LDWORK .LT. MINWRK ) THEN - INFO = -21 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BD', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - MINMN = MIN( M, N ) - IF ( MINMN .EQ. 0 ) THEN - IF ( N.GT.0 ) - $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) - DWORK(1) = ONE - RETURN - ENDIF -C - IF ( ISFACT ) THEN -C -C Make sure the upper Hessenberg part of A is quasitriangular. -C - DO 20 I = 1, N-2 - IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN - INFO = 2 - RETURN - END IF - 20 CONTINUE - END IF -C - IF ( .NOT.ISFACT ) THEN -C -C Reduce the pencil A - lambda * E to generalized Schur form. -C -C A := Q**T * A * Z (upper quasitriangular) -C E := Q**T * E * Z (upper triangular) -C -C ( Workspace: >= MAX(1,4*N) ) -C -C CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, -C $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, -C $ INFO1 ) - CALL DGGES( 'Vectors', 'Vectors', 'N', 0, N, A, LDA, - $ E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, - $ DWORK, LDWORK, 0, INFO) - IF ( INFO1 .NE. 0 ) THEN - INFO = 4 - RETURN - END IF - OPTWRK = INT( DWORK(1) ) - ELSE - OPTWRK = MINWRK - END IF -C - IF ( ISFACT ) THEN -C -C If the matrix pencil A - lambda * E has been in generalized -C Schur form on entry, compute its eigenvalues. -C - SAFMIN = DLAMCH( 'Safe minimum' ) - E1(2,1) = ZERO - I = 1 -C WHILE ( I .LE. N ) DO - 30 IF ( I .LE. N ) THEN - IF ( ( I.EQ.N ) .OR. ( A(MIN( I+1, N ),I).EQ.ZERO ) ) THEN - ALPHAR(I) = A(I,I) - ALPHAI(I) = ZERO - BETA(I) = E(I,I) - I = I+1 - ELSE - E1(1,1) = E(I,I) - E1(1,2) = E(I,I+1) - E1(2,2) = E(I+1,I+1) - CALL DLAG2( A(I,I), LDA, E1, 2, SAFMIN, S1, S2, WR1, WR2, - $ WI ) - IF ( WI .EQ. ZERO ) INFO = 3 - ALPHAR(I) = WR1 - ALPHAI(I) = WI - BETA(I) = S1 - ALPHAR(I+1) = WR2 - ALPHAI(I+1) = -WI - BETA(I+1) = S2 - I = I+2 - END IF - GOTO 30 - END IF -C END WHILE 30 - IF ( INFO.NE.0 ) RETURN - END IF -C -C Check on the stability of the matrix pencil A - lambda * E. -C - DO 40 I = 1, N - IF ( ISDISC ) THEN - IF ( DLAPY2( ALPHAR(I), ALPHAI(I) ) .GE. ABS( BETA(I) ) ) - $ THEN - INFO = 6 - RETURN - END IF - ELSE - IF ( ( ALPHAR(I).EQ.ZERO ) .OR. ( BETA(I).EQ.ZERO ) .OR. - $ ( SIGN( ONE,ALPHAR(I) )*SIGN( ONE, BETA(I) ) .GE. ZERO) ) - $ THEN - INFO = 5 - RETURN - END IF - END IF - 40 CONTINUE -C -C Transformation of the right hand side. -C -C B := B * Z or B := Q**T * B -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: max(1,N) ) -C - IF ( .NOT.ISTRAN ) THEN - IF ( LDWORK .GE. N*M ) THEN - CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, B, - $ LDB, Z, LDZ, ZERO, DWORK, M ) - CALL DLACPY( 'All', M, N, DWORK, M, B, LDB ) - ELSE - DO 60 I = 1, M - CALL DCOPY( N, B(I,1), LDB, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, - $ ZERO, B(I,1), LDB ) - 60 CONTINUE - END IF - IF ( M .LT. N ) - $ CALL DLASET( 'All', N-M, N, ZERO, ZERO, B(M+1,1), LDB ) - ELSE - IF ( LDWORK .GE. N*M ) THEN - CALL DLACPY( 'All', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, Q, - $ LDQ, DWORK, N, ZERO, B, LDB ) - ELSE - DO 80 I = 1, M - CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, - $ ZERO, B(1,I), 1 ) - 80 CONTINUE - END IF - IF ( M .LT. N ) - $ CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,M+1), LDB ) - END IF - OPTWRK = MAX( OPTWRK, N*M ) -C -C Overwrite B with the triangular matrix of its QR-factorization -C or its RQ-factorization. -C (The entries on the main diagonal are non-negative.) -C -C ( Workspace: >= max(1,2*N) ) -C - IF ( .NOT.ISTRAN ) THEN - IF ( M .GE. 2 ) THEN - CALL DGEQRF( M, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, - $ INFO1 ) - CALL DLASET( 'Lower', MAX( M, N )-1, MIN( M, N ), ZERO, - $ ZERO, B(2,1), LDB ) - END IF - DO 100 I = 1, MINMN - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) - 100 CONTINUE - ELSE - IF ( M .GE. 2 ) THEN - CALL DGERQF( N, M, B, LDB, DWORK, DWORK(N+1), LDWORK-N, - $ INFO1 ) - IF ( N .GE. M ) THEN - CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, B(N-M+2,1), - $ LDB ) - IF ( N .GT. M ) THEN - DO 120 I = M, 1, -1 - CALL DCOPY( N, B(1,I), 1, B(1,I+N-M), 1 ) - 120 CONTINUE - CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,1), LDB ) - END IF - ELSE - IF ( N .GT. 1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, - $ B(2,M-N+1), LDB ) - DO 140 I = 1, N - CALL DCOPY( N, B(1,M-N+I), 1, B(1,I), 1 ) - 140 CONTINUE - CALL DLASET( 'All', N, M-N, ZERO, ZERO, B(1,N+1), LDB ) - END IF - ELSE - IF ( N .NE. 1 ) THEN - CALL DCOPY( N, B(1,1), 1, B(1,N), 1 ) - CALL DLASET( 'All', N, 1, ZERO, ZERO, B(1,1), LDB ) - END IF - END IF - DO 160 I = N - MINMN + 1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 160 CONTINUE - END IF - OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) -C -C Solve the reduced generalized Lyapunov equation. -C -C ( Workspace: 6*N-6 ) -C - IF ( ISDISC ) THEN - CALL SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - IF ( INFO1 .EQ. 1 ) INFO = 1 - IF ( INFO1 .EQ. 2 ) INFO = 3 - IF ( INFO1 .EQ. 3 ) INFO = 6 - IF ( INFO1 .EQ. 4 ) INFO = 7 - IF ( INFO .NE. 1 ) - $ RETURN - END IF - ELSE - CALL SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - IF ( INFO1 .EQ. 1 ) INFO = 1 - IF ( INFO1 .GE. 2 ) INFO = 3 - IF ( INFO1 .EQ. 3 ) INFO = 5 - IF ( INFO .NE. 1 ) - $ RETURN - END IF - END IF -C -C Transform the solution matrix back. -C -C U := U * Q**T or U := Z * U -C -C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. -C -C ( Workspace: max(1,N) ) -C - IF ( .NOT.ISTRAN ) THEN - IF ( LDWORK .GE. N*N ) THEN - CALL DLACPY( 'All', N, N, Q, LDQ, DWORK, N ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, N, - $ ONE, B, LDB, DWORK, N) - DO 170 I = 1, N - CALL DCOPY( N, DWORK(N*(I-1)+1), 1, B(I,1), LDB ) - 170 CONTINUE - ELSE - DO 180 I = 1, N - CALL DCOPY( N-I+1, B(I,I), LDB, DWORK, 1 ) - CALL DGEMV( 'NoTranspose', N, N-I+1, ONE, Q(1,I), LDQ, - $ DWORK, 1, ZERO, B(I,1), LDB ) - 180 CONTINUE - END IF - ELSE - IF ( LDWORK .GE. N*N ) THEN - CALL DLACPY( 'All', N, N, Z, LDZ, DWORK, N ) - CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, - $ N, ONE, B, LDB, DWORK, N ) - CALL DLACPY( 'All', N, N, DWORK, N, B, LDB ) - ELSE - DO 200 I = 1, N - CALL DCOPY( I, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'NoTranspose', N, I, ONE, Z, LDZ, DWORK, 1, - $ ZERO, B(1,I), 1 ) - 200 CONTINUE - END IF - END IF - OPTWRK = MAX( OPTWRK, N*N ) -C -C Overwrite U with the triangular matrix of its QR-factorization -C or its RQ-factorization. -C (The entries on the main diagonal are non-negative.) -C -C ( Workspace: >= max(1,2*N) ) -C - IF ( .NOT.ISTRAN ) THEN - CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) - IF ( N .GT. 1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) - DO 220 I = 1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) - 220 CONTINUE - ELSE - CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) - IF ( N .GT. 1 ) - $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) - DO 240 I = 1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 240 CONTINUE - END IF - OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) -C - DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) - RETURN -C *** Last line of SG03BD *** - END diff --git a/slycot/src/SG03BU.f b/slycot/src/SG03BU.f deleted file mode 100644 index 0e1084f9..00000000 --- a/slycot/src/SG03BU.f +++ /dev/null @@ -1,696 +0,0 @@ - SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor U of the matrix X, X = U**T * U or -C X = U * U**T, which is the solution of the generalized d-stable -C discrete-time Lyapunov equation -C -C T T 2 T -C A * X * A - E * X * E = - SCALE * B * B, (1) -C -C or the transposed equation -C -C T T 2 T -C A * X * A - E * X * E = - SCALE * B * B , (2) -C -C respectively, where A, E, B, and U are real N-by-N matrices. The -C Cholesky factor U of the solution is computed without first -C finding X. The pencil A - lambda * E must be in generalized Schur -C form ( A upper quasitriangular, E upper triangular ). Moreover, it -C must be d-stable, i.e. the moduli of its eigenvalues must be less -C than one. B must be an upper triangular matrix with non-negative -C entries on its main diagonal. -C -C The resulting matrix U is upper triangular. The entries on its -C main diagonal are non-negative. SCALE is an output scale factor -C set to avoid overflow in U. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether equation (1) or equation (2) is to be -C solved: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the matrix B. -C On exit, the leading N-by-N upper triangular part of this -C array contains the solution matrix U. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (6*N-6) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the generalized Sylvester equation to be solved in -C step II (see METHOD) is (nearly) singular to working -C precision; perturbed values were used to solve the -C equation (but the matrices A and E are unchanged); -C = 2: the generalized Schur form of the pencil -C A - lambda * E contains a 2-by-2 main diagonal block -C whose eigenvalues are not a pair of conjugate -C complex numbers; -C = 3: the pencil A - lambda * E is not d-stable, i.e. -C there are eigenvalues outside the open unit circle; -C = 4: the LAPACK routine DSYEVX utilized to factorize M3 -C failed to converge. This error is unlikely to occur. -C -C METHOD -C -C The method [2] used by the routine is an extension of Hammarling's -C algorithm [1] to generalized Lyapunov equations. -C -C We present the method for solving equation (1). Equation (2) can -C be treated in a similar fashion. For simplicity, assume SCALE = 1. -C -C The matrix A is an upper quasitriangular matrix, i.e. it is a -C block triangular matrix with square blocks on the main diagonal -C and the block order at most 2. We use the following partitioning -C for the matrices A, E, B and the solution matrix U -C -C ( A11 A12 ) ( E11 E12 ) -C A = ( ), E = ( ), -C ( 0 A22 ) ( 0 E22 ) -C -C ( B11 B12 ) ( U11 U12 ) -C B = ( ), U = ( ). (3) -C ( 0 B22 ) ( 0 U22 ) -C -C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or -C 2-by-2. -C -C We compute U11 and U12**T in three steps. -C -C Step I: -C -C From (1) and (3) we get the 1-by-1 or 2-by-2 equation -C -C T T T T -C A11 * U11 * U11 * A11 - E11 * U11 * U11 * E11 -C -C T -C = - B11 * B11. -C -C For brevity, details are omitted here. The technique for -C computing U11 is similar to those applied to standard Lyapunov -C equations in Hammarling's algorithm ([1], section 6). -C -C Furthermore, the auxiliary matrices M1 and M2 defined as -C follows -C -C -1 -1 -C M1 = U11 * A11 * E11 * U11 -C -C -1 -1 -C M2 = B11 * E11 * U11 -C -C are computed in a numerically reliable way. -C -C Step II: -C -C We solve for U12**T the generalized Sylvester equation -C -C T T T T -C A22 * U12 * M1 - E22 * U12 -C -C T T T T T -C = - B12 * M2 + E12 * U11 - A12 * U11 * M1. -C -C Step III: -C -C One can show that -C -C T T T T -C A22 * U22 * U22 * A22 - E22 * U22 * U22 * E22 = -C -C T T -C - B22 * B22 - y * y (4) -C -C holds, where y is defined as follows -C -C T T T T -C w = A12 * U11 + A22 * U12 -C -C T -C y = ( B12 w ) * M3EV, -C -C where M3EV is a matrix which fulfils -C -C ( I-M2*M2**T -M2*M1**T ) T -C M3 = ( ) = M3EV * M3EV . -C ( -M1*M2**T I-M1*M1**T ) -C -C M3 is positive semidefinite and its rank is equal to the size -C of U11. Therefore, a matrix M3EV can be found by solving the -C symmetric eigenvalue problem for M3 such that y consists of -C either 1 or 2 rows. -C -C If B22_tilde is the square triangular matrix arising from the -C QR-factorization -C -C ( B22_tilde ) ( B22 ) -C Q * ( ) = ( ), -C ( 0 ) ( y**T ) -C -C then -C -C T T T -C - B22 * B22 - y * y = - B22_tilde * B22_tilde. -C -C Replacing the right hand side in (4) by the term -C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov -C equation of lower dimension compared to (1). -C -C The solution U of the equation (1) can be obtained by recursive -C application of the steps I to III. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The routine requires 2*N**3 flops. Note that we count a single -C floating point arithmetic operation as one flop. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if the pencil A - lambda * E has a pair of almost reciprocal -C eigenvalues, then the Lyapunov equation will be ill-conditioned. -C Perturbed values were used to solve the equation. -C A condition estimate can be obtained from the routine SG03AD. -C When setting the error indicator INFO, the routine does not test -C for near instability in the equation but only for exact -C instability. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION HALF, MONE, ONE, TWO, ZERO - PARAMETER ( HALF = 0.5D+0, MONE = -1.0D0, ONE = 1.0D+0, - $ TWO = 2.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) -C .. Local Scalars .. - DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, UFLT, - $ X, Z - INTEGER I, INFO1, J, KB, KH, KL, LDWS, M, UIIPT, WPT, - $ YPT - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION M1(2,2), M2(2,2), M3(4,4), M3C(4,4), M3EW(4), - $ RW(32), TM(2,2), UI(2,2) - INTEGER IW(24) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLACPY, DLASET, - $ DROT, DROTG, DSCAL, DSYEVX, DSYRK, SG03BW, - $ SG03BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C -C Decode input parameter. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BU', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - UFLT = DLAMCH( 'S' ) - SMLNUM = UFLT/EPS - BIGNUM = ONE/SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Set work space pointers and leading dimension of matrices in -C work space. -C - UIIPT = 1 - WPT = 2*N-1 - YPT = 4*N-3 - LDWS = N-1 -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the -C number of rows in this block row. -C - KH = 0 -C WHILE ( KH .LT. N ) DO - 20 IF ( KH .LT. N ) THEN - KL = KH + 1 - IF ( KL .EQ. N ) THEN - KH = N - KB = 1 - ELSE - IF ( A(KL+1,KL) .EQ. ZERO ) THEN - KH = KL - KB = 1 - ELSE - KH = KL + 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 40 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 40 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'D', 'N', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 60 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 60 CONTINUE - END IF - END IF -C - IF ( KH .LT. N ) THEN -C -C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized -C Sylvester equation. (For the moment the result -C U(KL:KH,KH+1:N) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), - $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), - $ LDE, UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, A(KL,KH+1), - $ LDA, TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) - CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, M1, 2, - $ E(KH+1,KH+1), LDE, TM, 2, DWORK(UIIPT), - $ LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 80 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 80 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary matrices M3 and Y. The factorization -C M3 = M3C * M3C**T is found by solving the symmetric -C eigenvalue problem. -C - CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) - CALL DSYRK( 'U', 'N', KB, KB, MONE, M2, 2, ONE, M3, 4 ) - CALL DGEMM( 'N', 'T', KB, KB, KB, MONE, M2, 2, M1, 2, - $ ZERO, M3(1,KB+1), 4 ) - CALL DSYRK( 'U', 'N', KB, KB, MONE, M1, 2, ONE, - $ M3(KB+1,KB+1), 4 ) - CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, - $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), - $ IW, INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGEMM( 'T', 'N', N-KH, KB, KB, ONE, B(KL,KH+1), LDB, - $ M3C, 4, ZERO, DWORK(YPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, A(KL,KH+1), LDA, - $ UI, 2, ZERO, DWORK(WPT), LDWS ) - DO 100 I = 1, N-KH - CALL DGEMV( 'T', MIN( I+1, N-KH ), KB, ONE, - $ DWORK(UIIPT), LDWS, A(KH+1,KH+I), 1, ONE, - $ DWORK(WPT+I-1), LDWS ) - 100 CONTINUE - CALL DGEMM( 'N', 'N', N-KH, KB, KB, ONE, DWORK(WPT), - $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix -C from the QR-factorization of the (N-KH+KB)-by-(N-KH) -C matrix -C -C ( B(KH+1:N,KH+1:N) ) -C ( ) -C ( Y**T ) . -C - DO 140 J = 1, KB - DO 120 I = 1, N-KH - X = B(KH+I,KH+I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, - $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) - 120 CONTINUE - 140 CONTINUE -C -C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. -C - DO 160 I = KH+1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) - 160 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - DO 180 J = KL, KH - CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, - $ B(J,KH+1), LDB ) - 180 CONTINUE - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the -C number of columns in this block column. -C - KL = N + 1 -C WHILE ( KL .GT. 1 ) DO - 200 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KL = 1 - KB = 1 - ELSE - IF ( A(KH,KH-1) .EQ. ZERO ) THEN - KL = KH - KB = 1 - ELSE - KL = KH - 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 220 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 220 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'D', 'T', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 240 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 240 CONTINUE - END IF - END IF -C - IF ( KL .GT. 1 ) THEN -C -C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized -C Sylvester equation. (For the moment the result -C U(1:KL-1,KL:KH) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, - $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, - $ UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, - $ TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) - CALL SG03BW( 'T', KL-1, KB, A, LDA, M1, 2, E, LDE, TM, 2, - $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 260 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 260 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary matrices M3 and Y. The factorization -C M3 = M3C * M3C**T is found by solving the symmetric -C eigenvalue problem. -C - CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) - CALL DSYRK( 'U', 'T', KB, KB, MONE, M2, 2, ONE, M3, 4 ) - CALL DGEMM( 'T', 'N', KB, KB, KB, MONE, M2, 2, M1, 2, - $ ZERO, M3(1,KB+1), 4 ) - CALL DSYRK( 'U', 'T', KB, KB, MONE, M1, 2, ONE, - $ M3(KB+1,KB+1), 4 ) - CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, - $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), - $ IW, INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = 4 - RETURN - END IF - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, B(1,KL), LDB, - $ M3C, 4, ZERO, DWORK(YPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, A(1,KL), LDA, - $ UI, 2, ZERO, DWORK(WPT), LDWS ) - DO 280 I = 1, KL-1 - CALL DGEMV( 'T', MIN( KL-I+1, KL-1 ), KB, ONE, - $ DWORK(MAX( UIIPT, UIIPT+I-2 )), LDWS, - $ A(I,MAX( I-1, 1 )), LDA, ONE, - $ DWORK(WPT+I-1), LDWS ) - 280 CONTINUE - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, DWORK(WPT), - $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix -C from the RQ-factorization of the (KL-1)-by-KH matrix -C -C ( ) -C ( B(1:KL-1,1:KL-1) Y ) -C ( ). -C - DO 320 J = 1, KB - DO 300 I = KL-1, 1, -1 - X = B(I,I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, - $ C, S ) - 300 CONTINUE - 320 CONTINUE -C -C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. -C - DO 340 I = 1, KL-1 - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 340 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), - $ LDB ) -C - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 200 - END IF -C END WHILE 200 -C - END IF -C - RETURN -C *** Last line of SG03BU *** - END diff --git a/slycot/src/SG03BV.f b/slycot/src/SG03BV.f deleted file mode 100644 index edce6f0d..00000000 --- a/slycot/src/SG03BV.f +++ /dev/null @@ -1,645 +0,0 @@ - SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the Cholesky factor U of the matrix X, X = U**T * U or -C X = U * U**T, which is the solution of the generalized c-stable -C continuous-time Lyapunov equation -C -C T T 2 T -C A * X * E + E * X * A = - SCALE * B * B, (1) -C -C or the transposed equation -C -C T T 2 T -C A * X * E + E * X * A = - SCALE * B * B , (2) -C -C respectively, where A, E, B, and U are real N-by-N matrices. The -C Cholesky factor U of the solution is computed without first -C finding X. The pencil A - lambda * E must be in generalized Schur -C form ( A upper quasitriangular, E upper triangular ). Moreover, it -C must be c-stable, i.e. its eigenvalues must have negative real -C parts. B must be an upper triangular matrix with non-negative -C entries on its main diagonal. -C -C The resulting matrix U is upper triangular. The entries on its -C main diagonal are non-negative. SCALE is an output scale factor -C set to avoid overflow in U. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether equation (1) or equation (2) is to be -C solved: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N upper Hessenberg part of this array -C must contain the quasitriangular matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,N) -C The leading N-by-N upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) -C On entry, the leading N-by-N upper triangular part of this -C array must contain the matrix B. -C On exit, the leading N-by-N upper triangular part of this -C array contains the solution matrix U. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= MAX(1,N). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (6*N-6) -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the generalized Sylvester equation to be solved in -C step II (see METHOD) is (nearly) singular to working -C precision; perturbed values were used to solve the -C equation (but the matrices A and E are unchanged); -C = 2: the generalized Schur form of the pencil -C A - lambda * E contains a 2-by-2 main diagonal block -C whose eigenvalues are not a pair of conjugate -C complex numbers; -C = 3: the pencil A - lambda * E is not stable, i.e. there -C is an eigenvalue without a negative real part. -C -C METHOD -C -C The method [2] used by the routine is an extension of Hammarling's -C algorithm [1] to generalized Lyapunov equations. -C -C We present the method for solving equation (1). Equation (2) can -C be treated in a similar fashion. For simplicity, assume SCALE = 1. -C -C The matrix A is an upper quasitriangular matrix, i.e. it is a -C block triangular matrix with square blocks on the main diagonal -C and the block order at most 2. We use the following partitioning -C for the matrices A, E, B and the solution matrix U -C -C ( A11 A12 ) ( E11 E12 ) -C A = ( ), E = ( ), -C ( 0 A22 ) ( 0 E22 ) -C -C ( B11 B12 ) ( U11 U12 ) -C B = ( ), U = ( ). (3) -C ( 0 B22 ) ( 0 U22 ) -C -C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or -C 2-by-2. -C -C We compute U11 and U12**T in three steps. -C -C Step I: -C -C From (1) and (3) we get the 1-by-1 or 2-by-2 equation -C -C T T T T -C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 -C -C T -C = - B11 * B11. -C -C For brevity, details are omitted here. The technique for -C computing U11 is similar to those applied to standard Lyapunov -C equations in Hammarling's algorithm ([1], section 6). -C -C Furthermore, the auxiliary matrices M1 and M2 defined as -C follows -C -C -1 -1 -C M1 = U11 * A11 * E11 * U11 -C -C -1 -1 -C M2 = B11 * E11 * U11 -C -C are computed in a numerically reliable way. -C -C Step II: -C -C We solve for U12**T the generalized Sylvester equation -C -C T T T T -C A22 * U12 + E22 * U12 * M1 -C -C T T T T T -C = - B12 * M2 - A12 * U11 - E12 * U11 * M1. -C -C Step III: -C -C One can show that -C -C T T T T -C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = -C -C T T -C - B22 * B22 - y * y (4) -C -C holds, where y is defined as follows -C -C T T T T -C w = E12 * U11 + E22 * U12 -C T T -C y = B12 - w * M2 . -C -C If B22_tilde is the square triangular matrix arising from the -C QR-factorization -C -C ( B22_tilde ) ( B22 ) -C Q * ( ) = ( ), -C ( 0 ) ( y**T ) -C -C then -C -C T T T -C - B22 * B22 - y * y = - B22_tilde * B22_tilde. -C -C Replacing the right hand side in (4) by the term -C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov -C equation of lower dimension compared to (1). -C -C The solution U of the equation (1) can be obtained by recursive -C application of the steps I to III. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The routine requires 2*N**3 flops. Note that we count a single -C floating point arithmetic operation as one flop. -C -C FURTHER COMMENTS -C -C The Lyapunov equation may be very ill-conditioned. In particular, -C if the pencil A - lambda * E has a pair of almost degenerate -C eigenvalues, then the Lyapunov equation will be ill-conditioned. -C Perturbed values were used to solve the equation. -C A condition estimate can be obtained from the routine SG03AD. -C When setting the error indicator INFO, the routine does not test -C for near instability in the equation but only for exact -C instability. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, TWO, ZERO - PARAMETER ( MONE = -1.0D0, ONE = 1.0D+0, TWO = 2.0D+0, - $ ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) -C .. Local Scalars .. - DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, X, Z - INTEGER I, INFO1, J, KB, KH, KL, LDWS, UIIPT, WPT, YPT - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION M1(2,2), M2(2,2), TM(2,2), UI(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH - LOGICAL LSAME - EXTERNAL DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASET, DROT, - $ DROTG, DSCAL, DTRMM, SG03BW, SG03BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -C .. Executable Statements .. -C -C Decode input parameter. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( N .LT. 0 ) THEN - INFO = -2 - ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN - INFO = -4 - ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN - INFO = -8 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BV', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( N .EQ. 0 ) - $ RETURN -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' )/EPS - BIGNUM = ONE/SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C -C Set work space pointers and leading dimension of matrices in -C work space. -C - UIIPT = 1 - WPT = 2*N-1 - YPT = 4*N-3 - LDWS = N-1 -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the -C number of rows in this block row. -C - KH = 0 -C WHILE ( KH .LT. N ) DO - 20 IF ( KH .LT. N ) THEN - KL = KH + 1 - IF ( KL .EQ. N ) THEN - KH = N - KB = 1 - ELSE - IF ( A(KL+1,KL) .EQ. ZERO ) THEN - KH = KL - KB = 1 - ELSE - KH = KL + 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = -TWO*A(KL,KL)*E(KL,KL) - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 40 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 40 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'C', 'N', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 60 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 60 CONTINUE - END IF - END IF -C - IF ( KH .LT. N ) THEN -C -C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized -C Sylvester equation. (For the moment the result -C U(KL:KH,KH+1:N) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), - $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, MONE, A(KL,KH+1), - $ LDA, UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, E(KL,KH+1), - $ LDE, TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) - CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, TM, 2, - $ E(KH+1,KH+1), LDE, M1, 2, DWORK(UIIPT), - $ LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 80 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 80 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary vectors (or matrices) W and Y. -C - CALL DLACPY( 'A', N-KH, KB, DWORK(UIIPT), LDWS, - $ DWORK(WPT), LDWS ) - CALL DTRMM( 'L', 'U', 'T', 'N', N-KH, KB, ONE, - $ E(KH+1,KH+1), LDE, DWORK(WPT), LDWS ) - CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), - $ LDE, UI, 2, ONE, DWORK(WPT), LDWS ) - DO 100 I = KL, KH - CALL DCOPY( N-KH, B(I,KH+1), LDB, - $ DWORK(YPT+LDWS*(I-KL)), 1 ) - 100 CONTINUE - CALL DGEMM( 'N', 'T', N-KH, KB, KB, MONE, DWORK(WPT), - $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix -C from the QR-factorization of the (N-KH+KB)-by-(N-KH) -C matrix -C -C ( B(KH+1:N,KH+1:N) ) -C ( ) -C ( Y**T ) . -C - DO 140 J = 1, KB - DO 120 I = 1, N-KH - X = B(KH+I,KH+I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, - $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) - 120 CONTINUE - 140 CONTINUE -C -C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. -C - DO 160 I = KH+1, N - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) - 160 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - DO 180 J = KL, KH - CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, - $ B(J,KH+1), LDB ) - 180 CONTINUE - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the -C number of columns in this block column. -C - KL = N + 1 -C WHILE ( KL .GT. 1 ) DO - 200 IF ( KL .GT. 1 ) THEN - KH = KL - 1 - IF ( KH .EQ. 1 ) THEN - KL = 1 - KB = 1 - ELSE - IF ( A(KH,KH-1) .EQ. ZERO ) THEN - KL = KH - KB = 1 - ELSE - KL = KH - 1 - KB = 2 - END IF - END IF -C -C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary -C matrices M1 and M2. (For the moment the result -C U(KL:KH,KL:KH) is stored in UI). -C - IF ( KB .EQ. 1 ) THEN - DELTA1 = -TWO*A(KL,KL)*E(KL,KL) - IF ( DELTA1 .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - DELTA1 = SQRT( DELTA1 ) - Z = TWO*ABS( B(KL,KL) )*SMLNUM - IF ( Z .GT. DELTA1 ) THEN - SCALE1 = DELTA1/Z - SCALE = SCALE1*SCALE - DO 220 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 220 CONTINUE - END IF - UI(1,1) = B(KL,KL)/DELTA1 - M1(1,1) = A(KL,KL)/E(KL,KL) - M2(1,1) = DELTA1/E(KL,KL) - ELSE -C -C If a pair of complex conjugate eigenvalues occurs, apply -C (complex) Hammarling algorithm for the 2-by-2 problem. -C - CALL SG03BX( 'C', 'T', A(KL,KL), LDA, E(KL,KL), LDE, - $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, - $ INFO1 ) - IF ( INFO1 .NE. 0 ) THEN - INFO = INFO1 - RETURN - END IF - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 240 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 240 CONTINUE - END IF - END IF -C - IF ( KL .GT. 1 ) THEN -C -C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized -C Sylvester equation. (For the moment the result -C U(1:KL-1,KL:KH) is stored in the workspace.) -C -C Form right hand side of the Sylvester equation. -C - CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, - $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, - $ UI, 2, ONE, DWORK(UIIPT), LDWS ) - CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, - $ ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, E(1,KL), LDE, - $ TM, 2, ONE, DWORK(UIIPT), LDWS ) -C -C Solve generalized Sylvester equation. -C - CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) - CALL SG03BW( 'T', KL-1, KB, A, LDA, TM, 2, E, LDE, M1, 2, - $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 260 I = 1, N - CALL DSCAL( I, SCALE1, B(1,I), 1 ) - 260 CONTINUE - CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) - END IF -C -C STEP III: Form the right hand side matrix -C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov -C equation to be solved during the next pass of -C the main loop. -C -C Compute auxiliary vectors (or matrices) W and Y. -C - CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, - $ DWORK(WPT), LDWS ) - CALL DTRMM( 'L', 'U', 'N', 'N', KL-1, KB, ONE, E(1,1), - $ LDE, DWORK(WPT), LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, - $ UI, 2, ONE, DWORK(WPT), LDWS ) - CALL DLACPY( 'A', KL-1, KB, B(1, KL), LDB, DWORK(YPT), - $ LDWS ) - CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, DWORK(WPT), - $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) -C -C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix -C from the RQ-factorization of the (KL-1)-by-KH matrix -C -C ( ) -C ( B(1:KL-1,1:KL-1) Y ) -C ( ). -C - DO 300 J = 1, KB - DO 280 I = KL-1, 1, -1 - X = B(I,I) - Z = DWORK(YPT+I-1+(J-1)*LDWS) - CALL DROTG( X, Z, C, S ) - CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, - $ C, S ) - 280 CONTINUE - 300 CONTINUE -C -C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. -C - DO 320 I = 1, KL-1 - IF ( B(I,I) .LT. ZERO ) - $ CALL DSCAL( I, MONE, B(1,I), 1 ) - 320 CONTINUE -C -C Overwrite right hand side with the part of the solution -C computed in step II. -C - CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), - $ LDB ) -C - END IF -C -C Overwrite right hand side with the part of the solution -C computed in step I. -C - CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) -C - GOTO 200 - END IF -C END WHILE 200 -C - END IF -C - RETURN -C *** Last line of SG03BV *** - END diff --git a/slycot/src/SG03BW.f b/slycot/src/SG03BW.f deleted file mode 100644 index aed45369..00000000 --- a/slycot/src/SG03BW.f +++ /dev/null @@ -1,459 +0,0 @@ - SUBROUTINE SG03BW( TRANS, M, N, A, LDA, C, LDC, E, LDE, D, LDD, X, - $ LDX, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X the generalized Sylvester equation -C -C T T -C A * X * C + E * X * D = SCALE * Y, (1) -C -C or the transposed equation -C -C T T -C A * X * C + E * X * D = SCALE * Y, (2) -C -C where A and E are real M-by-M matrices, C and D are real N-by-N -C matrices, X and Y are real M-by-N matrices. N is either 1 or 2. -C The pencil A - lambda * E must be in generalized real Schur form -C (A upper quasitriangular, E upper triangular). SCALE is an output -C scale factor, set to avoid overflow in X. -C -C ARGUMENTS -C -C Mode Parameters -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': Solve equation (1); -C = 'T': Solve equation (2). -C -C Input/Output Parameters -C -C M (input) INTEGER -C The order of the matrices A and E. M >= 0. -C -C N (input) INTEGER -C The order of the matrices C and D. N = 1 or N = 2. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,M) -C The leading M-by-M part of this array must contain the -C upper quasitriangular matrix A. The elements below the -C upper Hessenberg part are not referenced. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,M). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading N-by-N part of this array must contain the -C matrix C. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,N). -C -C E (input) DOUBLE PRECISION array, dimension (LDE,M) -C The leading M-by-M part of this array must contain the -C upper triangular matrix E. The elements below the main -C diagonal are not referenced. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= MAX(1,M). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,N) -C The leading N-by-N part of this array must contain the -C matrix D. -C -C LDD INTEGER -C The leading dimension of the array D. LDD >= MAX(1,N). -C -C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, the leading M-by-N part of this array must -C contain the right hand side matrix Y. -C On exit, the leading M-by-N part of this array contains -C the solution matrix X. -C -C LDX INTEGER -C The leading dimension of the array X. LDX >= MAX(1,M). -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in X. -C 0 < SCALE <= 1. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the generalized Sylvester equation is (nearly) -C singular to working precision; perturbed values -C were used to solve the equation (but the matrices -C A, C, D, and E are unchanged). -C -C METHOD -C -C The method used by the routine is based on a generalization of the -C algorithm due to Bartels and Stewart [1]. See also [2] and [3] for -C details. -C -C REFERENCES -C -C [1] Bartels, R.H., Stewart, G.W. -C Solution of the equation A X + X B = C. -C Comm. A.C.M., 15, pp. 820-826, 1972. -C -C [2] Gardiner, J.D., Laub, A.J., Amato, J.J., Moler, C.B. -C Solution of the Sylvester Matrix Equation -C A X B**T + C X D**T = E. -C A.C.M. Trans. Math. Soft., vol. 18, no. 2, pp. 223-231, 1992. -C -C [3] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C NUMERICAL ASPECTS -C -C The routine requires about 2 * N * M**2 flops. Note that we count -C a single floating point arithmetic operation as one flop. -C -C The algorithm is backward stable if the eigenvalues of the pencil -C A - lambda * E are real. Otherwise, linear systems of order at -C most 4 are involved into the computation. These systems are solved -C by Gauss elimination with complete pivoting. The loss of stability -C of the Gauss elimination with complete pivoting is rarely -C encountered in practice. -C -C FURTHER COMMENTS -C -C When near singularity is detected, perturbed values are used -C to solve the equation (but the given matrices are unchanged). -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C KEYWORDS -C -C Lyapunov equation -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDC, LDD, LDE, LDX, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), C(LDC,*), D(LDD,*), E(LDE,*), X(LDX,*) -C .. Local Scalars .. - DOUBLE PRECISION SCALE1 - INTEGER DIMMAT, I, INFO1, J, MA, MAI, MAJ, MB, ME - LOGICAL NOTRNS -C .. Local Arrays .. - DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) - INTEGER PIV1(4), PIV2(4) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DSCAL, MB02UU, MB02UV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C Decode input parameters. -C - NOTRNS = LSAME( TRANS, 'N' ) -C -C Check the scalar input parameters. -C - IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN - INFO = -1 - ELSEIF ( M .LT. 0 ) THEN - INFO = -2 - ELSEIF ( N .NE. 1 .AND. N .NE. 2 ) THEN - INFO = -3 - ELSEIF ( LDA .LT. MAX( 1, M ) ) THEN - INFO = -5 - ELSEIF ( LDC .LT. MAX( 1, N ) ) THEN - INFO = -7 - ELSEIF ( LDE .LT. MAX( 1, M ) ) THEN - INFO = -9 - ELSEIF ( LDD .LT. MAX( 1, N ) ) THEN - INFO = -11 - ELSEIF ( LDX .LT. MAX( 1, M ) ) THEN - INFO = -13 - ELSE - INFO = 0 - END IF - IF ( INFO .NE. 0 ) THEN - CALL XERBLA( 'SG03BW', -INFO ) - RETURN - END IF -C - SCALE = ONE -C -C Quick return if possible. -C - IF ( M .EQ. 0 ) - $ RETURN -C - IF ( NOTRNS ) THEN -C -C Solve equation (1). -C -C Compute block row X(MA:ME,:). MB denotes the number of rows in -C this block row. -C - ME = 0 -C WHILE ( ME .NE. M ) DO - 20 IF ( ME .NE. M ) THEN - MA = ME + 1 - IF ( MA .EQ. M ) THEN - ME = M - MB = 1 - ELSE - IF ( A(MA+1,MA) .EQ. ZERO ) THEN - ME = MA - MB = 1 - ELSE - ME = MA + 1 - MB = 2 - END IF - END IF -C -C Assemble Kronecker product system of linear equations with -C matrix -C -C MAT = kron(C',A(MA:ME,MA:ME)') + kron(D',E(MA:ME,MA:ME)') -C -C and right hand side -C -C RHS = vec(X(MA:ME,:)). -C - IF ( N .EQ. 1 ) THEN - DIMMAT = MB - DO 60 I = 1, MB - MAI = MA + I - 1 - DO 40 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAJ,MAI) - IF ( MAJ .LE. MAI ) - $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) - 40 CONTINUE - RHS(I) = X(MAI,1) - 60 CONTINUE - ELSE - DIMMAT = 2*MB - DO 100 I = 1, MB - MAI = MA + I - 1 - DO 80 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAJ,MAI) - MAT(MB+I,J) = C(1,2)*A(MAJ,MAI) - MAT(I,MB+J) = C(2,1)*A(MAJ,MAI) - MAT(MB+I,MB+J) = C(2,2)*A(MAJ,MAI) - IF ( MAJ .LE. MAI ) THEN - MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) - MAT(MB+I,J) = MAT(MB+I,J) + D(1,2)*E(MAJ,MAI) - MAT(I,MB+J) = MAT(I,MB+J) + D(2,1)*E(MAJ,MAI) - MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + - $ D(2,2)*E(MAJ,MAI) - END IF - 80 CONTINUE - RHS(I) = X(MAI,1) - RHS(MB+I) = X(MAI,2) - 100 CONTINUE - END IF -C -C Solve the system of linear equations. -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 120 I = 1, N - CALL DSCAL( M, SCALE1, X(1,I), 1 ) - 120 CONTINUE - END IF -C - IF ( N .EQ. 1 ) THEN - DO 140 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - 140 CONTINUE - ELSE - DO 160 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - X(MAI,2) = RHS(MB+I) - 160 CONTINUE - END IF -C -C Update right hand sides. -C -C X(ME+1:M,:) = X(ME+1:M,:) - A(MA:ME,ME+1:M)'*X(MA:ME,:)*C -C -C X(ME+1:M,:) = X(ME+1:M,:) - E(MA:ME,ME+1:M)'*X(MA:ME,:)*D -C - IF ( ME .LT. M ) THEN - CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, C, - $ LDC, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, A(MA,ME+1), - $ LDA, TM, 2, ONE, X(ME+1,1), LDX ) - CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, D, - $ LDD, ZERO, TM, 2 ) - CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, E(MA,ME+1), LDE, - $ TM, 2, ONE, X(ME+1,1), LDX ) - END IF -C - GOTO 20 - END IF -C END WHILE 20 -C - ELSE -C -C Solve equation (2). -C -C Compute block row X(MA:ME,:). MB denotes the number of rows in -C this block row. -C - MA = M + 1 -C WHILE ( MA .NE. 1 ) DO - 180 IF ( MA .NE. 1 ) THEN - ME = MA - 1 - IF ( ME .EQ. 1 ) THEN - MA = 1 - MB = 1 - ELSE - IF ( A(ME,ME-1) .EQ. ZERO ) THEN - MA = ME - MB = 1 - ELSE - MA = ME - 1 - MB = 2 - END IF - END IF -C -C Assemble Kronecker product system of linear equations with -C matrix -C -C MAT = kron(C,A(MA:ME,MA:ME)) + kron(D,E(MA:ME,MA:ME)) -C -C and right hand side -C -C RHS = vec(X(MA:ME,:)). -C - IF ( N .EQ. 1 ) THEN - DIMMAT = MB - DO 220 I = 1, MB - MAI = MA + I - 1 - DO 200 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAI,MAJ) - IF ( MAJ .GE. MAI ) - $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) - 200 CONTINUE - RHS(I) = X(MAI,1) - 220 CONTINUE - ELSE - DIMMAT = 2*MB - DO 260 I = 1, MB - MAI = MA + I - 1 - DO 240 J = 1, MB - MAJ = MA + J - 1 - MAT(I,J) = C(1,1)*A(MAI,MAJ) - MAT(MB+I,J) = C(2,1)*A(MAI,MAJ) - MAT(I,MB+J) = C(1,2)*A(MAI,MAJ) - MAT(MB+I,MB+J) = C(2,2)*A(MAI,MAJ) - IF ( MAJ .GE. MAI ) THEN - MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) - MAT(MB+I,J) = MAT(MB+I,J) + D(2,1)*E(MAI,MAJ) - MAT(I,MB+J) = MAT(I,MB+J) + D(1,2)*E(MAI,MAJ) - MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + - $ D(2,2)*E(MAI,MAJ) - END IF - 240 CONTINUE - RHS(I) = X(MAI,1) - RHS(MB+I) = X(MAI,2) - 260 CONTINUE - END IF -C -C Solve the system of linear equations. -C - CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) - IF ( INFO1 .NE. 0 ) - $ INFO = 1 - CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) - IF ( SCALE1 .NE. ONE ) THEN - SCALE = SCALE1*SCALE - DO 280 I = 1, N - CALL DSCAL( M, SCALE1, X(1,I), 1 ) - 280 CONTINUE - END IF -C - IF ( N .EQ. 1 ) THEN - DO 300 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - 300 CONTINUE - ELSE - DO 320 I = 1, MB - MAI = MA + I - 1 - X(MAI,1) = RHS(I) - X(MAI,2) = RHS(MB+I) - 320 CONTINUE - END IF -C -C Update right hand sides. -C -C X(1:MA-1,:) = X(1:MA-1,:) - A(1:MA-1,MA:ME)*X(MA:ME,:)*C' -C -C X(1:MA-1,:) = X(1:MA-1,:) - E(1:MA-1,MA:ME)*X(MA:ME,:)*D' -C - IF ( MA .GT. 1 ) THEN - CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, C, - $ LDC, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, A(1,MA), LDA, - $ TM, 2, ONE, X, LDX ) - CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, D, - $ LDD, ZERO, TM, 2 ) - CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, E(1,MA), LDE, - $ TM, 2, ONE, X, LDX ) - END IF -C - GOTO 180 - END IF -C END WHILE 180 -C - END IF -C - RETURN -C *** Last line of SG03BW *** - END diff --git a/slycot/src/SG03BX.f b/slycot/src/SG03BX.f deleted file mode 100644 index 651716cd..00000000 --- a/slycot/src/SG03BX.f +++ /dev/null @@ -1,764 +0,0 @@ - SUBROUTINE SG03BX( DICO, TRANS, A, LDA, E, LDE, B, LDB, U, LDU, - $ SCALE, M1, LDM1, M2, LDM2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To solve for X = op(U)**T * op(U) either the generalized c-stable -C continuous-time Lyapunov equation -C -C T T -C op(A) * X * op(E) + op(E) * X * op(A) -C -C 2 T -C = - SCALE * op(B) * op(B), (1) -C -C or the generalized d-stable discrete-time Lyapunov equation -C -C T T -C op(A) * X * op(A) - op(E) * X * op(E) -C -C 2 T -C = - SCALE * op(B) * op(B), (2) -C -C where op(K) is either K or K**T for K = A, B, E, U. The Cholesky -C factor U of the solution is computed without first finding X. -C -C Furthermore, the auxiliary matrices -C -C -1 -1 -C M1 := op(U) * op(A) * op(E) * op(U) -C -C -1 -1 -C M2 := op(B) * op(E) * op(U) -C -C are computed in a numerically reliable way. -C -C The matrices A, B, E, M1, M2, and U are real 2-by-2 matrices. The -C pencil A - lambda * E must have a pair of complex conjugate -C eigenvalues. The eigenvalues must be in the open right half plane -C (in the continuous-time case) or inside the unit circle (in the -C discrete-time case). -C -C The resulting matrix U is upper triangular. The entries on its -C main diagonal are non-negative. SCALE is an output scale factor -C set to avoid overflow in U. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies whether the continuous-time or the discrete-time -C equation is to be solved: -C = 'C': Solve continuous-time equation (1); -C = 'D': Solve discrete-time equation (2). -C -C TRANS CHARACTER*1 -C Specifies whether the transposed equation is to be solved -C or not: -C = 'N': op(K) = K, K = A, B, E, U; -C = 'T': op(K) = K**T, K = A, B, E, U. -C -C Input/Output Parameters -C -C A (input) DOUBLE PRECISION array, dimension (LDA,2) -C The leading 2-by-2 part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= 2. -C -C E (input) DOUBLE PRECISION array, dimension (LDE,2) -C The leading 2-by-2 upper triangular part of this array -C must contain the matrix E. -C -C LDE INTEGER -C The leading dimension of the array E. LDE >= 2. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,2) -C The leading 2-by-2 upper triangular part of this array -C must contain the matrix B. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= 2. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,2) -C The leading 2-by-2 part of this array contains the upper -C triangular matrix U. -C -C LDU INTEGER -C The leading dimension of the array U. LDU >= 2. -C -C SCALE (output) DOUBLE PRECISION -C The scale factor set to avoid overflow in U. -C 0 < SCALE <= 1. -C -C M1 (output) DOUBLE PRECISION array, dimension (LDM1,2) -C The leading 2-by-2 part of this array contains the -C matrix M1. -C -C LDM1 INTEGER -C The leading dimension of the array M1. LDM1 >= 2. -C -C M2 (output) DOUBLE PRECISION array, dimension (LDM2,2) -C The leading 2-by-2 part of this array contains the -C matrix M2. -C -C LDM2 INTEGER -C The leading dimension of the array M2. LDM2 >= 2. -C -C Error indicator -C -C INFO INTEGER -C = 0: successful exit; -C = 2: the eigenvalues of the pencil A - lambda * E are not -C a pair of complex conjugate numbers; -C = 3: the eigenvalues of the pencil A - lambda * E are -C not in the open right half plane (in the continuous- -C time case) or inside the unit circle (in the -C discrete-time case). -C -C METHOD -C -C The method used by the routine is based on a generalization of the -C method due to Hammarling ([1], section 6) for Lyapunov equations -C of order 2. A more detailed description is given in [2]. -C -C REFERENCES -C -C [1] Hammarling, S.J. -C Numerical solution of the stable, non-negative definite -C Lyapunov equation. -C IMA J. Num. Anal., 2, pp. 303-323, 1982. -C -C [2] Penzl, T. -C Numerical solution of generalized Lyapunov equations. -C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. -C -C FURTHER COMMENTS -C -C If the solution matrix U is singular, the matrices M1 and M2 are -C properly set (see [1], equation (6.21)). -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C Dec. 1998 (V. Sima). -C July 2003 (V. Sima; suggested by Klaus Schnepper). -C Oct. 2003 (A. Varga). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION MONE, ONE, TWO, ZERO - PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, - $ ZERO = 0.0D+0) -C .. Scalar Arguments .. - CHARACTER DICO, TRANS - DOUBLE PRECISION SCALE - INTEGER INFO, LDA, LDB, LDE, LDM1, LDM2, LDU -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), E(LDE,*), M1(LDM1,*), - $ M2(LDM2,*), U(LDU,*) -C .. Local Scalars .. - DOUBLE PRECISION ALPHA, B11, B12I, B12R, B22, BETAI, BETAR, - $ BIGNUM, CI, CR, EPS, L, LAMI, LAMR, SCALE1, - $ SCALE2, SI, SMLNUM, SR, T, V, W, XR, XI, YR, YI - LOGICAL ISCONT, ISTRNS -C .. Local Arrays .. - DOUBLE PRECISION AA(2,2), AI(2,2), AR(2,2), BB(2,2), BI(2,2), - $ BR(2,2), EE(2,2), EI(2,2), ER(2,2), M1I(2,2), - $ M1R(2,2), M2I(2,2), M2R(2,2), QBI(2,2), - $ QBR(2,2), QI(2,2), QR(2,2), QUI(2,2), QUR(2,2), - $ TI(2,2), TR(2,2), UI(2,2), UR(2,2), ZI(2,2), - $ ZR(2,2) -C .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2 - LOGICAL LSAME - EXTERNAL DLAMCH, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLADIV, DLAG2, - $ SG03BY -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -C -C Decode input parameters. -C - ISTRNS = LSAME( TRANS, 'T' ) - ISCONT = LSAME( DICO, 'C' ) -C -C Do not check input parameters for errors. -C -C Set constants to control overflow. -C - EPS = DLAMCH( 'P' ) - SMLNUM = DLAMCH( 'S' )/EPS - BIGNUM = ONE/SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -C - INFO = 0 - SCALE = ONE -C -C Make copies of A, E, and B. -C - AA(1,1) = A(1,1) - AA(2,1) = A(2,1) - AA(1,2) = A(1,2) - AA(2,2) = A(2,2) - EE(1,1) = E(1,1) - EE(2,1) = ZERO - EE(1,2) = E(1,2) - EE(2,2) = E(2,2) - BB(1,1) = B(1,1) - BB(2,1) = ZERO - BB(1,2) = B(1,2) - BB(2,2) = B(2,2) -C -C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be -C solved, transpose the matrices A, E, B with respect to the -C anti-diagonal. This results in a non-transposed equation. -C - IF ( ISTRNS ) THEN - V = AA(1,1) - AA(1,1) = AA(2,2) - AA(2,2) = V - V = EE(1,1) - EE(1,1) = EE(2,2) - EE(2,2) = V - V = BB(1,1) - BB(1,1) = BB(2,2) - BB(2,2) = V - END IF -C -C Perform QZ-step to transform the pencil A - lambda * E to -C generalized Schur form. The main diagonal of the Schur factor of E -C is real and positive. -C -C Compute eigenvalues (LAMR + LAMI * I, LAMR - LAMI * I). -C - T = MAX( EPS*MAX( ABS( EE(1,1) ), ABS( EE(1,2) ), - $ ABS( EE(2,2) ) ), SMLNUM ) - IF ( MIN( ABS( EE(1,1) ), ABS( EE(2,2) ) ) .LT. T ) THEN - INFO = 3 - RETURN - END IF - CALL DLAG2( AA, 2, EE, 2, SMLNUM*EPS, SCALE1, SCALE2, LAMR, - $ W, LAMI ) - IF (LAMI .LE. ZERO) THEN - INFO = 2 - RETURN - END IF -C -C Compute right orthogonal transformation matrix Q. -C - CALL SG03BY( SCALE1*AA(1,1) - EE(1,1)*LAMR, -EE(1,1)*LAMI, - $ SCALE1*AA(2,1), ZERO, CR, CI, SR, SI, L ) - QR(1,1) = CR - QR(1,2) = SR - QR(2,1) = -SR - QR(2,2) = CR - QI(1,1) = -CI - QI(1,2) = -SI - QI(2,1) = -SI - QI(2,2) = CI -C -C A := Q * A -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, AA, 2, ZERO, AR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, AA, 2, ZERO, AI, 2 ) -C -C E := Q * E -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, EE, 2, ZERO, ER, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, EE, 2, ZERO, EI, 2 ) -C -C Compute left orthogonal transformation matrix Z. -C - CALL SG03BY( ER(2,2), EI(2,2), ER(2,1), EI(2,1), CR, CI, SR, SI, - $ L ) - ZR(1,1) = CR - ZR(1,2) = SR - ZR(2,1) = -SR - ZR(2,2) = CR - ZI(1,1) = CI - ZI(1,2) = -SI - ZI(2,1) = -SI - ZI(2,2) = -CI -C -C E := E * Z -C - CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, ER, 2, ZERO, TR, 2 ) - CALL DGEMV( 'T', 2, 2, MONE, ZI, 2, EI, 2, ONE, TR, 2 ) - CALL DGEMV( 'T', 2, 2, ONE, ZI, 2, ER, 2, ZERO, TI, 2 ) - CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, EI, 2, ONE, TI, 2 ) - CALL DCOPY( 2, TR, 2, ER, 2 ) - CALL DCOPY( 2, TI, 2, EI, 2 ) - ER(2,1) = ZERO - ER(2,2) = L - EI(2,1) = ZERO - EI(2,2) = ZERO -C -C Make main diagonal entries of E real and positive. -C (Note: Z and E are altered.) -C - V = DLAPY2( ER(1,1), EI(1,1) ) - CALL DLADIV( V, ZERO, ER(1,1), EI(1,1), XR, XI ) - ER(1,1) = V - EI(1,1) = ZERO - YR = ZR(1,1) - YI = ZI(1,1) - ZR(1,1) = XR*YR - XI*YI - ZI(1,1) = XR*YI + XI*YR - YR = ZR(2,1) - YI = ZI(2,1) - ZR(2,1) = XR*YR - XI*YI - ZI(2,1) = XR*YI + XI*YR -C -C A := A * Z -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZR, 2, ZERO, TR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, AI, 2, ZI, 2, ONE, TR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZI, 2, ZERO, TI, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AI, 2, ZR, 2, ONE, TI, 2 ) - CALL DCOPY( 4, TR, 1, AR, 1 ) - CALL DCOPY( 4, TI, 1, AI, 1 ) -C -C End of QZ-step. -C -C B := B * Z -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZR, 2, ZERO, BR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZI, 2, ZERO, BI, 2 ) -C -C Overwrite B with the upper triangular matrix of its -C QR-factorization. The elements on the main diagonal are real -C and non-negative. -C - CALL SG03BY( BR(1,1), BI(1,1), BR(2,1), BI(2,1), CR, CI, SR, SI, - $ L ) - QBR(1,1) = CR - QBR(1,2) = SR - QBR(2,1) = -SR - QBR(2,2) = CR - QBI(1,1) = -CI - QBI(1,2) = -SI - QBI(2,1) = -SI - QBI(2,2) = CI - CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BR(1,2), 1, ZERO, TR, 1 ) - CALL DGEMV( 'N', 2, 2, MONE, QBI, 2, BI(1,2), 1, ONE, TR, 1 ) - CALL DGEMV( 'N', 2, 2, ONE, QBI, 2, BR(1,2), 1, ZERO, TI, 1 ) - CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BI(1,2), 1, ONE, TI, 1 ) - CALL DCOPY( 2, TR, 1, BR(1,2), 1 ) - CALL DCOPY( 2, TI, 1, BI(1,2), 1 ) - BR(1,1) = L - BR(2,1) = ZERO - BI(1,1) = ZERO - BI(2,1) = ZERO - V = DLAPY2( BR(2,2), BI(2,2) ) - IF ( V .GE. MAX( EPS*MAX( BR(1,1), DLAPY2( BR(1,2), BI(1,2) ) ), - $ SMLNUM ) ) THEN - CALL DLADIV( V, ZERO, BR(2,2), BI(2,2), XR, XI ) - BR(2,2) = V - YR = QBR(2,1) - YI = QBI(2,1) - QBR(2,1) = XR*YR - XI*YI - QBI(2,1) = XR*YI + XI*YR - YR = QBR(2,2) - YI = QBI(2,2) - QBR(2,2) = XR*YR - XI*YI - QBI(2,2) = XR*YI + XI*YR - ELSE - BR(2,2) = ZERO - END IF - BI(2,2) = ZERO -C -C Compute the Cholesky factor of the solution of the reduced -C equation. The solution may be scaled to avoid overflow. -C - IF ( ISCONT ) THEN -C -C Continuous-time equation. -C -C Step I: Compute U(1,1). Set U(2,1) = 0. -C - V = -TWO*( AR(1,1)*ER(1,1) + AI(1,1)*EI(1,1) ) - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - T = TWO*ABS( BR(1,1) )*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - END IF - UR(1,1) = BR(1,1)/V - UI(1,1) = ZERO - UR(2,1) = ZERO - UI(2,1) = ZERO -C -C Step II: Compute U(1,2). -C - T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), - $ SMLNUM ) - IF ( ABS( BR(1,1) ) .LT. T ) THEN - UR(1,2) = ZERO - UI(1,2) = ZERO - ELSE - XR = AR(1,1)*ER(1,2) + AI(1,1)*EI(1,2) - XI = AI(1,1)*ER(1,2) - AR(1,1)*EI(1,2) - XR = XR + AR(1,2)*ER(1,1) + AI(1,2)*EI(1,1) - XI = XI - AI(1,2)*ER(1,1) + AR(1,2)*EI(1,1) - XR = -BR(1,2)*V - XR*UR(1,1) - XI = BI(1,2)*V - XI*UR(1,1) - YR = AR(2,2)*ER(1,1) + AI(2,2)*EI(1,1) - YI = -AI(2,2)*ER(1,1) + AR(2,2)*EI(1,1) - YR = YR + ER(2,2)*AR(1,1) + EI(2,2)*AI(1,1) - YI = YI - EI(2,2)*AR(1,1) + ER(2,2)*AI(1,1) - T = TWO*DLAPY2( XR, XI )*SMLNUM - IF ( T .GT. DLAPY2( YR, YI ) ) THEN - SCALE1 = DLAPY2( YR, YI )/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - UR(1,1) = SCALE1*UR(1,1) - XR = SCALE1*XR - XI = SCALE1*XI - END IF - CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) - UI(1,2) = -UI(1,2) - END IF -C -C Step III: Compute U(2,2). -C - XR = ( ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) )*V - XI = (-EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) )*V - T = TWO*DLAPY2( XR, XI )*SMLNUM - IF ( T .GT. DLAPY2( ER(1,1), EI(1,1) ) ) THEN - SCALE1 = DLAPY2( ER(1,1), EI(1,1) )/T - SCALE = SCALE1*SCALE - UR(1,1) = SCALE1*UR(1,1) - UR(1,2) = SCALE1*UR(1,2) - UI(1,2) = SCALE1*UI(1,2) - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - XR = SCALE1*XR - XI = SCALE1*XI - END IF - CALL DLADIV( XR, XI, ER(1,1), -EI(1,1), YR, YI ) - YR = BR(1,2) - YR - YI = -BI(1,2) - YI - V = -TWO*( AR(2,2)*ER(2,2) + AI(2,2)*EI(2,2) ) - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - W = DLAPY2( DLAPY2( BR(2,2), BI(2,2) ), DLAPY2( YR, YI ) ) - T = TWO*W*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - UR(1,1) = SCALE1*UR(1,1) - UR(1,2) = SCALE1*UR(1,2) - UI(1,2) = SCALE1*UI(1,2) - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - W = SCALE1*W - END IF - UR(2,2) = W/V - UI(2,2) = ZERO -C -C Compute matrices M1 and M2 for the reduced equation. -C - M1R(2,1) = ZERO - M1I(2,1) = ZERO - M2R(2,1) = ZERO - M2I(2,1) = ZERO - CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) - M1R(1,1) = BETAR - M1I(1,1) = BETAI - M1R(2,2) = BETAR - M1I(2,2) = -BETAI - ALPHA = SQRT( -TWO*BETAR ) - M2R(1,1) = ALPHA - M2I(1,1) = ZERO - V = ER(1,1)*ER(2,2) - XR = ( -BR(1,1)*ER(1,2) + ER(1,1)*BR(1,2) )/V - XI = ( -BR(1,1)*EI(1,2) + ER(1,1)*BI(1,2) )/V - YR = XR - ALPHA*UR(1,2) - YI = -XI + ALPHA*UI(1,2) - IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN - M2R(1,2) = YR/UR(2,2) - M2I(1,2) = -YI/UR(2,2) - M2R(2,2) = BR(2,2)/( ER(2,2)*UR(2,2) ) - M2I(2,2) = ZERO - M1R(1,2) = -ALPHA*M2R(1,2) - M1I(1,2) = -ALPHA*M2I(1,2) - ELSE - M2R(1,2) = ZERO - M2I(1,2) = ZERO - M2R(2,2) = ALPHA - M2I(2,2) = ZERO - M1R(1,2) = ZERO - M1I(1,2) = ZERO - END IF - ELSE -C -C Discrete-time equation. -C -C Step I: Compute U(1,1). Set U(2,1) = 0. -C - V = ER(1,1)**2 + EI(1,1)**2 - AR(1,1)**2 - AI(1,1)**2 - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - T = TWO*ABS( BR(1,1) )*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - END IF - UR(1,1) = BR(1,1)/V - UI(1,1) = ZERO - UR(2,1) = ZERO - UI(2,1) = ZERO -C -C Step II: Compute U(1,2). -C - T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), - $ SMLNUM ) - IF ( ABS( BR(1,1) ) .LT. T ) THEN - UR(1,2) = ZERO - UI(1,2) = ZERO - ELSE - XR = AR(1,1)*AR(1,2) + AI(1,1)*AI(1,2) - XI = AI(1,1)*AR(1,2) - AR(1,1)*AI(1,2) - XR = XR - ER(1,2)*ER(1,1) - EI(1,2)*EI(1,1) - XI = XI + EI(1,2)*ER(1,1) - ER(1,2)*EI(1,1) - XR = -BR(1,2)*V - XR*UR(1,1) - XI = BI(1,2)*V - XI*UR(1,1) - YR = AR(2,2)*AR(1,1) + AI(2,2)*AI(1,1) - YI = -AI(2,2)*AR(1,1) + AR(2,2)*AI(1,1) - YR = YR - ER(2,2)*ER(1,1) - EI(2,2)*EI(1,1) - YI = YI + EI(2,2)*ER(1,1) - ER(2,2)*EI(1,1) - T = TWO*DLAPY2( XR, XI )*SMLNUM - IF ( T .GT. DLAPY2( YR, YI ) ) THEN - SCALE1 = DLAPY2( YR, YI )/T - SCALE = SCALE1*SCALE - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - UR(1,1) = SCALE1*UR(1,1) - XR = SCALE1*XR - XI = SCALE1*XI - END IF - CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) - UI(1,2) = -UI(1,2) - END IF -C -C Step III: Compute U(2,2). -C - XR = ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) - XI = -EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) - YR = AR(1,2)*UR(1,1) + AR(2,2)*UR(1,2) - AI(2,2)*UI(1,2) - YI = -AI(1,2)*UR(1,1) - AR(2,2)*UI(1,2) - AI(2,2)*UR(1,2) - V = ER(2,2)**2 + EI(2,2)**2 - AR(2,2)**2 - AI(2,2)**2 - IF ( V .LE. ZERO ) THEN - INFO = 3 - RETURN - END IF - V = SQRT( V ) - T = MAX( ABS( BR(2,2) ), ABS( BR(1,2) ), ABS( BI(1,2) ), - $ ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI) ) - IF ( T .LE. SMLNUM ) T = ONE - W = ( BR(2,2)/T )**2 + ( BR(1,2)/T )**2 + ( BI(1,2)/T )**2 - - $ ( XR/T )**2 - ( XI/T )**2 + ( YR/T )**2 + ( YI/T )**2 - IF ( W .LT. ZERO ) THEN - INFO = 3 - RETURN - END IF - W = T*SQRT( W ) - T = TWO*W*SMLNUM - IF ( T .GT. V ) THEN - SCALE1 = V/T - SCALE = SCALE1*SCALE - UR(1,1) = SCALE1*UR(1,1) - UR(1,2) = SCALE1*UR(1,2) - UI(1,2) = SCALE1*UI(1,2) - BR(1,1) = SCALE1*BR(1,1) - BR(1,2) = SCALE1*BR(1,2) - BI(1,2) = SCALE1*BI(1,2) - BR(2,2) = SCALE1*BR(2,2) - W = SCALE1*W - END IF - UR(2,2) = W/V - UI(2,2) = ZERO -C -C Compute matrices M1 and M2 for the reduced equation. -C - B11 = BR(1,1)/ER(1,1) - T = ER(1,1)*ER(2,2) - B12R = ( ER(1,1)*BR(1,2) - BR(1,1)*ER(1,2) )/T - B12I = ( ER(1,1)*BI(1,2) - BR(1,1)*EI(1,2) )/T - B22 = BR(2,2)/ER(2,2) - M1R(2,1) = ZERO - M1I(2,1) = ZERO - M2R(2,1) = ZERO - M2I(2,1) = ZERO - CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) - M1R(1,1) = BETAR - M1I(1,1) = BETAI - M1R(2,2) = BETAR - M1I(2,2) = -BETAI - V = DLAPY2( BETAR, BETAI ) - ALPHA = SQRT( ( ONE - V )*( ONE + V ) ) - M2R(1,1) = ALPHA - M2I(1,1) = ZERO - XR = ( AI(1,1)*EI(1,2) - AR(1,1)*ER(1,2) )/T + AR(1,2)/ER(2,2) - XI = ( AR(1,1)*EI(1,2) + AI(1,1)*ER(1,2) )/T - AI(1,2)/ER(2,2) - XR = -TWO*BETAI*B12I - B11*XR - XI = -TWO*BETAI*B12R - B11*XI - V = ONE + ( BETAI - BETAR )*( BETAI + BETAR ) - W = -TWO*BETAI*BETAR - CALL DLADIV( XR, XI, V, W, YR, YI ) - IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN - M2R(1,2) = ( YR*BETAR - YI*BETAI )/UR(2,2) - M2I(1,2) = -( YI*BETAR + YR*BETAI )/UR(2,2) - M2R(2,2) = B22/UR(2,2) - M2I(2,2) = ZERO - M1R(1,2) = -ALPHA*YR/UR(2,2) - M1I(1,2) = ALPHA*YI/UR(2,2) - ELSE - M2R(1,2) = ZERO - M2I(1,2) = ZERO - M2R(2,2) = ALPHA - M2I(2,2) = ZERO - M1R(1,2) = ZERO - M1I(1,2) = ZERO - END IF - END IF -C -C Transform U back: U := U * Q. -C (Note: Z is used as workspace.) -C - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QR, 2, ZERO, ZR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, UI, 2, QI, 2, ONE, ZR, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QI, 2, ZERO, ZI, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UI, 2, QR, 2, ONE, ZI, 2 ) -C -C Overwrite U with the upper triangular matrix of its -C QR-factorization. The elements on the main diagonal are real -C and non-negative. -C - CALL SG03BY( ZR(1,1), ZI(1,1), ZR(2,1), ZI(2,1), CR, CI, SR, SI, - $ L ) - QUR(1,1) = CR - QUR(1,2) = SR - QUR(2,1) = -SR - QUR(2,2) = CR - QUI(1,1) = -CI - QUI(1,2) = -SI - QUI(2,1) = -SI - QUI(2,2) = CI - CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZR(1,2), 1, ZERO, U(1,2), 1) - CALL DGEMV( 'N', 2, 2, MONE, QUI, 2, ZI(1,2), 1, ONE, U(1,2), 1) - CALL DGEMV( 'N', 2, 2, ONE, QUI, 2, ZR(1,2), 1, ZERO, UI(1,2), 1) - CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZI(1,2), 1, ONE, UI(1,2), 1) - U(1,1) = L - U(2,1) = ZERO - V = DLAPY2( U(2,2), UI(2,2) ) - IF ( V .NE. ZERO ) THEN - CALL DLADIV( V, ZERO, U(2,2), UI(2,2), XR, XI ) - YR = QUR(2,1) - YI = QUI(2,1) - QUR(2,1) = XR*YR - XI*YI - QUI(2,1) = XR*YI + XI*YR - YR = QUR(2,2) - YI = QUI(2,2) - QUR(2,2) = XR*YR - XI*YI - QUI(2,2) = XR*YI + XI*YR - END IF - U(2,2) = V -C -C Transform the matrices M1 and M2 back. -C -C M1 := QU * M1 * QU**H -C M2 := QB**H * M2 * QU**H -C - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1R, 2, QUR, 2, ZERO, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUI, 2, ONE, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M1R, 2, QUI, 2, ZERO, TI, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUR, 2, ONE, TI, 2 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QUR, 2, TR, 2, ZERO, M1, - $ LDM1 ) - CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, QUI, 2, TI, 2, ONE, M1, - $ LDM1 ) -C - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2R, 2, QUR, 2, ZERO, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUI, 2, ONE, TR, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M2R, 2, QUI, 2, ZERO, TI, 2 ) - CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUR, 2, ONE, TI, 2 ) - CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBR, 2, TR, 2, ZERO, M2, - $ LDM2 ) - CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBI, 2, TI, 2, ONE, M2, - $ LDM2 ) -C -C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be -C solved, transpose the matrix U with respect to the -C anti-diagonal and the matrices M1, M2 with respect to the diagonal -C and the anti-diagonal. -C - IF ( ISTRNS ) THEN - V = U(1,1) - U(1,1) = U(2,2) - U(2,2) = V - V = M1(1,1) - M1(1,1) = M1(2,2) - M1(2,2) = V - V = M2(1,1) - M2(1,1) = M2(2,2) - M2(2,2) = V - END IF -C - RETURN -C *** Last line of SG03BX *** - END diff --git a/slycot/src/SG03BY.f b/slycot/src/SG03BY.f deleted file mode 100644 index 356fe042..00000000 --- a/slycot/src/SG03BY.f +++ /dev/null @@ -1,93 +0,0 @@ - SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the parameters for the complex Givens rotation -C -C ( CR-CI*I SR-SI*I ) ( XR+XI*I ) ( Z ) -C ( ) * ( ) = ( ), -C ( -SR-SI*I CR+CI*I ) ( YR+YI*I ) ( 0 ) -C -C where CR, CI, SR, SI, XR, XI, YR, YI are real numbers and I is the -C imaginary unit, I = SQRT(-1). Z is a non-negative real number. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C XR, XI, (input) DOUBLE PRECISION -C YR, YI (input) DOUBLE PRECISION -C The given real scalars XR, XI, YR, YI. -C -C CR, CI, (output) DOUBLE PRECISION -C SR, SI, (output) DOUBLE PRECISION -C Z (output) DOUBLE PRECISION -C The computed real scalars CR, CI, SR, SI, Z, defining the -C complex Givens rotation and Z. -C -C NUMERICAL ASPECTS -C -C The subroutine avoids unnecessary overflow. -C -C FURTHER COMMENTS -C -C In the interest of speed, this routine does not check the input -C for errors. -C -C CONTRIBUTOR -C -C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. -C -C REVISIONS -C -C Sep. 1998 (V. Sima). -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION CI, CR, SI, SR, XI, XR, YI, YR, Z -C .. Intrinsic Functions .. - DOUBLE PRECISION ABS, MAX, SQRT -C .. Executable Statements .. -C - Z = MAX( ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI ) ) -C - IF ( Z .EQ. ZERO ) THEN - CR = ONE - CI = ZERO - SR = ZERO - SI = ZERO - ELSE - Z = Z*SQRT( ( XR/Z )**2 + ( XI/Z )**2 + - $ ( YR/Z )**2 + ( YI/Z )**2 ) - CR = XR/Z - CI = XI/Z - SR = YR/Z - SI = YI/Z - END IF -C - RETURN -C -C *** Last line of SG03BY *** - END diff --git a/slycot/src/SLCT_DLATZM.f b/slycot/src/SLCT_DLATZM.f deleted file mode 100644 index 06f140c2..00000000 --- a/slycot/src/SLCT_DLATZM.f +++ /dev/null @@ -1,223 +0,0 @@ -*> \brief \b DLATZM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download DLATZM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE SLCT_DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER INCV, LDC, M, N -* DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. -* DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This routine is deprecated and has been replaced by routine DORMRZ. -*> For compatibility, this copy re-named and included in SLYCOT -*> -*> DLATZM applies a Householder matrix generated by DTZRQF to a matrix. -*> -*> Let P = I - tau*u*u**T, u = ( 1 ), -*> ( v ) -*> where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if -*> SIDE = 'R'. -*> -*> If SIDE equals 'L', let -*> C = [ C1 ] 1 -*> [ C2 ] m-1 -*> n -*> Then C is overwritten by P*C. -*> -*> If SIDE equals 'R', let -*> C = [ C1, C2 ] m -*> 1 n-1 -*> Then C is overwritten by C*P. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': form P * C -*> = 'R': form C * P -*> \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' -*> (1 + (N-1)*abs(INCV)) if SIDE = 'R' -*> The vector v in the representation of P. 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 P. -*> \endverbatim -*> -*> \param[in,out] C1 -*> \verbatim -*> C1 is DOUBLE PRECISION array, dimension -*> (LDC,N) if SIDE = 'L' -*> (M,1) if SIDE = 'R' -*> On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 -*> if SIDE = 'R'. -*> -*> On exit, the first row of P*C if SIDE = 'L', or the first -*> column of C*P if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in,out] C2 -*> \verbatim -*> C2 is DOUBLE PRECISION array, dimension -*> (LDC, N) if SIDE = 'L' -*> (LDC, N-1) if SIDE = 'R' -*> On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the -*> m x (n - 1) matrix C2 if SIDE = 'R'. -*> -*> On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P -*> if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the arrays C1 and C2. LDC >= (1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension -*> (N) if SIDE = 'L' -*> (M) if SIDE = 'R' -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup doubleOTHERcomputational -* -* ===================================================================== - SUBROUTINE SLCT_DLATZM( SIDE, M, N, V, INCV, TAU, - & C1, C2, LDC, WORK ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) - $ RETURN -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* w := (C1 + v**T * C2)**T -* - CALL DCOPY( N, C1, LDC, WORK, 1 ) - CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE, - $ WORK, 1 ) -* -* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T -* [ C2 ] [ C2 ] [ v ] -* - CALL DAXPY( N, -TAU, WORK, 1, C1, LDC ) - CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* w := C1 + C2 * v -* - CALL DCOPY( M, C1, 1, WORK, 1 ) - CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, - $ WORK, 1 ) -* -* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T] -* - CALL DAXPY( M, -TAU, WORK, 1, C1, 1 ) - CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) - END IF -* - RETURN -* -* End of DLATZM -* - END diff --git a/slycot/src/SLCT_ZLATZM.f b/slycot/src/SLCT_ZLATZM.f deleted file mode 100644 index 5768ed69..00000000 --- a/slycot/src/SLCT_ZLATZM.f +++ /dev/null @@ -1,226 +0,0 @@ -*> \brief \b ZLATZM -* -* =========== DOCUMENTATION =========== -* -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ -* -*> \htmlonly -*> Download ZLATZM + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> -*> [TXT] -*> \endhtmlonly -* -* Definition: -* =========== -* -* SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) -* -* .. Scalar Arguments .. -* CHARACTER SIDE -* INTEGER INCV, LDC, M, N -* COMPLEX*16 TAU -* .. -* .. Array Arguments .. -* COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) -* .. -* -* -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> This routine is deprecated and has been replaced by routine ZUNMRZ. -*> -*> ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix. -*> -*> Let P = I - tau*u*u**H, u = ( 1 ), -*> ( v ) -*> where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if -*> SIDE = 'R'. -*> -*> If SIDE equals 'L', let -*> C = [ C1 ] 1 -*> [ C2 ] m-1 -*> n -*> Then C is overwritten by P*C. -*> -*> If SIDE equals 'R', let -*> C = [ C1, C2 ] m -*> 1 n-1 -*> Then C is overwritten by C*P. -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] SIDE -*> \verbatim -*> SIDE is CHARACTER*1 -*> = 'L': form P * C -*> = 'R': form C * P -*> \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' -*> (1 + (N-1)*abs(INCV)) if SIDE = 'R' -*> The vector v in the representation of P. 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 P. -*> \endverbatim -*> -*> \param[in,out] C1 -*> \verbatim -*> C1 is COMPLEX*16 array, dimension -*> (LDC,N) if SIDE = 'L' -*> (M,1) if SIDE = 'R' -*> On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 -*> if SIDE = 'R'. -*> -*> On exit, the first row of P*C if SIDE = 'L', or the first -*> column of C*P if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in,out] C2 -*> \verbatim -*> C2 is COMPLEX*16 array, dimension -*> (LDC, N) if SIDE = 'L' -*> (LDC, N-1) if SIDE = 'R' -*> On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the -*> m x (n - 1) matrix C2 if SIDE = 'R'. -*> -*> On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P -*> if SIDE = 'R'. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the arrays C1 and C2. -*> LDC >= max(1,M). -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is COMPLEX*16 array, dimension -*> (N) if SIDE = 'L' -*> (M) if SIDE = 'R' -*> \endverbatim -* -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 -* -*> \ingroup complex16OTHERcomputational -* -* ===================================================================== - SUBROUTINE SLCT_ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, - $ WORK ) -* -* -- LAPACK computational routine (version 3.4.0) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - COMPLEX*16 TAU -* .. -* .. Array Arguments .. - COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) -* .. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. External Subroutines .. - EXTERNAL ZAXPY, ZCOPY, ZGEMV, ZGERC, ZGERU, ZLACGV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) - $ RETURN -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* w := ( C1 + v**H * C2 )**H -* - CALL ZCOPY( N, C1, LDC, WORK, 1 ) - CALL ZLACGV( N, WORK, 1 ) - CALL ZGEMV( 'Conjugate transpose', M-1, N, ONE, C2, LDC, V, - $ INCV, ONE, WORK, 1 ) -* -* [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H -* [ C2 ] [ C2 ] [ v ] -* - CALL ZLACGV( N, WORK, 1 ) - CALL ZAXPY( N, -TAU, WORK, 1, C1, LDC ) - CALL ZGERU( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* w := C1 + C2 * v -* - CALL ZCOPY( M, C1, 1, WORK, 1 ) - CALL ZGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, - $ WORK, 1 ) -* -* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H] -* - CALL ZAXPY( M, -TAU, WORK, 1, C1, 1 ) - CALL ZGERC( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) - END IF -* - RETURN -* -* End of ZLATZM -* - END diff --git a/slycot/src/SLICOT-reference b/slycot/src/SLICOT-reference index 1fc31b7d..b19fe520 160000 --- a/slycot/src/SLICOT-reference +++ b/slycot/src/SLICOT-reference @@ -1 +1 @@ -Subproject commit 1fc31b7db59f027ccf1c7fcd0164e77e5ff97107 +Subproject commit b19fe52072f82d99168511153ae9bd1b586e81f5 diff --git a/slycot/src/TB01ID.f b/slycot/src/TB01ID.f deleted file mode 100644 index 9dbedb63..00000000 --- a/slycot/src/TB01ID.f +++ /dev/null @@ -1,402 +0,0 @@ - SUBROUTINE TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the 1-norm of a system matrix -C -C S = ( A B ) -C ( C 0 ) -C -C corresponding to the triple (A,B,C), by balancing. This involves -C a diagonal similarity transformation inv(D)*A*D applied -C iteratively to A to make the rows and columns of -C -1 -C diag(D,I) * S * diag(D,I) -C -C as close in norm as possible. -C -C The balancing can be performed optionally on the following -C particular system matrices -C -C S = A, S = ( A B ) or S = ( A ) -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B and A matrices are involved in balancing; -C = 'C': C and A matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C MAXRED (input/output) DOUBLE PRECISION -C On entry, the maximum allowed reduction in the 1-norm of -C S (in an iteration) if zero rows or columns are -C encountered. -C If MAXRED > 0.0, MAXRED must be larger than one (to enable -C the norm reduction). -C If MAXRED <= 0.0, then the value 10.0 for MAXRED is -C used. -C On exit, if the 1-norm of the given matrix S is non-zero, -C the ratio between the 1-norm of the given matrix and the -C 1-norm of the balanced matrix. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced matrix inv(D)*A*D. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, if M > 0, the leading N-by-M part of this array -C must contain the system input matrix B. -C On exit, if M > 0, the leading N-by-M part of this array -C contains the balanced matrix inv(D)*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0. -C LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, if P > 0, the leading P-by-N part of this array -C must contain the system output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*D. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S. If D(j) is the scaling -C factor applied to row and column j, then SCALE(j) = D(j), -C for j = 1,...,N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(D,I) * S * diag(D,I) -C -C to make the 1-norms of each row of the first N rows of S and its -C corresponding column nearly equal. -C -C Information about the diagonal matrix D is returned in the vector -C SCALE. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C This subroutine is based on LAPACK routine DGEBAL, and routine -C BALABC (A. Varga, German Aerospace Research Establishment, DLR). -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) - DOUBLE PRECISION FACTOR, MAXR - PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, LDA, LDB, LDC, M, N, P - DOUBLE PRECISION MAXRED -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ SCALE( * ) -C .. -C .. Local Scalars .. - LOGICAL NOCONV, WITHB, WITHC - INTEGER I, ICA, IRA, J - DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DSCAL, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01ID', -INFO ) - RETURN - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Compute the 1-norm of the required part of matrix S and exit if -C it is zero. -C - SNORM = ZERO -C - DO 10 J = 1, N - SCALE( J ) = ONE - CO = DASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 10 CONTINUE -C - IF( WITHB ) THEN -C - DO 20 J = 1, M - SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) - 20 CONTINUE -C - END IF -C - IF( SNORM.EQ.ZERO ) - $ RETURN -C -C Set some machine parameters and the maximum reduction in the -C 1-norm of S if zero rows or columns are encountered. -C - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C - SRED = MAXRED - IF( SRED.LE.ZERO ) SRED = MAXR -C - MAXNRM = MAX( SNORM/SRED, SFMIN1 ) -C -C Balance the matrix. -C -C Iterative loop for norm reduction. -C - 30 CONTINUE - NOCONV = .FALSE. -C - DO 90 I = 1, N - CO = ZERO - RO = ZERO -C - DO 40 J = 1, N - IF( J.EQ.I ) - $ GO TO 40 - CO = CO + ABS( A( J, I ) ) - RO = RO + ABS( A( I, J ) ) - 40 CONTINUE -C - ICA = IDAMAX( N, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IDAMAX( N, A( I, 1 ), LDA ) - RA = ABS( A( I, IRA ) ) -C - IF( WITHC .AND. P.GT.0 ) THEN - CO = CO + DASUM( P, C( 1, I ), 1 ) - ICA = IDAMAX( P, C( 1, I ), 1 ) - CA = MAX( CA, ABS( C( ICA, I ) ) ) - END IF -C - IF( WITHB .AND. M.GT.0 ) THEN - RO = RO + DASUM( M, B( I, 1 ), LDB ) - IRA = IDAMAX( M, B( I, 1 ), LDB ) - RA = MAX( RA, ABS( B( I, IRA ) ) ) - END IF -C -C Special case of zero CO and/or RO. -C - IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) - $ GO TO 90 - IF( CO.EQ.ZERO ) THEN - IF( RO.LE.MAXNRM ) - $ GO TO 90 - CO = MAXNRM - END IF - IF( RO.EQ.ZERO ) THEN - IF( CO.LE.MAXNRM ) - $ GO TO 90 - RO = MAXNRM - END IF -C -C Guard against zero CO or RO due to underflow. -C - G = RO / SCLFAC - F = ONE - S = CO + RO - 50 CONTINUE - IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. - $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 - F = F*SCLFAC - CO = CO*SCLFAC - CA = CA*SCLFAC - G = G / SCLFAC - RO = RO / SCLFAC - RA = RA / SCLFAC - GO TO 50 -C - 60 CONTINUE - G = CO / SCLFAC - 70 CONTINUE - IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. - $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 - F = F / SCLFAC - CO = CO / SCLFAC - CA = CA / SCLFAC - G = G / SCLFAC - RO = RO*SCLFAC - RA = RA*SCLFAC - GO TO 70 -C -C Now balance. -C - 80 CONTINUE - IF( ( CO+RO ).GE.FACTOR*S ) - $ GO TO 90 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 90 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 90 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -C - CALL DSCAL( N, G, A( I, 1 ), LDA ) - CALL DSCAL( N, F, A( 1, I ), 1 ) - IF( M.GT.0 ) CALL DSCAL( M, G, B( I, 1 ), LDB ) - IF( P.GT.0 ) CALL DSCAL( P, F, C( 1, I ), 1 ) -C - 90 CONTINUE -C - IF( NOCONV ) - $ GO TO 30 -C -C Set the norm reduction parameter. -C - MAXRED = SNORM - SNORM = ZERO -C - DO 100 J = 1, N - CO = DASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 100 CONTINUE -C - IF( WITHB ) THEN -C - DO 110 J = 1, M - SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) - 110 CONTINUE -C - END IF - MAXRED = MAXRED/SNORM - RETURN -C *** Last line of TB01ID *** - END diff --git a/slycot/src/TB01IZ.f b/slycot/src/TB01IZ.f deleted file mode 100644 index e719aa39..00000000 --- a/slycot/src/TB01IZ.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the 1-norm of a system matrix -C -C S = ( A B ) -C ( C 0 ) -C -C corresponding to the triple (A,B,C), by balancing. This involves -C a diagonal similarity transformation inv(D)*A*D applied -C iteratively to A to make the rows and columns of -C -1 -C diag(D,I) * S * diag(D,I) -C -C as close in norm as possible. -C -C The balancing can be performed optionally on the following -C particular system matrices -C -C S = A, S = ( A B ) or S = ( A ) -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B and A matrices are involved in balancing; -C = 'C': C and A matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C MAXRED (input/output) DOUBLE PRECISION -C On entry, the maximum allowed reduction in the 1-norm of -C S (in an iteration) if zero rows or columns are -C encountered. -C If MAXRED > 0.0, MAXRED must be larger than one (to enable -C the norm reduction). -C If MAXRED <= 0.0, then the value 10.0 for MAXRED is -C used. -C On exit, if the 1-norm of the given matrix S is non-zero, -C the ratio between the 1-norm of the given matrix and the -C 1-norm of the balanced matrix. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced matrix inv(D)*A*D. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, if M > 0, the leading N-by-M part of this array -C must contain the system input matrix B. -C On exit, if M > 0, the leading N-by-M part of this array -C contains the balanced matrix inv(D)*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0. -C LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, if P > 0, the leading P-by-N part of this array -C must contain the system output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*D. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C SCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S. If D(j) is the scaling -C factor applied to row and column j, then SCALE(j) = D(j), -C for j = 1,...,N. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(D,I) * S * diag(D,I) -C -C to make the 1-norms of each row of the first N rows of S and its -C corresponding column nearly equal. -C -C Information about the diagonal matrix D is returned in the vector -C SCALE. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION SCLFAC - PARAMETER ( SCLFAC = 1.0D+1 ) - DOUBLE PRECISION FACTOR, MAXR - PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) -C .. -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, LDA, LDB, LDC, M, N, P - DOUBLE PRECISION MAXRED -C .. -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) - DOUBLE PRECISION SCALE( * ) -C .. -C .. Local Scalars .. - LOGICAL NOCONV, WITHB, WITHC - INTEGER I, ICA, IRA, J - DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, - $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED - COMPLEX*16 CDUM -C .. -C .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DLAMCH, DZASUM - EXTERNAL DLAMCH, DZASUM, IZAMAX, LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL -C .. -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, MAX, MIN -C .. -C .. Statement Functions .. - DOUBLE PRECISION CABS1 -C .. -C .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01IZ', -INFO ) - RETURN - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Compute the 1-norm of the required part of matrix S and exit if -C it is zero. -C - SNORM = ZERO -C - DO 10 J = 1, N - SCALE( J ) = ONE - CO = DZASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DZASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 10 CONTINUE -C - IF( WITHB ) THEN -C - DO 20 J = 1, M - SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) - 20 CONTINUE -C - END IF -C - IF( SNORM.EQ.ZERO ) - $ RETURN -C -C Set some machine parameters and the maximum reduction in the -C 1-norm of S if zero rows or columns are encountered. -C - SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) - SFMAX1 = ONE / SFMIN1 - SFMIN2 = SFMIN1*SCLFAC - SFMAX2 = ONE / SFMIN2 -C - SRED = MAXRED - IF( SRED.LE.ZERO ) SRED = MAXR -C - MAXNRM = MAX( SNORM/SRED, SFMIN1 ) -C -C Balance the matrix. -C -C Iterative loop for norm reduction. -C - 30 CONTINUE - NOCONV = .FALSE. -C - DO 90 I = 1, N - CO = ZERO - RO = ZERO -C - DO 40 J = 1, N - IF( J.EQ.I ) - $ GO TO 40 - CO = CO + CABS1( A( J, I ) ) - RO = RO + CABS1( A( I, J ) ) - 40 CONTINUE -C - ICA = IZAMAX( N, A( 1, I ), 1 ) - CA = ABS( A( ICA, I ) ) - IRA = IZAMAX( N, A( I, 1 ), LDA ) - RA = ABS( A( I, IRA ) ) -C - IF( WITHC .AND. P.GT.0 ) THEN - CO = CO + DZASUM( P, C( 1, I ), 1 ) - ICA = IZAMAX( P, C( 1, I ), 1 ) - CA = MAX( CA, ABS( C( ICA, I ) ) ) - END IF -C - IF( WITHB .AND. M.GT.0 ) THEN - RO = RO + DZASUM( M, B( I, 1 ), LDB ) - IRA = IZAMAX( M, B( I, 1 ), LDB ) - RA = MAX( RA, ABS( B( I, IRA ) ) ) - END IF -C -C Special case of zero CO and/or RO. -C - IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) - $ GO TO 90 - IF( CO.EQ.ZERO ) THEN - IF( RO.LE.MAXNRM ) - $ GO TO 90 - CO = MAXNRM - END IF - IF( RO.EQ.ZERO ) THEN - IF( CO.LE.MAXNRM ) - $ GO TO 90 - RO = MAXNRM - END IF -C -C Guard against zero CO or RO due to underflow. -C - G = RO / SCLFAC - F = ONE - S = CO + RO - 50 CONTINUE - IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. - $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 - F = F*SCLFAC - CO = CO*SCLFAC - CA = CA*SCLFAC - G = G / SCLFAC - RO = RO / SCLFAC - RA = RA / SCLFAC - GO TO 50 -C - 60 CONTINUE - G = CO / SCLFAC - 70 CONTINUE - IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. - $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 - F = F / SCLFAC - CO = CO / SCLFAC - CA = CA / SCLFAC - G = G / SCLFAC - RO = RO*SCLFAC - RA = RA*SCLFAC - GO TO 70 -C -C Now balance. -C - 80 CONTINUE - IF( ( CO+RO ).GE.FACTOR*S ) - $ GO TO 90 - IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN - IF( F*SCALE( I ).LE.SFMIN1 ) - $ GO TO 90 - END IF - IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN - IF( SCALE( I ).GE.SFMAX1 / F ) - $ GO TO 90 - END IF - G = ONE / F - SCALE( I ) = SCALE( I )*F - NOCONV = .TRUE. -C - CALL ZDSCAL( N, G, A( I, 1 ), LDA ) - CALL ZDSCAL( N, F, A( 1, I ), 1 ) - IF( M.GT.0 ) CALL ZDSCAL( M, G, B( I, 1 ), LDB ) - IF( P.GT.0 ) CALL ZDSCAL( P, F, C( 1, I ), 1 ) -C - 90 CONTINUE -C - IF( NOCONV ) - $ GO TO 30 -C -C Set the norm reduction parameter. -C - MAXRED = SNORM - SNORM = ZERO -C - DO 100 J = 1, N - CO = DZASUM( N, A( 1, J ), 1 ) - IF( WITHC .AND. P.GT.0 ) - $ CO = CO + DZASUM( P, C( 1, J ), 1 ) - SNORM = MAX( SNORM, CO ) - 100 CONTINUE -C - IF( WITHB ) THEN -C - DO 110 J = 1, M - SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) - 110 CONTINUE -C - END IF - MAXRED = MAXRED/SNORM - RETURN -C *** Last line of TB01IZ *** - END diff --git a/slycot/src/TB01KD.f b/slycot/src/TB01KD.f deleted file mode 100644 index a3d0a85d..00000000 --- a/slycot/src/TB01KD.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, - $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute an additive spectral decomposition of the transfer- -C function matrix of the system (A,B,C) by reducing the system -C state-matrix A to a block-diagonal form. -C The system matrices are transformed as -C A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U. -C The leading diagonal block of the resulting A has eigenvalues -C in a suitably defined domain of interest. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C JOBA CHARACTER*1 -C Specifies the shape of the state dynamics matrix on entry -C as follows: -C = 'S': A is in an upper real Schur form; -C = 'G': A is a general square dense matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION. -C Specifies the boundary of the domain of interest for the -C eigenvalues of A. For a continuous-time system -C (DICO = 'C'), ALPHA is the boundary value for the real -C parts of eigenvalues, while for a discrete-time system -C (DICO = 'D'), ALPHA >= 0 represents the boundary value for -C the moduli of eigenvalues. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the unreduced state dynamics matrix A. -C If JOBA = 'S' then A must be a matrix in real Schur form. -C On exit, the leading N-by-N part of this array contains a -C block diagonal matrix inv(U) * A * U with two diagonal -C blocks in real Schur form with the elements below the -C first subdiagonal set to zero. -C The leading NDIM-by-NDIM block of A has eigenvalues in the -C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) -C block has eigenvalues outside the domain of interest. -C The domain of interest for lambda(A), the eigenvalues -C of A, is defined by the parameters ALPHA, DICO and STDOM -C as follows: -C For a continuous-time system (DICO = 'C'): -C Real(lambda(A)) < ALPHA if STDOM = 'S'; -C Real(lambda(A)) > ALPHA if STDOM = 'U'; -C For a discrete-time system (DICO = 'D'): -C Abs(lambda(A)) < ALPHA if STDOM = 'S'; -C Abs(lambda(A)) > ALPHA if STDOM = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix inv(U) * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NDIM (output) INTEGER -C The number of eigenvalues of A lying inside the domain of -C interest for eigenvalues. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C transformation matrix used to reduce A to the block- -C diagonal form. The first NDIM columns of U span the -C invariant subspace of A corresponding to the eigenvalues -C of its leading diagonal block. The last N-NDIM columns -C of U span the reducing subspace of A corresponding to -C the eigenvalues of the trailing diagonal block of A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues of A. The -C eigenvalues will be in the same order that they appear on -C the diagonal of the output real Schur form of A. Complex -C conjugate pairs of eigenvalues will appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX(1,N) if JOBA = 'S'; -C LDWORK >= MAX(1,3*N) if JOBA = 'G'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to compute all the -C eigenvalues of A; -C = 2: a failure occured during the ordering of the real -C Schur form of A; -C = 3: the separation of the two diagonal blocks failed -C because of very close eigenvalues. -C -C METHOD -C -C A similarity transformation U is determined that reduces the -C system state-matrix A to a block-diagonal form (with two diagonal -C blocks), so that the leading diagonal block of the resulting A has -C eigenvalues in a specified domain of the complex plane. The -C determined transformation is applied to the system (A,B,C) as -C A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U. -C -C REFERENCES -C -C [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N. -C Synthesis of positive real multivariable feedback systems. -C Int. J. Control, pp. 817-842, 1987. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 14N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SADSDC. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Invariant subspace, real Schur form, similarity transformation, -C spectral factorization. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBA, STDOM - INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), - $ WI(*), WR(*) -C .. Local Scalars .. - LOGICAL DISCR, LJOBG - INTEGER NDIM1, NR - DOUBLE PRECISION SCALE -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMM, DLASET, DTRSYL, TB01LD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBG = LSAME( JOBA, 'G' ) -C -C Check input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. - $ LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. - $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01KD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NDIM = 0 - IF( N.EQ.0 ) - $ RETURN -C -C Reduce A to an ordered real Schur form using an orthogonal -C similarity transformation A <- U'*A*U and accumulate the -C transformations in U. The reordering of the real Schur form of A -C is performed in accordance with the values of the parameters DICO, -C STDOM and ALPHA. Apply the transformation to B and C: B <- U'*B -C and C <- C*U. The eigenvalues of A are computed in (WR,WI). -C -C Workspace: need 3*N (if JOBA = 'G'), or N (if JOBA = 'S'); -C prefer larger. -C - CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, LDB, C, - $ LDC, NDIM, U, LDU, WR, WI, DWORK, LDWORK, INFO ) -C - IF ( INFO.NE.0 ) - $ RETURN -C - IF ( NDIM.GT.0 .AND. NDIM.LT.N ) THEN -C -C Reduce A to a block-diagonal form by a similarity -C transformation of the form -C -1 ( I -X ) -C A <- T AT, where T = ( ) and X satisfies the -C ( 0 I ) -C Sylvester equation -C -C A11*X - X*A22 = A12. -C - NR = N - NDIM - NDIM1 = NDIM + 1 - CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1), - $ LDA, A(1,NDIM1), LDA, SCALE, INFO ) - IF ( INFO.NE.0 ) THEN - INFO = 3 - RETURN - END IF -C -1 -C Compute B <- T B, C <- CT, U <- UT. -C - SCALE = ONE/SCALE - CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA, - $ B(NDIM1,1), LDB, ONE, B, LDB ) - CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1), - $ LDA, ONE, C(1,NDIM1), LDC ) - CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1), - $ LDA, ONE, U(1,NDIM1), LDU ) -C -C Set A12 to zero. -C - CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA ) - END IF -C -C Set to zero the lower triangular part under the first subdiagonal -C of A. -C - IF ( N.GT.2 ) - $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) - RETURN -C *** Last line of TB01KD *** - END diff --git a/slycot/src/TB01LD.f b/slycot/src/TB01LD.f deleted file mode 100644 index 50f64c91..00000000 --- a/slycot/src/TB01LD.f +++ /dev/null @@ -1,348 +0,0 @@ - SUBROUTINE TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, - $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the system state matrix A to an ordered upper real -C Schur form by using an orthogonal similarity transformation -C A <-- U'*A*U and to apply the transformation to the matrices -C B and C: B <-- U'*B and C <-- C*U. -C The leading block of the resulting A has eigenvalues in a -C suitably defined domain of interest. -C -C ARGUMENTS -C -C Mode Parameters -C -C DICO CHARACTER*1 -C Specifies the type of the system as follows: -C = 'C': continuous-time system; -C = 'D': discrete-time system. -C -C STDOM CHARACTER*1 -C Specifies whether the domain of interest is of stability -C type (left part of complex plane or inside of a circle) -C or of instability type (right part of complex plane or -C outside of a circle) as follows: -C = 'S': stability type domain; -C = 'U': instability type domain. -C -C JOBA CHARACTER*1 -C Specifies the shape of the state dynamics matrix on entry -C as follows: -C = 'S': A is in an upper real Schur form; -C = 'G': A is a general square dense matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C ALPHA (input) DOUBLE PRECISION. -C Specifies the boundary of the domain of interest for the -C eigenvalues of A. For a continuous-time system -C (DICO = 'C'), ALPHA is the boundary value for the real -C parts of eigenvalues, while for a discrete-time system -C (DICO = 'D'), ALPHA >= 0 represents the boundary value -C for the moduli of eigenvalues. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the unreduced state dynamics matrix A. -C If JOBA = 'S' then A must be a matrix in real Schur form. -C On exit, the leading N-by-N part of this array contains -C the ordered real Schur matrix U' * A * U with the elements -C below the first subdiagonal set to zero. -C The leading NDIM-by-NDIM part of A has eigenvalues in the -C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) -C part has eigenvalues outside the domain of interest. -C The domain of interest for lambda(A), the eigenvalues -C of A, is defined by the parameters ALPHA, DICO and STDOM -C as follows: -C For a continuous-time system (DICO = 'C'): -C Real(lambda(A)) < ALPHA if STDOM = 'S'; -C Real(lambda(A)) > ALPHA if STDOM = 'U'; -C For a discrete-time system (DICO = 'D'): -C Abs(lambda(A)) < ALPHA if STDOM = 'S'; -C Abs(lambda(A)) > ALPHA if STDOM = 'U'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix U' * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NDIM (output) INTEGER -C The number of eigenvalues of A lying inside the domain of -C interest for eigenvalues. -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C orthogonal transformation matrix used to reduce A to the -C real Schur form and/or to reorder the diagonal blocks of -C real Schur form of A. The first NDIM columns of U form -C an orthogonal basis for the invariant subspace of A -C corresponding to the first NDIM eigenvalues. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues of A. The -C eigenvalues will be in the same order that they appear on -C the diagonal of the output real Schur form of A. Complex -C conjugate pairs of eigenvalues will appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. -C LDWORK >= MAX(1,N) if JOBA = 'S'; -C LDWORK >= MAX(1,3*N) if JOBA = 'G'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to compute all the -C eigenvalues of A; -C = 2: a failure occured during the ordering of the real -C Schur form of A. -C -C METHOD -C -C Matrix A is reduced to an ordered upper real Schur form using an -C orthogonal similarity transformation A <-- U'*A*U. This -C transformation is determined so that the leading block of the -C resulting A has eigenvalues in a suitably defined domain of -C interest. Then, the transformation is applied to the matrices B -C and C: B <-- U'*B and C <-- C*U. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 14N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRSFOD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. -C -C KEYWORDS -C -C Invariant subspace, orthogonal transformation, real Schur form, -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER DICO, JOBA, STDOM - INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), - $ WI(*), WR(*) -C .. Local Scalars .. - LOGICAL DISCR, LJOBG - INTEGER I, IERR, LDWP, SDIM - DOUBLE PRECISION WRKOPT -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DLASET, - $ MB03QD, MB03QX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C - INFO = 0 - DISCR = LSAME( DICO, 'D' ) - LJOBG = LSAME( JOBA, 'G' ) -C -C Check input scalar arguments. -C - IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. - $ LSAME( STDOM, 'U' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. - $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01LD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NDIM = 0 - IF( N.EQ.0 ) - $ RETURN -C - IF( LSAME( JOBA, 'G' ) ) THEN -C -C Reduce A to real Schur form using an orthogonal similarity -C transformation A <- U'*A*U, accumulate the transformation in U -C and compute the eigenvalues of A in (WR,WI). -C -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - WRKOPT = DWORK( 1 ) - IF( INFO.NE.0 ) THEN - INFO = 1 - RETURN - END IF - ELSE -C -C Initialize U with an identity matrix. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) - WRKOPT = 0 - END IF -C -C Separate the spectrum of A. The leading NDIM-by-NDIM submatrix of -C A corresponds to the eigenvalues of interest. -C Workspace: need N. -C - CALL MB03QD( DICO, STDOM, 'Update', N, 1, N, ALPHA, A, LDA, - $ U, LDU, NDIM, DWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN -C -C Compute the eigenvalues. -C - CALL MB03QX( N, A, LDA, WR, WI, IERR ) -C -C Apply the transformation: B <-- U'*B. -C - IF( LDWORK.LT.N*M ) THEN -C -C Not enough working space for using DGEMM. -C - DO 10 I = 1, M - CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ B(1,I), 1 ) - 10 CONTINUE -C - ELSE - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, - $ DWORK, N, ZERO, B, LDB ) - WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) - END IF -C -C Apply the transformation: C <-- C*U. -C - IF( LDWORK.LT.N*P ) THEN -C -C Not enough working space for using DGEMM. -C - DO 20 I = 1, P - CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ C(I,1), LDC ) - 20 CONTINUE -C - ELSE - LDWP = MAX( 1, P ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) - CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, - $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) - WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) - END IF -C - DWORK( 1 ) = WRKOPT -C - RETURN -C *** Last line of TB01LD *** - END diff --git a/slycot/src/TB01MD.f b/slycot/src/TB01MD.f deleted file mode 100644 index b446e719..00000000 --- a/slycot/src/TB01MD.f +++ /dev/null @@ -1,340 +0,0 @@ - SUBROUTINE TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the pair (B,A) to upper or lower controller Hessenberg -C form using (and optionally accumulating) unitary state-space -C transformations. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the unitary state-space transformations for -C reducing the system, as follows: -C = 'N': Do not form U; -C = 'I': U is initialized to the unit matrix and the -C unitary transformation matrix U is returned; -C = 'U': The given matrix U is updated by the unitary -C transformations used in the reduction. -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes the pair (B,A) to be -C reduced to upper or lower controller Hessenberg form as -C follows: -C = 'U': Upper controller Hessenberg form; -C = 'L': Lower controller Hessenberg form. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C M (input) INTEGER -C The actual input dimension, i.e. the number of columns of -C the matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A to be transformed. -C On exit, the leading N-by-N part of this array contains -C the transformed state transition matrix U' * A * U. -C The annihilated elements are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B to be transformed. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix U' * B. -C The annihilated elements are set to zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, if JOBU = 'U', then the leading N-by-N part of -C this array must contain a given matrix U (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix U and the state-space transformation -C matrix which reduces the given pair to controller -C Hessenberg form. -C On exit, if JOBU = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated unitary -C similarity transformations which reduces the given pair -C to controller Hessenberg form. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. If JOBU = 'U' or -C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N,M-1)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a unitary state-space transformation U, which -C reduces the pair (B,A) to one of the following controller -C Hessenberg forms: -C -C |* . . . *|* . . . . . . *| -C | . .|. .| -C | . .|. .| -C | . .|. .| -C [U'B|U'AU] = | *|. .| N -C | |* .| -C | | . .| -C | | . .| -C | | . .| -C | | * . . *| -C M N -C -C if UPLO = 'U', or -C -C |* . . * | | -C |. . | | -C |. . | | -C |. . | | -C [U'AU|U'B] = |. *| | N -C |. .|* | -C |. .|. . | -C |. .|. . | -C |. .|. . | -C |* . . . . . . *|* . . . *| -C N M -C if UPLO = 'L'. -C -C IF M >= N, then the matrix U'B is trapezoidal and U'AU is full. -C -C REFERENCES -C -C [1] Van Dooren, P. and Verhaegen, M.H.G. -C On the use of unitary state-space transformations. -C In : Contemporary Mathematics on Linear Algebra and its Role -C in Systems Theory, 47, AMS, Providence, 1985. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + M) x N**2) operations and is -C backward stable (see [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01AD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C February 1997. -C -C KEYWORDS -C -C Controllability, controller Hessenberg form, orthogonal -C transformation, unitary transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBU, UPLO - INTEGER INFO, LDA, LDB, LDU, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*) -C .. Local Scalars .. - LOGICAL LJOBA, LJOBI, LUPLO - INTEGER II, J, M1, N1, NJ, PAR1, PAR2, PAR3, PAR4, PAR5, - $ PAR6 - DOUBLE PRECISION DZ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, DLASET, SLCT_DLATZM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LJOBI = LSAME( JOBU, 'I' ) - LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. - $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'TB01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -C - M1 = M + 1 - N1 = N - 1 -C - IF ( LJOBI ) THEN -C -C Initialize U to the identity matrix. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) - END IF -C -C Perform transformations involving both B and A. -C - DO 20 J = 1, MIN( M, N1 ) - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = J - PAR2 = J - PAR3 = J + 1 - PAR4 = M - PAR5 = N - ELSE - PAR1 = M - J + 1 - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = M - J - PAR5 = NJ - END IF -C - CALL DLARFG( NJ+1, B(PAR2,PAR1), B(PAR3,PAR1), 1, DZ ) -C -C Update A. -C - CALL SLCT_DLATZM( 'Left', NJ+1, N, B(PAR3,PAR1), 1, DZ, - $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) - CALL SLCT_DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, - $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL SLCT_DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - IF ( J.NE.M ) THEN -C -C Update B -C - CALL SLCT_DLATZM( 'Left', NJ+1, PAR4-PAR3+1, B(PAR3,PAR1), - $ 1, DZ, - $ B(PAR2,PAR3), B(PAR3,PAR3), LDB, DWORK ) - END IF -C - DO 10 II = PAR3, PAR5 - B(II,PAR1) = ZERO - 10 CONTINUE -C - 20 CONTINUE -C - DO 40 J = M1, N1 -C -C Perform next transformations only involving A. -C - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = J - M - PAR2 = J - PAR3 = J + 1 - PAR4 = N - PAR5 = J - M + 1 - PAR6 = N - ELSE - PAR1 = N + M1 - J - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = NJ - PAR5 = 1 - PAR6 = N + M - J - END IF -C - CALL DLARFG( NJ+1, A(PAR2,PAR1), A(PAR3,PAR1), 1, DZ ) -C -C Update A. -C - CALL SLCT_DLATZM( 'Left', NJ+1, PAR6-PAR5+1, A(PAR3,PAR1), - $ 1, DZ, - $ A(PAR2,PAR5), A(PAR3,PAR5), LDA, DWORK ) - CALL SLCT_DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, - $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL SLCT_DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - DO 30 II = PAR3, PAR4 - A(II,PAR1) = ZERO - 30 CONTINUE -C - 40 CONTINUE -C - RETURN -C *** Last line of TB01MD *** - END diff --git a/slycot/src/TB01ND.f b/slycot/src/TB01ND.f deleted file mode 100644 index 4bd4fbad..00000000 --- a/slycot/src/TB01ND.f +++ /dev/null @@ -1,352 +0,0 @@ - SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, - $ DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the pair (A,C) to lower or upper observer Hessenberg -C form using (and optionally accumulating) unitary state-space -C transformations. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBU CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix U the unitary state-space transformations for -C reducing the system, as follows: -C = 'N': Do not form U; -C = 'I': U is initialized to the unit matrix and the -C unitary transformation matrix U is returned; -C = 'U': The given matrix U is updated by the unitary -C transformations used in the reduction. -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes the pair (A,C) to be -C reduced to upper or lower observer Hessenberg form as -C follows: -C = 'U': Upper observer Hessenberg form; -C = 'L': Lower observer Hessenberg form. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The actual state dimension, i.e. the order of the -C matrix A. N >= 0. -C -C P (input) INTEGER -C The actual output dimension, i.e. the number of rows of -C the matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A to be transformed. -C On exit, the leading N-by-N part of this array contains -C the transformed state transition matrix U' * A * U. -C The annihilated elements are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C to be transformed. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C The annihilated elements are set to zero. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) -C On entry, if JOBU = 'U', then the leading N-by-N part of -C this array must contain a given matrix U (e.g. from a -C previous call to another SLICOT routine), and on exit, the -C leading N-by-N part of this array contains the product of -C the input matrix U and the state-space transformation -C matrix which reduces the given pair to observer Hessenberg -C form. -C On exit, if JOBU = 'I', then the leading N-by-N part of -C this array contains the matrix of accumulated unitary -C similarity transformations which reduces the given pair -C to observer Hessenberg form. -C If JOBU = 'N', the array U is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDU = 1 and -C declare this array to be U(1,1) in the calling program). -C -C LDU INTEGER -C The leading dimension of array U. If JOBU = 'U' or -C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (MAX(N,P-1)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a unitary state-space transformation U, which -C reduces the pair (A,C) to one of the following observer Hessenberg -C forms: -C -C N -C |* . . . . . . *| -C |. .| -C |. .| -C |. .| N -C |* .| -C |U'AU| | . .| -C |----| = | . .| -C |CU | | * . . . *| -C ------------------- -C | * . . *| -C | . .| P -C | . .| -C | *| -C -C if UPLO = 'U', or -C -C N -C |* | -C |. . | -C |. . | P -C |* . . * | -C |CU | ------------------- -C |----| = |* . . . * | -C |U'AU| |. . | -C |. . | -C |. *| -C |. .| N -C |. .| -C |. .| -C |* . . . . . . *| -C -C if UPLO = 'L'. -C -C If P >= N, then the matrix CU is trapezoidal and U'AU is full. -C -C REFERENCES -C -C [1] Van Dooren, P. and Verhaegen, M.H.G. -C On the use of unitary state-space transformations. -C In : Contemporary Mathematics on Linear Algebra and its Role -C in Systems Theory, 47, AMS, Providence, 1985. -C -C NUMERICAL ASPECTS -C -C The algorithm requires O((N + P) x N**2) operations and is -C backward stable (see [1]). -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01BD by M. Vanbegin, and -C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. -C -C REVISIONS -C -C February 1997. -C -C KEYWORDS -C -C Controllability, observer Hessenberg form, orthogonal -C transformation, unitary transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDC, LDU, N, P - CHARACTER JOBU, UPLO -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), C(LDC,*), DWORK(*), U(LDU,*) -C .. Local Scalars .. - LOGICAL LJOBA, LJOBI, LUPLO - INTEGER II, J, N1, NJ, P1, PAR1, PAR2, PAR3, PAR4, PAR5, - $ PAR6 - DOUBLE PRECISION DZ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLARFG, DLASET, SLCT_DLATZM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LJOBI = LSAME( JOBU, 'I' ) - LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. - $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'TB01ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. P.EQ.0 ) - $ RETURN -C - P1 = P + 1 - N1 = N - 1 -C - IF ( LJOBI ) THEN -C -C Initialize U to the identity matrix. -C - CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) - END IF -C -C Perform transformations involving both C and A. -C - DO 20 J = 1, MIN( P, N1 ) - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = P - J + 1 - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = P - J - PAR5 = NJ - ELSE - PAR1 = J - PAR2 = J - PAR3 = J + 1 - PAR4 = P - PAR5 = N - END IF -C - CALL DLARFG( NJ+1, C(PAR1,PAR2), C(PAR1,PAR3), LDC, DZ ) -C -C Update A. -C - CALL SLCT_DLATZM( 'Left', NJ+1, N, C(PAR1,PAR3), LDC, DZ, - $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) - CALL SLCT_DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, - $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL SLCT_DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - IF ( J.NE.P ) THEN -C -C Update C. -C - CALL SLCT_DLATZM( 'Right', PAR4-PAR3+1, NJ+1, - $ C(PAR1,PAR3), LDC, - $ DZ, C(PAR3,PAR2), C(PAR3,PAR3), LDC, DWORK ) - END IF -C - DO 10 II = PAR3, PAR5 - C(PAR1,II) = ZERO - 10 CONTINUE -C - 20 CONTINUE -C - DO 40 J = P1, N1 -C -C Perform next transformations only involving A. -C - NJ = N - J - IF ( LUPLO ) THEN - PAR1 = N + P1 - J - PAR2 = NJ + 1 - PAR3 = 1 - PAR4 = NJ - PAR5 = 1 - PAR6 = N + P - J - ELSE - PAR1 = J - P - PAR2 = J - PAR3 = J + 1 - PAR4 = N - PAR5 = J - P + 1 - PAR6 = N - END IF -C - IF ( NJ.GT.0 ) THEN -C - CALL DLARFG( NJ+1, A(PAR1,PAR2), A(PAR1,PAR3), LDA, DZ ) -C -C Update A. -C - CALL SLCT_DLATZM( 'Left', NJ+1, N, A(PAR1,PAR3), LDA, DZ, - $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) - CALL SLCT_DLATZM( 'Right', PAR6-PAR5+1, NJ+1, A(PAR1,PAR3), - $ LDA, - $ DZ, A(PAR5,PAR2), A(PAR5,PAR3), LDA, DWORK ) -C - IF ( LJOBA ) THEN -C -C Update U. -C - CALL SLCT_DLATZM( 'Right', N, NJ+1, A(PAR1,PAR3), - $ LDA, DZ, - $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) - END IF -C - DO 30 II = PAR3, PAR4 - A(PAR1,II) = ZERO - 30 CONTINUE -C - END IF -C - 40 CONTINUE -C - RETURN -C *** Last line of TB01ND *** - END diff --git a/slycot/src/TB01PD.f b/slycot/src/TB01PD.f deleted file mode 100644 index c1c9594b..00000000 --- a/slycot/src/TB01PD.f +++ /dev/null @@ -1,352 +0,0 @@ - SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, - $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a reduced (controllable, observable, or minimal) state- -C space representation (Ar,Br,Cr) for any original state-space -C representation (A,B,C). The matrix Ar is in upper block -C Hessenberg form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to remove the -C uncontrollable and/or unobservable parts as follows: -C = 'M': Remove both the uncontrollable and unobservable -C parts to get a minimal state-space representation; -C = 'C': Remove the uncontrollable part only to get a -C controllable state-space representation; -C = 'O': Remove the unobservable part only to get an -C observable state-space representation. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily balance -C the triplet (A,B,C) as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, i.e. -C the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the upper block Hessenberg state dynamics matrix Ar of a -C minimal, controllable, or observable realization for the -C original system, depending on the value of JOB, JOB = 'M', -C JOB = 'C', or JOB = 'O', respectively. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), -C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B; if JOB = 'M', -C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) -C part is used as internal workspace. -C On exit, the leading NR-by-M part of this array contains -C the transformed input/state matrix Br of a minimal, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'M', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'C', only the first IWORK(1) rows of B are -C nonzero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C; if JOB = 'M', -C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N -C part is used as internal workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix Cr of a minimal, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'M', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns -C (in the first NR columns) of C are nonzero. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C NR (output) INTEGER -C The order of the reduced state-space representation -C (Ar,Br,Cr) of a minimal, controllable, or observable -C realization for the original system, depending on -C JOB = 'M', JOB = 'C', or JOB = 'O'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If JOB = 'M', the matrices A and B are operated on by orthogonal -C similarity transformations (made up of products of Householder -C transformations) so as to produce an upper block Hessenberg matrix -C A1 and a matrix B1 with all but its first rank(B) rows zero; this -C separates out the controllable part of the original system. -C Applying the same algorithm to the dual of this subsystem, -C therefore separates out the controllable and observable (i.e. -C minimal) part of the original system representation, with the -C final Ar upper block Hessenberg (after using pertransposition). -C If JOB = 'C', or JOB = 'O', only the corresponding part of the -C above procedure is applied. -C -C REFERENCES -C -C [1] Van Dooren, P. -C The Generalized Eigenstructure Problem in Linear System -C Theory. (Algorithm 1) -C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C A. Varga, DLR Oberpfaffenhofen, July 1998. -C A. Varga, DLR Oberpfaffenhofen, April 28, 1999. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Hessenberg form, minimal realization, multivariable system, -C orthogonal transformation, state-space model, state-space -C representation. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER LDIZ - PARAMETER ( LDIZ = 1 ) - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOB - INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) -C .. Local Scalars .. - LOGICAL LEQUIL, LNJOBC, LNJOBO - INTEGER I, INDCON, ITAU, IZ, JWORK, KL, MAXMP, NCONT, - $ WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, TB01ID, TB01UD, TB01XD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - MAXMP = MAX( M, P ) - LNJOBC = .NOT.LSAME( JOB, 'C' ) - LNJOBO = .NOT.LSAME( JOB, 'O' ) - LEQUIL = LSAME( EQUIL, 'S' ) -C -C Test the input scalar arguments. -C - IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.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( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ) ) ) THEN - INFO = -16 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 .OR. ( LNJOBC .AND. MIN( N, P ).EQ.0 ) .OR. - $ ( LNJOBO .AND. MIN( N, M ).EQ.0 ) ) THEN - NR = 0 -C - DO 5 I = 1, N - IWORK(I) = 0 - 5 CONTINUE -C - DWORK(1) = ONE - RETURN - END IF -C -C If required, balance the triplet (A,B,C) (default MAXRED). -C Workspace: need N. -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the code, -C as well as the preferred amount for good performance.) -C - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, INFO ) - WRKOPT = N - ELSE - WRKOPT = 1 - END IF -C - IZ = 1 - ITAU = 1 - JWORK = ITAU + N - IF ( LNJOBO ) THEN -C -C Separate out controllable subsystem (of order NCONT): -C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. -C -C Workspace: need N + MAX(N, 3*M, P). -C prefer larger. -C - CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT, - $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 - ELSE - NCONT = N - END IF -C - IF ( LNJOBC ) THEN -C -C Separate out the observable subsystem (of order NR): -C Form the dual of the subsystem of order NCONT (which is -C controllable, if JOB = 'M'), leaving rest as it is. -C - CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK, - $ 1, INFO ) -C -C And separate out the controllable part of this dual subsystem. -C -C Workspace: need NCONT + MAX(NCONT, 3*P, M). -C prefer larger. -C - CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR, - $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Transpose and reorder (to get a block upper Hessenberg -C matrix A), giving, for JOB = 'M', the controllable and -C observable (i.e., minimal) part of original system. -C - IF( INDCON.GT.0 ) THEN - KL = IWORK(1) - 1 - IF ( INDCON.GE.2 ) - $ KL = KL + IWORK(2) - ELSE - KL = 0 - END IF - CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), A, LDA, - $ B, LDB, C, LDC, DWORK, 1, INFO ) - ELSE - NR = NCONT - END IF -C -C Annihilate the trailing components of IWORK(1:N). -C - DO 10 I = INDCON + 1, N - IWORK(I) = 0 - 10 CONTINUE -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of TB01PD *** - END diff --git a/slycot/src/TB01TD.f b/slycot/src/TB01TD.f deleted file mode 100644 index 8f2fc650..00000000 --- a/slycot/src/TB01TD.f +++ /dev/null @@ -1,308 +0,0 @@ - SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW, - $ IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce a given state-space representation (A,B,C,D) to -C balanced form by means of state permutations and state, input and -C output scalings. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the original state dynamics matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the balanced state dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-M part of this array contains -C the balanced input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the balanced state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) -C On entry, the leading P-by-M part of this array must -C contain the original direct transmission matrix D. -C On exit, the leading P-by-M part of this array contains -C the scaled direct transmission matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C LOW (output) INTEGER -C The index of the lower end of the balanced submatrix of A. -C -C IGH (output) INTEGER -C The index of the upper end of the balanced submatrix of A. -C -C SCSTAT (output) DOUBLE PRECISION array, dimension (N) -C This array contains the information defining the -C similarity transformations used to permute and balance -C the state dynamics matrix A, as returned from the LAPACK -C library routine DGEBAL. -C -C SCIN (output) DOUBLE PRECISION array, dimension (M) -C Contains the scalars used to scale the system inputs so -C that the columns of the final matrix B have norms roughly -C equal to the column sums of the balanced matrix A -C (see FURTHER COMMENTS). -C The j-th input of the balanced state-space representation -C is SCIN(j)*(j-th column of the permuted and balanced -C input/state matrix B). -C -C SCOUT (output) DOUBLE PRECISION array, dimension (P) -C Contains the scalars used to scale the system outputs so -C that the rows of the final matrix C have norms roughly -C equal to the row sum of the balanced matrix A. -C The i-th output of the balanced state-space representation -C is SCOUT(i)*(i-th row of the permuted and balanced -C state/ouput matrix C). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Similarity transformations are used to permute the system states -C and balance the corresponding row and column sum norms of a -C submatrix of the state dynamics matrix A. These operations are -C also applied to the input/state matrix B and the system inputs -C are then scaled (see parameter SCIN) so that the columns of the -C final matrix B have norms roughly equal to the column sum norm of -C the balanced matrix A (see FURTHER COMMENTS). -C The above operations are also applied to the matrix C, and the -C system outputs are then scaled (see parameter SCOUT) so that the -C rows of the final matrix C have norms roughly equal to the row sum -C norm of the balanced matrix A (see FURTHER COMMENTS). -C Finally, the (I,J)-th element of the direct transmission matrix D -C is scaled as -C D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P -C and J = 1,2,...,M. -C -C Scaling performed to balance the row/column sum norms is by -C integer powers of the machine base so as to avoid introducing -C rounding errors. -C -C REFERENCES -C -C [1] Wilkinson, J.H. and Reinsch, C. -C Handbook for Automatic Computation, (Vol II, Linear Algebra). -C Springer-Verlag, 1971, (contribution II/11). -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C The columns (rows) of the final matrix B (matrix C) have norms -C 'roughly' equal to the column (row) sum norm of the balanced -C matrix A, i.e. -C size/BASE < abssum <= size -C where -C BASE = the base of the arithmetic used on the computer, which -C can be obtained from the LAPACK Library routine -C DLAMCH; -C -C size = column or row sum norm of the balanced matrix A; -C abssum = column sum norm of the balanced matrix B or row sum -C norm of the balanced matrix C. -C -C The routine is BASE dependent. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01HD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, October 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balanced form, orthogonal transformation, similarity -C transformation, state-space model, state-space representation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IGH, INFO, LDA, LDB, LDC, LDD, LOW, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), SCIN(*), SCOUT(*), SCSTAT(*) -C .. Local Scalars .. - INTEGER I, J, K, KNEW, KOLD - DOUBLE PRECISION ACNORM, ARNORM, SCALE -C .. External Functions .. - DOUBLE PRECISION DLANGE - EXTERNAL DLANGE -C .. External Subroutines .. - EXTERNAL DGEBAL, DSCAL, DSWAP, TB01TY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01TD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - LOW = 1 - IGH = N - RETURN - END IF -C -C Permute states, and balance a submatrix of A. -C - CALL DGEBAL( 'Both', N, A, LDA, LOW, IGH, SCSTAT, INFO ) -C -C Use the information in SCSTAT on state scalings and reorderings -C to transform B and C. -C - DO 10 K = 1, N - KOLD = N + 1 - K ! RvP, rabraker, slycot #11 - IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN - IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD - KNEW = INT( SCSTAT(KOLD) ) - IF ( KNEW.NE.KOLD ) THEN -C -C Exchange rows KOLD and KNEW of B. -C - CALL DSWAP( M, B(KOLD,1), LDB, B(KNEW,1), LDB ) -C -C Exchange columns KOLD and KNEW of C. -C - CALL DSWAP( P, C(1,KOLD), 1, C(1,KNEW), 1 ) - END IF - END IF - 10 CONTINUE -C - IF ( IGH.NE.LOW ) THEN -C - DO 20 K = LOW, IGH - SCALE = SCSTAT(K) -C -C Scale the K-th row of permuted B. -C - CALL DSCAL( M, ONE/SCALE, B(K,1), LDB ) -C -C Scale the K-th column of permuted C. -C - CALL DSCAL( P, SCALE, C(1,K), 1 ) - 20 CONTINUE -C - END IF -C -C Calculate the column and row sum norms of A. -C - ACNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) - ARNORM = DLANGE( 'I-norm', N, N, A, LDA, DWORK ) -C -C Scale the columns of B (i.e. inputs) to have norms roughly ACNORM. -C - CALL TB01TY( 1, 0, 0, N, M, ACNORM, B, LDB, SCIN ) -C -C Scale the rows of C (i.e. outputs) to have norms roughly ARNORM. -C - CALL TB01TY( 0, 0, 0, P, N, ARNORM, C, LDC, SCOUT ) -C -C Finally, apply these input and output scalings to D and set SCIN. -C - DO 40 J = 1, M - SCALE = SCIN(J) -C - DO 30 I = 1, P - D(I,J) = D(I,J)*( SCALE*SCOUT(I) ) - 30 CONTINUE -C - SCIN(J) = ONE/SCALE - 40 CONTINUE -C - RETURN -C *** Last line of TB01TD *** - END diff --git a/slycot/src/TB01TY.f b/slycot/src/TB01TY.f deleted file mode 100644 index 6dada6fa..00000000 --- a/slycot/src/TB01TY.f +++ /dev/null @@ -1,136 +0,0 @@ - SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX, - $ BVECT ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Balances the rows (MODE .EQ. 0) or columns (MODE .NE. 0) of the -C (NROW x NCOL) block of the matrix X with offset (IOFF,JOFF), i.e. -C with first (top left) element (IOFF + 1,JOFF + 1). Each non- -C zero row (column) is balanced in the sense that it is multiplied -C by that integer power of the base of the machine floating-point -C representation for which the sum of the absolute values of its -C entries (i.e. its 1-norm) satisfies -C -C (SIZE / BASE) .LT. ABSSUM .LE. SIZE -C -C for SIZE as input. (Note that this form of scaling does not -C introduce any rounding errors.) The vector BVECT then contains -C the appropriate scale factors in rows (IOFF + 1)...(IOFF + NROW) -C (columns (JOFF + 1)...(JOFF + NCOL) ). In particular, if the -C I-th row (J-th column) of the block is 'numerically' non-zero -C with 1-norm given by BASE**(-EXPT) for some real EXPT, then the -C desired scale factor (returned as element IOFF + I (JOFF + J) of -C BVECT) is BASE**IEXPT, where IEXPT is the largest integer .LE. -C EXPT: this integer is precisely the truncation INT(EXPT) except -C for negative non-integer EXPT, in which case this value is too -C high by 1 and so must be adjusted accordingly. Finally, note -C that the element of BVECT corresponding to a 'numerically' zero -C row (column) is simply set equal to 1.0. -C -C For efficiency, no tests of the input scalar parameters are -C performed. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER IOFF, JOFF, LDX, MODE, NCOL, NROW - DOUBLE PRECISION SIZE -C .. Array Arguments .. - DOUBLE PRECISION BVECT(*), X(LDX,*) -C .. Local Scalars .. - DOUBLE PRECISION ABSSUM, DIV, EPS, EXPT, SCALE, TEST - INTEGER BASE, I, IEXPT, J -C .. External Functions .. - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH -C .. External Subroutines .. - EXTERNAL DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG -C .. Executable Statements .. -C - BASE = DLAMCH( 'Base' ) - EPS = DLAMCH( 'Epsilon' ) -C - DIV = ONE/LOG( DBLE( BASE ) ) - IF ( MODE.NE.0 ) THEN -C -C Balance one column at a time using its column-sum norm. -C - DO 10 J = JOFF + 1, JOFF + NCOL - ABSSUM = DASUM( NROW, X(IOFF+1,J), 1 )/ABS( SIZE ) - TEST = ABSSUM/DBLE( NROW ) - IF ( TEST.GT.EPS ) THEN -C -C Non-zero column: calculate (and apply) correct scale -C factor. -C - EXPT = -DIV*LOG( ABSSUM ) - IEXPT = INT( EXPT ) - IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) - $ IEXPT = IEXPT - 1 - SCALE = DBLE( BASE )**IEXPT - BVECT(J) = SCALE - CALL DSCAL( NROW, SCALE, X(IOFF+1,J), 1 ) - ELSE -C -C 'Numerically' zero column: do not rescale. -C - BVECT(J) = ONE - END IF - 10 CONTINUE -C - ELSE -C -C Balance one row at a time using its row-sum norm. -C - DO 20 I = IOFF + 1, IOFF + NROW - ABSSUM = DASUM( NCOL, X(I,JOFF+1), LDX )/ABS( SIZE ) - TEST = ABSSUM/DBLE( NCOL ) - IF ( TEST.GT.EPS ) THEN -C -C Non-zero row: calculate (and apply) correct scale factor. -C - EXPT = -DIV*LOG( ABSSUM ) - IEXPT = INT( EXPT ) - IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) - $ IEXPT = IEXPT - 1 -C - SCALE = DBLE( BASE )**IEXPT - BVECT(I) = SCALE - CALL DSCAL( NCOL, SCALE, X(I,JOFF+1), LDX ) - ELSE -C -C 'Numerically' zero row: do not rescale. -C - BVECT(I) = ONE - END IF - 20 CONTINUE -C - END IF -C - RETURN -C *** Last line of TB01TY *** - END diff --git a/slycot/src/TB01UD.f b/slycot/src/TB01UD.f deleted file mode 100644 index 19178014..00000000 --- a/slycot/src/TB01UD.f +++ /dev/null @@ -1,491 +0,0 @@ - SUBROUTINE TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, NCONT, - $ INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C multi-input system -C -C dX/dt = A * X + B * U, -C Y = C * X, -C -C where A, B, and C are N-by-N, N-by-M, and P-by-N matrices, -C respectively, and A and B are reduced by this routine to -C orthogonal canonical form using (and optionally accumulating) -C orthogonal similarity transformations, which are also applied -C to C. Specifically, the system (A, B, C) is reduced to the -C triplet (Ac, Bc, Cc), where Ac = Z' * A * Z, Bc = Z' * B, -C Cc = C * Z, with -C -C [ Acont * ] [ Bcont ] -C Ac = [ ], Bc = [ ], -C [ 0 Auncont ] [ 0 ] -C -C and -C -C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] -C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] -C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] -C Acont = [ . . . . . . . ], Bc = [ . ], -C [ . . . . . . ] [ . ] -C [ . . . . . ] [ . ] -C [ 0 0 . . . Ap,p-1 App ] [ 0 ] -C -C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and -C p is the controllability index of the pair. The size of the -C block Auncont is equal to the dimension of the uncontrollable -C subspace of the pair (A, B). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT part contains the -C upper block Hessenberg state dynamics matrix Acont in Ac, -C given by Z' * A * Z, of a controllable realization for -C the original system. The elements below the first block- -C subdiagonal are set to zero. The leading N-by-N part -C contains the matrix Ac. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading NCONT-by-M part of this array -C contains the transformed input matrix Bcont in Bc, given -C by Z' * B, with all elements but the first block set to -C zero. The leading N-by-M part contains the matrix Bc. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix Cc, given by C * Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C INDCON (output) INTEGER -C The controllability index of the controllable part of the -C system representation. -C -C NBLK (output) INTEGER array, dimension (N) -C The leading INDCON elements of this array contain the -C the orders of the diagonal blocks of Acont. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this -C array contains the matrix of accumulated orthogonal -C similarity transformations which reduces the given system -C to orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N, 3*M, P). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Matrix B is first QR-decomposed and the appropriate orthogonal -C similarity transformation applied to the matrix A. Leaving the -C first rank(B) states unchanged, the remaining lower left block -C of A is then QR-decomposed and the new orthogonal matrix, Q1, -C is also applied to the right of A to complete the similarity -C transformation. By continuing in this manner, a completely -C controllable state-space pair (Acont, Bcont) is found for the -C given (A, B), where Acont is upper block Hessenberg with each -C subdiagonal block of full row rank, and Bcont is zero apart from -C its (independent) first rank(B) rows. -C All orthogonal transformations determined in this process are also -C applied to the matrix C, from the right. -C NOTE that the system controllability indices are easily -C calculated from the dimensions of the blocks of Acont. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Paige, C.C. -C Properties of numerical algorithms related to computing -C controllablity. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and -C Postlethwaite, I. -C Optimal Pole Assignment Design of Linear Multi-Input Systems. -C Leicester University, Report 99-11, May 1996. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C FURTHER COMMENTS -C -C If the system matrices A and B are badly scaled, it would be -C useful to scale them with SLICOT routine TB01ID, before calling -C the routine. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Nov. 2003. -C A. Varga, DLR Oberpfaffenhofen, March 2002, Nov. 2003. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N, - $ NCONT, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*), - $ Z(LDZ,*) - INTEGER IWORK(*), NBLK(*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, - $ WRKOPT - DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 - EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, - $ MB01PD, MB03OY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. - $ LJOBZ .AND. LDZ.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDWORK.LT.MAX( 1, N, 3*M, P ) ) THEN - INFO = -20 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01UD', -INFO ) - RETURN - END IF -C - NCONT = 0 - INDCON = 0 -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) -C -C Quick return if possible. -C - IF ( MIN( N, M ).EQ.0 .OR. BNORM.EQ.ZERO ) THEN - IF( N.GT.0 ) THEN - IF ( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - ELSE IF ( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - END IF - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) - CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO ) -C -C Compute the Frobenius norm of [ B A ] (used for rank estimation). -C - FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), - $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) - END IF -C - IF ( FNRM.LT.TOLDEF ) - $ FNRM = ONE -C - WRKOPT = 1 - NI = 0 - ITAU = 1 - NCRT = N - MCRT = M - IQR = 1 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - 10 CONTINUE -C -C Rank-revealing QR decomposition with column pivoting. -C The calculation is performed in NCRT rows of B starting from -C the row IQR (initialized to 1 and then set to rank(B)+1). -C Workspace: 3*MCRT. -C - CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, - $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) -C - IF ( RANK.NE.0 ) THEN - NJ = NI - NI = NCONT - NCONT = NCONT + RANK - INDCON = INDCON + 1 - NBLK(INDCON) = RANK -C -C Premultiply and postmultiply the appropriate block row -C and block column of A by Q' and Q, respectively. -C Workspace: need NCRT; -C prefer NCRT*NB. -C - CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Workspace: need N; -C prefer N*NB. -C - CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C Postmultiply the appropriate block column of C by Q. -C Workspace: need P; -C prefer P*NB. -C - CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK, - $ B(IQR,1), LDB, TAU(ITAU), C(1,NI+1), LDC, - $ DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) -C -C If required, save transformations. -C - IF ( LJOBZ.AND.NCRT.GT.1 ) THEN - CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), - $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) - END IF -C -C Zero the subdiagonal elements of the current matrix. -C - IF ( RANK.GT.1 ) - $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), - $ LDB ) -C -C Backward permutation of the columns of B or A. -C - IF ( INDCON.EQ.1 ) THEN - CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) - IQR = RANK + 1 - ELSE - DO 20 J = 1, MCRT - CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), - $ 1 ) - 20 CONTINUE - END IF -C - ITAU = ITAU + RANK - IF ( RANK.NE.NCRT ) THEN - MCRT = RANK - NCRT = NCRT - RANK - CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, - $ B(IQR,1), LDB ) - CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, - $ A(NCONT+1,NI+1), LDA ) - GO TO 10 - END IF - END IF -C -C If required, accumulate transformations. -C Workspace: need N; prefer N*NB. -C - IF ( LJOBI ) THEN - CALL DORGQR( N, N, ITAU-1, Z, LDZ, TAU, DWORK, - $ LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) - END IF -C -C Annihilate the trailing blocks of B. -C - IF( IQR.LE.N ) - $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) -C -C Annihilate the trailing elements of TAU, if JOBZ = 'F'. -C - IF ( LJOBF ) THEN - DO 30 J = ITAU, N - TAU(J) = ZERO - 30 CONTINUE - END IF -C -C Undo scaling of A and B. -C - IF ( INDCON.LT.N ) THEN - NBL = INDCON + 1 - NBLK(NBL) = N - NCONT - ELSE - NBL = 0 - END IF - CALL MB01PD( 'U', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'U', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, LDB, - $ INFO ) -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of TB01UD *** - END diff --git a/slycot/src/TB01VD.f b/slycot/src/TB01VD.f deleted file mode 100644 index 26cd1c7c..00000000 --- a/slycot/src/TB01VD.f +++ /dev/null @@ -1,503 +0,0 @@ - SUBROUTINE TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD, - $ X0, THETA, LTHETA, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To convert the linear discrete-time system given as (A, B, C, D), -C with initial state x0, into the output normal form [1], with -C parameter vector THETA. The matrix A is assumed to be stable. -C The matrices A, B, C, D and the vector x0 are converted, so that -C on exit they correspond to the system defined by THETA. -C -C ARGUMENTS -C -C Mode Parameters -C -C APPLY CHARACTER*1 -C Specifies whether or not the parameter vector should be -C transformed using a bijective mapping, as follows: -C = 'A' : apply the bijective mapping to the N vectors in -C THETA corresponding to the matrices A and C; -C = 'N' : do not apply the bijective mapping. -C The transformation performed when APPLY = 'A' allows -C to get rid of the constraints norm(THETAi) < 1, i = 1:N. -C A call of the SLICOT Library routine TB01VY associated to -C a call of TB01VD must use the same value of APPLY. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A, assumed to be stable. -C On exit, the leading N-by-N part of this array contains -C the transformed system state matrix corresponding to the -C output normal form with parameter vector THETA. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed system input matrix corresponding to the -C output normal form with parameter vector THETA. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading L-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading L-by-N part of this array contains -C the transformed system output matrix corresponding to the -C output normal form with parameter vector THETA. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,L). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading L-by-M part of this array must contain the -C system input/output matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,L). -C -C X0 (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state of the -C system, x0. -C On exit, this array contains the transformed initial state -C of the system, corresponding to the output normal form -C with parameter vector THETA. -C -C THETA (output) DOUBLE PRECISION array, dimension (LTHETA) -C The leading N*(L+M+1)+L*M part of this array contains the -C parameter vector that defines a system (A, B, C, D, x0) -C which is equivalent up to a similarity transformation to -C the system given on entry. The parameters are: -C -C THETA(1:N*L) : parameters for A, C; -C THETA(N*L+1:N*(L+M)) : parameters for B; -C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; -C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. -C -C LTHETA INTEGER -C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*N*L + N*L + N, -C N*N + MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), -C N*M)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the Lyapunov equation A'*Q*A - Q = -scale^2*C'*C -C could only be solved with scale = 0; -C = 2: if matrix A is not discrete-time stable; -C = 3: if the QR algorithm failed to converge for -C matrix A. -C -C METHOD -C -C The matrices A and C are converted to output normal form. -C First, the Lyapunov equation -C -C A'*Q*A - Q = -scale^2*C'*C, -C -C is solved in the Cholesky factor T, T'*T = Q, and then T is used -C to get the transformation matrix. -C -C The matrix B and the initial state x0 are transformed accordingly. -C -C Then, the QR factorization of the transposed observability matrix -C is computed, and the matrix Q is used to further transform the -C system matrices. The parameters characterizing A and C are finally -C obtained by applying a set of N orthogonal transformations. -C -C REFERENCES -C -C [1] Peeters, R.L.M., Hanzon, B., and Olivi, M. -C Balanced realizations of discrete-time stable all-pass -C systems and the tangential Schur algorithm. -C Proceedings of the European Control Conference, -C 31 August - 3 September 1999, Karlsruhe, Germany. -C Session CP-6, Discrete-time Systems, 1999. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Feb. 2002, Feb. 2004. -C -C KEYWORDS -C -C Asymptotically stable, Lyapunov equation, output normal form, -C parameter estimation, similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER APPLY - INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, - $ N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), THETA(*), X0(*) -C .. Local Scalars .. - DOUBLE PRECISION PIBY2, RI, SCALE, TI - INTEGER CA, I, IA, IN, IQ, IR, IT, ITAU, IU, IWI, IWR, - $ J, JWORK, K, LDCA, LDT, WRKOPT - LOGICAL LAPPLY -C .. External Functions .. - EXTERNAL DNRM2, LSAME - DOUBLE PRECISION DNRM2 - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DGER, - $ DLACPY, DLASET, DORMQR, DSCAL, DTRMM, DTRMV, - $ DTRSM, MA02AD, SB03OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, INT, MAX, MIN, SQRT, TAN -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - LAPPLY = LSAME( APPLY, 'A' ) -C - INFO = 0 - IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 ) THEN - INFO = -4 - ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN - INFO = -12 - ELSEIF ( LTHETA.LT.( N*( M + L + 1 ) + L*M ) ) THEN - INFO = -15 - ELSEIF ( LDWORK.LT.MAX( 1, N*N*L + N*L + N, N*N + - $ MAX( N*( N + MAX( N, L ) + 6 ) + - $ MIN( N, L ), N*M ) ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01VD', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MAX( N, M, L ).EQ.0 ) THEN - DWORK(1) = ONE - RETURN - ELSE IF ( N.EQ.0 ) THEN - CALL DLACPY( 'Full', L, M, D, LDD, THETA, MAX( 1, L ) ) - DWORK(1) = ONE - RETURN - ELSE IF ( L.EQ.0 ) THEN - CALL DLACPY( 'Full', N, M, B, LDB, THETA, N ) - CALL DCOPY( N, X0, 1, THETA(N*M+1), 1 ) - DWORK(1) = ONE - RETURN - ENDIF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = 1 - PIBY2 = TWO*ATAN( ONE ) -C -C Convert A and C to output normal form. -C First, solve the Lyapunov equation -C A'*Q*A - Q = -scale^2*C'*C, -C in the Cholesky factor T, T'*T = Q, and use T to get the -C transformation matrix. Copy A and C, to preserve them. -C -C Workspace: need N*(2*N + MAX(N,L) + 6) + MIN(N,L). -C prefer larger. -C -C Initialize the indices in the workspace. -C - LDT = MAX( N, L ) - CA = 1 - IA = 1 - IT = IA + N*N - IU = IT + LDT*N - IWR = IU + N*N - IWI = IWR + N -C - JWORK = IWI + N -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IT), LDT ) -C - CALL SB03OD( 'Discrete', 'NotFactored', 'NoTranspose', N, L, - $ DWORK(IA), N, DWORK(IU), N, DWORK(IT), LDT, SCALE, - $ DWORK(IWR), DWORK(IWI), DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - IF ( INFO.NE.0 ) THEN - IF ( INFO.EQ.6 ) THEN - INFO = 3 - ELSE - INFO = 2 - ENDIF - RETURN - ENDIF - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C - IF ( SCALE.EQ.ZERO ) THEN - INFO = 1 - RETURN - ENDIF -C -C Compute A = T*A*T^(-1). -C - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, - $ DWORK(IT), LDT, A, LDA ) -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, - $ DWORK(IT), LDT, A, LDA ) - IF ( M.GT.0 ) THEN -C -C Compute B = (1/scale)*T*B. -C - CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, M, - $ ONE/SCALE, DWORK(IT), LDT, B, LDB ) - ENDIF -C -C Compute x0 = (1/scale)*T*x0. -C - CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(IT), LDT, - $ X0, 1 ) - CALL DSCAL( N, ONE/SCALE, X0, 1 ) -C -C Compute C = scale*C*T^(-1). -C - CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', L, N, - $ SCALE, DWORK(IT), LDT, C, LDC ) -C -C Now, the system has been transformed to the output normal form. -C Build the transposed observability matrix in DWORK(CA) and compute -C its QR factorization. -C - CALL MA02AD( 'Full', L, N, C, LDC, DWORK(CA), N ) -C - DO 10 I = 1, N - 1 - CALL DGEMM( 'Transpose', 'NoTranspose', N, L, N, ONE, A, LDA, - $ DWORK(CA+(I-1)*N*L), N, ZERO, DWORK(CA+I*N*L), N ) - 10 CONTINUE -C -C Compute the QR factorization. -C -C Workspace: need N*N*L + N + L*N. -C prefer N*N*L + N + NB*L*N. -C - ITAU = CA + N*N*L - JWORK = ITAU + N - CALL DGEQRF( N, L*N, DWORK(CA), N, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) -C -C Compute Q such that R has all diagonal elements nonnegative. -C Only the first N*N part of R is needed. Move the details -C of the QR factorization process, to gain memory and efficiency. -C -C Workspace: need 2*N*N + 2*N. -C prefer 2*N*N + N + NB*N. -C - IR = N*N + 1 - IF ( L.NE.2 ) - $ CALL DCOPY( N, DWORK(ITAU), 1, DWORK(IR+N*N), 1 ) - CALL DLACPY( 'Lower', N, N, DWORK(CA), N, DWORK(IR), N ) - ITAU = IR + N*N - JWORK = ITAU + N -C - IQ = 1 - CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IQ), N ) -C - DO 20 I = 1, N - IF ( DWORK(IR+(I-1)*(N+1)).LT.ZERO ) - $ DWORK(IQ+(I-1)*(N+1))= -ONE - 20 CONTINUE -C - CALL DORMQR( 'Left', 'NoTranspose', N, N, N, DWORK(IR), N, - $ DWORK(ITAU), DWORK(IQ), N, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) - JWORK = IR -C -C Now, the transformation matrix Q is in DWORK(IQ). -C -C Compute A = Q'*A*Q. -C - CALL DGEMM( 'Transpose', 'NoTranspose', N, N, N, ONE, DWORK(IQ), - $ N, A, LDA, ZERO, DWORK(JWORK), N ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, - $ DWORK(JWORK), N, DWORK(IQ), N, ZERO, A, LDA ) -C - IF ( M.GT.0 ) THEN -C -C Compute B = Q'*B. -C Workspace: need N*N + N*M. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK(JWORK), N ) - CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, - $ DWORK(IQ), N, DWORK(JWORK), N, ZERO, B, LDB ) - ENDIF -C -C Compute C = C*Q. -C Workspace: need N*N + N*L. -C - CALL DLACPY( 'Full', L, N, C, LDC, DWORK(JWORK), L ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', L, N, N, ONE, - $ DWORK(JWORK), L, DWORK(IQ), N, ZERO, C, LDC ) -C -C Compute x0 = Q'*x0. -C - CALL DCOPY( N, X0, 1, DWORK(JWORK), 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, DWORK(IQ), N, DWORK(JWORK), - $ 1, ZERO, X0, 1 ) -C -C Now, copy C and A into the workspace to make it easier to read out -C the corresponding part of THETA, and to apply the transformations. -C - LDCA = N + L -C - DO 30 I = 1, N - CALL DCOPY( L, C(1,I), 1, DWORK(CA+(I-1)*LDCA), 1 ) - CALL DCOPY( N, A(1,I), 1, DWORK(CA+L+(I-1)*LDCA), 1 ) - 30 CONTINUE -C - JWORK = CA + LDCA*N -C -C The parameters characterizing A and C are extracted in this loop. -C Workspace: need N*(N + L + 1). -C - DO 60 I = 1, N - CALL DCOPY( L, DWORK(CA+1+(N-I)*(LDCA+1)), 1, THETA((I-1)*L+1), - $ 1 ) - RI = DWORK(CA+(N-I)*(LDCA+1)) - TI = DNRM2( L, THETA((I-1)*L+1), 1 ) -C -C Multiply the part of [C; A] which will be currently transformed -C with Ui = [ -THETAi, Si; RI, THETAi' ] from the left, without -C storing Ui. Ui has the size (L+1)-by-(L+1). -C - CALL DGEMV( 'Transpose', L, N, ONE, DWORK(CA+N-I+1), LDCA, - $ THETA((I-1)*L+1), 1, ZERO, DWORK(JWORK), 1 ) -C - IF ( TI.GT.ZERO ) THEN - CALL DGER( L, N, (RI-ONE)/TI/TI, THETA((I-1)*L+1), 1, - $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) - ELSE -C -C The call below is for the limiting case. -C - CALL DGER( L, N, -HALF, THETA((I-1)*L+1), 1, - $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) - ENDIF -C - CALL DGER( L, N, -ONE, THETA((I-1)*L+1), 1, DWORK(CA+N-I), - $ LDCA, DWORK(CA+N-I+1), LDCA ) - CALL DAXPY( N, RI, DWORK(CA+N-I), LDCA, DWORK(JWORK), 1 ) -C -C Move these results to their appropriate locations. -C - DO 50 J = 1, N - IN = CA + N - I + ( J - 1 )*LDCA - DO 40 K = IN + 1, IN + L - DWORK(K-1) = DWORK(K) - 40 CONTINUE - DWORK(IN+L) = DWORK(JWORK+J-1) - 50 CONTINUE -C -C Now, apply the bijective mapping, which allows to get rid -C of the constraint norm(THETAi) < 1. -C - IF ( LAPPLY .AND. TI.NE.ZERO ) - $ CALL DSCAL( L, TAN( TI*PIBY2 )/TI, THETA((I-1)*L+1), 1 ) -C - 60 CONTINUE -C - IF ( M.GT.0 ) THEN -C -C The next part of THETA is B. -C - CALL DLACPY( 'Full', N, M, B, LDB, THETA(N*L+1), N ) -C -C Copy the matrix D. -C - CALL DLACPY( 'Full', L, M, D, LDD, THETA(N*(L+M)+1), L ) - ENDIF -C -C Copy the initial state x0. -C - CALL DCOPY( N, X0, 1, THETA(N*(L+M)+L*M+1), 1 ) -C - DWORK(1) = WRKOPT - RETURN -C -C *** Last line of TB01VD *** - END diff --git a/slycot/src/TB01VY.f b/slycot/src/TB01VY.f deleted file mode 100644 index d18361a2..00000000 --- a/slycot/src/TB01VY.f +++ /dev/null @@ -1,317 +0,0 @@ - SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB, - $ C, LDC, D, LDD, X0, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To convert the linear discrete-time system given as its output -C normal form [1], with parameter vector THETA, into the state-space -C representation (A, B, C, D), with the initial state x0. -C -C ARGUMENTS -C -C Mode Parameters -C -C APPLY CHARACTER*1 -C Specifies whether or not the parameter vector should be -C transformed using a bijective mapping, as follows: -C = 'A' : apply the bijective mapping to the N vectors in -C THETA corresponding to the matrices A and C; -C = 'N' : do not apply the bijective mapping. -C The transformation performed when APPLY = 'A' allows -C to get rid of the constraints norm(THETAi) < 1, i = 1:N. -C A call of the SLICOT Library routine TB01VD associated to -C a call of TB01VY must use the same value of APPLY. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C L (input) INTEGER -C The number of system outputs. L >= 0. -C -C THETA (input) DOUBLE PRECISION array, dimension (LTHETA) -C The leading N*(L+M+1)+L*M part of this array must contain -C the parameter vector that defines a system (A, B, C, D), -C with the initial state x0. The parameters are: -C -C THETA(1:N*L) : parameters for A, C; -C THETA(N*L+1:N*(L+M)) : parameters for B; -C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; -C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. -C -C LTHETA INTEGER -C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the system -C state matrix corresponding to the output normal form with -C parameter vector THETA. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array contains the system -C input matrix corresponding to the output normal form with -C parameter vector THETA. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading L-by-N part of this array contains the system -C output matrix corresponding to the output normal form with -C parameter vector THETA. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,L). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading L-by-M part of this array contains the system -C input/output matrix corresponding to the output normal -C form with parameter vector THETA. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,L). -C -C X0 (output) DOUBLE PRECISION array, dimension (N) -C This array contains the initial state of the system, x0, -C corresponding to the output normal form with parameter -C vector THETA. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= N*(N+L+1). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The parameters characterizing A and C are used to build N -C orthogonal transformations, which are then applied to recover -C these matrices. -C -C CONTRIBUTORS -C -C A. Riedel, R. Schneider, Chemnitz University of Technology, -C Oct. 2000, during a stay at University of Twente, NL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, -C Feb. 2002, Feb. 2004. -C -C KEYWORDS -C -C Asymptotically stable, output normal form, parameter estimation, -C similarity transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER APPLY - INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, - $ N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), THETA(*), X0(*) -C .. Local Scalars .. - DOUBLE PRECISION FACTOR, RI, TI, TOBYPI - INTEGER CA, JWORK, I, IN, J, K, LDCA - LOGICAL LAPPLY -C .. External Functions .. - EXTERNAL DNRM2, LSAME - DOUBLE PRECISION DNRM2 - LOGICAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLACPY, DSCAL, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC ATAN, MAX, SQRT -C .. -C .. Executable Statements .. -C -C Check the scalar input parameters. -C - LAPPLY = LSAME( APPLY, 'A' ) -C - INFO = 0 - IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN - INFO = -1 - ELSEIF ( N.LT.0 ) THEN - INFO = -2 - ELSEIF ( M.LT.0 ) THEN - INFO = -3 - ELSEIF ( L.LT.0 ) THEN - INFO = -4 - ELSEIF ( LTHETA.LT.( N*( L + M + 1 ) + L*M ) ) THEN - INFO = -6 - ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN - INFO = -12 - ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN - INFO = -14 - ELSEIF ( LDWORK.LT.N*( N + L + 1 ) ) THEN - INFO = -17 - ENDIF -C -C Return if there are illegal arguments. -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TB01VY', -INFO ) - RETURN - ENDIF -C -C Quick return if possible. -C - IF ( MAX( N, M, L ).EQ.0 ) - $ RETURN -C - IF ( M.GT.0 ) THEN -C -C Copy the matrix B from THETA. -C - CALL DLACPY( 'Full', N, M, THETA(N*L+1), N, B, LDB ) -C -C Copy the matrix D. -C - CALL DLACPY( 'Full', L, M, THETA(N*(L+M)+1), L, D, LDD ) - ENDIF -C - IF ( N.EQ.0 ) THEN - RETURN - ELSE IF ( L.EQ.0 ) THEN - CALL DCOPY( N, THETA(N*M+1), 1, X0, 1 ) - RETURN - END IF -C -C Initialize the indices in the workspace. -C - LDCA = N + L -C - CA = 1 -C - JWORK = CA + N*LDCA - TOBYPI = HALF/ATAN( ONE ) -C -C Generate the matrices C and A from their parameters. -C Start with the block matrix [0; I], where 0 is a block of zeros -C of size L-by-N, and I is the identity matrix of order N. -C - DWORK(CA) = ZERO - CALL DCOPY( N*(L+N), DWORK(CA), 0, DWORK(CA), 1 ) - DWORK(CA+L) = ONE - CALL DCOPY( N, DWORK(CA+L), 0, DWORK(CA+L), LDCA+1 ) -C -C Now, read out THETA(1 : N*L) and perform the transformations -C defined by the parameters in THETA. -C - DO 30 I = N, 1, -1 -C -C Save THETAi in the first column of C and use the copy for -C further processing. -C - CALL DCOPY( L, THETA((I-1)*L+1), 1, C, 1 ) - TI = DNRM2( L, C, 1 ) - IF ( LAPPLY .AND. TI.NE.ZERO ) THEN -C -C Apply the bijective mapping which guarantees that TI < 1. -C - FACTOR = TOBYPI*ATAN( TI )/TI -C -C Scale THETAi and apply the same scaling on TI. -C - CALL DSCAL( L, FACTOR, C, 1 ) - TI = TI*FACTOR - END IF -C -C RI = sqrt( 1 - TI**2 ). -C - RI = SQRT( ( ONE - TI )*( ONE + TI ) ) -C -C Multiply a certain part of DWORK(CA) with Ui' from the left, -C where Ui = [ -THETAi, Si; RI, THETAi' ] is (L+1)-by-(L+1), but -C Ui is not stored. -C - CALL DGEMV( 'Transpose', L, N, -ONE, DWORK(CA+N-I), LDCA, C, 1, - $ ZERO, DWORK(JWORK), 1 ) -C - IF ( TI.GT.ZERO ) THEN - CALL DGER( L, N, (ONE-RI)/TI/TI, C, 1, DWORK(JWORK), 1, - $ DWORK(CA+N-I), LDCA ) - ELSE -C -C The call below is for the limiting case. -C - CALL DGER( L, N, HALF, C, 1, DWORK(JWORK), 1, - $ DWORK(CA+N-I), LDCA ) - ENDIF -C - CALL DGER( L, N, ONE, C, 1, DWORK(CA+N-I+L), LDCA, - $ DWORK(CA+N-I), LDCA ) - CALL DAXPY( N, RI, DWORK(CA+N-I+L), LDCA, DWORK(JWORK), 1 ) -C -C Move these results to their appropriate locations. -C - DO 20 J = 1, N - IN = CA + N - I + ( J - 1 )*LDCA - DO 10 K = IN + L, IN + 1, -1 - DWORK(K) = DWORK(K-1) - 10 CONTINUE - DWORK(IN) = DWORK(JWORK+J-1) - 20 CONTINUE -C - 30 CONTINUE -C -C Now, DWORK(CA) = [C; A]. Copy to C and A. -C - DO 40 I = 1, N - CALL DCOPY( L, DWORK(CA+(I-1)*LDCA), 1, C(1,I), 1 ) - CALL DCOPY( N, DWORK(CA+L+(I-1)*LDCA), 1, A(1,I), 1 ) - 40 CONTINUE -C -C Copy the initial state x0. -C - CALL DCOPY( N, THETA(N*(L+M)+L*M+1), 1, X0, 1 ) -C - RETURN -C -C *** Last line of TB01VY *** - END diff --git a/slycot/src/TB01WD.f b/slycot/src/TB01WD.f deleted file mode 100644 index 36dd0123..00000000 --- a/slycot/src/TB01WD.f +++ /dev/null @@ -1,259 +0,0 @@ - SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, - $ WR, WI, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the system state matrix A to an upper real Schur form -C by using an orthogonal similarity transformation A <-- U'*A*U and -C to apply the transformation to the matrices B and C: B <-- U'*B -C and C <-- C*U. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix U' * A * U in real Schur form. The elements -C below the first subdiagonal are set to zero. -C Note: A matrix is in real Schur form if it is upper -C quasi-triangular with 1-by-1 and 2-by-2 blocks. -C 2-by-2 blocks are standardized in the form -C [ a b ] -C [ c a ] -C where b*c < 0. The eigenvalues of such a block -C are a +- sqrt(bc). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix U' * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * U. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C U (output) DOUBLE PRECISION array, dimension (LDU,N) -C The leading N-by-N part of this array contains the -C orthogonal transformation matrix used to reduce A to the -C real Schur form. The columns of U are the Schur vectors of -C matrix A. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= max(1,N). -C -C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) -C WR and WI contain the real and imaginary parts, -C respectively, of the computed eigenvalues of A. The -C eigenvalues will be in the same order that they appear on -C the diagonal of the output real Schur form of A. Complex -C conjugate pairs of eigenvalues will appear consecutively -C with the eigenvalue having the positive imaginary part -C first. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. LWORK >= 3*N. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QR algorithm failed to compute -C all the eigenvalues; elements i+1:N of WR and WI -C contain those eigenvalues which have converged; -C U contains the matrix which reduces A to its -C partially converged Schur form. -C -C METHOD -C -C Matrix A is reduced to a real Schur form using an orthogonal -C similarity transformation A <- U'*A*U. Then, the transformation -C is applied to the matrices B and C: B <-- U'*B and C <-- C*U. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 10N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, March 1998. -C Based on the RASP routine SRSFDC. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Orthogonal transformation, real Schur form, similarity -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), - $ WI(*), WR(*) -C .. Local Scalars .. - INTEGER I, LDWP, SDIM - DOUBLE PRECISION WRKOPT -C .. Local Arrays .. - LOGICAL BWORK( 1 ) -C .. External Functions .. - LOGICAL LSAME, SELECT - EXTERNAL LSAME, SELECT -C .. External Subroutines .. - EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.3*N ) THEN - INFO = -15 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) - $ RETURN -C -C Reduce A to real Schur form using an orthogonal similarity -C transformation A <- U'*A*U, accumulate the transformation in U -C and compute the eigenvalues of A in (WR,WI). -C -C Workspace: need 3*N; -C prefer larger. -C - CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, - $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) - WRKOPT = DWORK( 1 ) - IF( INFO.NE.0 ) - $ RETURN -C -C Apply the transformation: B <-- U'*B. -C - IF( LDWORK.LT.N*M ) THEN -C -C Not enough working space for using DGEMM. -C - DO 10 I = 1, M - CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ B(1,I), 1 ) - 10 CONTINUE -C - ELSE - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, - $ DWORK, N, ZERO, B, LDB ) - WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) - END IF -C -C Apply the transformation: C <-- C*U. -C - IF( LDWORK.LT.N*P ) THEN -C -C Not enough working space for using DGEMM. -C - DO 20 I = 1, P - CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, - $ C(I,1), LDC ) - 20 CONTINUE -C - ELSE - LDWP = MAX( 1, P ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) - CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, - $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) - WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) - END IF -C - DWORK( 1 ) = WRKOPT -C - RETURN -C *** Last line of TB01WD *** - END diff --git a/slycot/src/TB01XD.f b/slycot/src/TB01XD.f deleted file mode 100644 index 78bf9295..00000000 --- a/slycot/src/TB01XD.f +++ /dev/null @@ -1,284 +0,0 @@ - SUBROUTINE TB01XD( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, - $ D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a special transformation to a system given as a triple -C (A,B,C), -C -C A <-- P * A' * P, B <-- P * C', C <-- B' * P, -C -C where P is a matrix with 1 on the secondary diagonal, and with 0 -C in the other entries. Matrix A can be specified as a band matrix. -C Optionally, matrix D of the system can be transposed. This -C transformation is actually a special similarity transformation of -C the dual system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KL >= 0. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KU >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed (pertransposed) matrix P*A'*P. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-P part of this array contains -C the dual input/state matrix P*C'. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0 or P > 0. -C LDB >= 1 if M = 0 and P = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading M-by-N part of this array contains -C the dual state/output matrix B'*P. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) DOUBLE PRECISION array, dimension -C (LDD,MAX(M,P)) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the original direct transmission -C matrix D. -C On exit, if JOBD = 'D', the leading M-by-P part of this -C array contains the transposed direct transmission matrix -C D'. The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,M,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The rows and/or columns of the matrices of the triplet (A,B,C) -C and, optionally, of the matrix D are swapped in a special way. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C Partly based on routine DMPTR (A. Varga, German Aerospace -C Research Establishment, DLR, Aug. 1992). -C -C -C REVISIONS -C -C 07-31-1998, 04-25-1999, A. Varga. -C 03-16-2004, V. Sima. -C -C KEYWORDS -C -C Matrix algebra, matrix operations, similarity transformation. -C -C ********************************************************************* -C -C .. -C .. Scalar Arguments .. - CHARACTER JOBD - INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ) -C .. -C .. Local Scalars .. - LOGICAL LJOBD - INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 -C .. -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - LJOBD = LSAME( JOBD, 'D' ) - MAXMP = MAX( M, P ) - MINMP = MIN( M, P ) - NM1 = N - 1 -C - IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN - INFO = -5 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN - INFO = -14 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01XD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( LJOBD ) THEN -C -C Replace D by D', if non-scalar. -C - DO 5 J = 1, MAXMP - IF ( J.LT.MINMP ) THEN - CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) - ELSE IF ( J.GT.M ) THEN - CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) - END IF - 5 CONTINUE -C - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Replace matrix A by P*A'*P. -C - IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN -C -C Full matrix A. -C - DO 10 J = 1, NM1 - CALL DSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) - 10 CONTINUE -C - ELSE -C -C Band matrix A. -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 20 J = 1, MIN( KL, N-2 ) - J1 = ( N - J )/2 - CALL DSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 30 J = 1, MIN( KU, N-2 ) - J1 = ( N - J )/2 - CALL DSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) - 30 CONTINUE -C -C Pertranspose the diagonal. -C - J1 = N/2 - CALL DSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) -C - END IF -C -C Replace matrix B by P*C' and matrix C by B'*P. -C - DO 40 J = 1, MAXMP - IF ( J.LE.MINMP ) THEN - CALL DSWAP( N, B(1,J), 1, C(J,1), -LDC ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( N, B(1,J), 1, C(J,1), -LDC ) - ELSE - CALL DCOPY( N, C(J,1), -LDC, B(1,J), 1 ) - END IF - 40 CONTINUE -C - RETURN -C *** Last line of TB01XD *** - END diff --git a/slycot/src/TB01XZ.f b/slycot/src/TB01XZ.f deleted file mode 100644 index ef73d0ce..00000000 --- a/slycot/src/TB01XZ.f +++ /dev/null @@ -1,280 +0,0 @@ - SUBROUTINE TB01XZ( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, - $ D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a special transformation to a system given as a triple -C (A,B,C), -C -C A <-- P * A' * P, B <-- P * C', C <-- B' * P, -C -C where P is a matrix with 1 on the secondary diagonal, and with 0 -C in the other entries. Matrix A can be specified as a band matrix. -C Optionally, matrix D of the system can be transposed. This -C transformation is actually a special similarity transformation of -C the dual system. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state space model: -C = 'D': D is present; -C = 'Z': D is assumed a zero matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C KL (input) INTEGER -C The number of subdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KL >= 0. -C -C KU (input) INTEGER -C The number of superdiagonals of A to be transformed. -C MAX( 0, N-1 ) >= KU >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed (pertransposed) matrix P*A'*P. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B. -C On exit, the leading N-by-P part of this array contains -C the dual input/state matrix P*C'. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0 or P > 0. -C LDB >= 1 if M = 0 and P = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C. -C On exit, the leading M-by-N part of this array contains -C the dual state/output matrix B'*P. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C D (input/output) COMPLEX*16 array, dimension (LDD,MAX(M,P)) -C On entry, if JOBD = 'D', the leading P-by-M part of this -C array must contain the original direct transmission -C matrix D. -C On exit, if JOBD = 'D', the leading M-by-P part of this -C array contains the transposed direct transmission matrix -C D'. The array D is not referenced if JOBD = 'Z'. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,M,P) if JOBD = 'D'. -C LDD >= 1 if JOBD = 'Z'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The rows and/or columns of the matrices of the triplet (A,B,C) -C and, optionally, of the matrix D are swapped in a special way. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Matrix algebra, matrix operations, similarity transformation. -C -C ********************************************************************* -C -C .. -C .. Scalar Arguments .. - CHARACTER JOBD - INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P -C .. -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ D( LDD, * ) -C .. -C .. Local Scalars .. - LOGICAL LJOBD - INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 -C .. -C .. External functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. -C .. External Subroutines .. - EXTERNAL XERBLA, ZCOPY, ZSWAP -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 - LJOBD = LSAME( JOBD, 'D' ) - MAXMP = MAX( M, P ) - MINMP = MIN( M, P ) - NM1 = N - 1 -C - IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN - INFO = -5 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. - $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN - INFO = -14 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01XZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( LJOBD ) THEN -C -C Replace D by D', if non-scalar. -C - DO 5 J = 1, MAXMP - IF ( J.LT.MINMP ) THEN - CALL ZSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) - ELSE IF ( J.GT.P ) THEN - CALL ZCOPY( P, D(1,J), 1, D(J,1), LDD ) - ELSE IF ( J.GT.M ) THEN - CALL ZCOPY( M, D(J,1), LDD, D(1,J), 1 ) - END IF - 5 CONTINUE -C - END IF -C - IF( N.EQ.0 ) - $ RETURN -C -C Replace matrix A by P*A'*P. -C - IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN -C -C Full matrix A. -C - DO 10 J = 1, NM1 - CALL ZSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) - 10 CONTINUE -C - ELSE -C -C Band matrix A. -C - LDA1 = LDA + 1 -C -C Pertranspose the KL subdiagonals. -C - DO 20 J = 1, MIN( KL, N-2 ) - J1 = ( N - J )/2 - CALL ZSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) - 20 CONTINUE -C -C Pertranspose the KU superdiagonals. -C - DO 30 J = 1, MIN( KU, N-2 ) - J1 = ( N - J )/2 - CALL ZSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) - 30 CONTINUE -C -C Pertranspose the diagonal. -C - J1 = N/2 - CALL ZSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) -C - END IF -C -C Replace matrix B by P*C' and matrix C by B'*P. -C - DO 40 J = 1, MAXMP - IF ( J.LE.MINMP ) THEN - CALL ZSWAP( N, B(1,J), 1, C(J,1), -LDC ) - ELSE IF ( J.GT.P ) THEN - CALL ZCOPY( N, B(1,J), 1, C(J,1), -LDC ) - ELSE - CALL ZCOPY( N, C(J,1), -LDC, B(1,J), 1 ) - END IF - 40 CONTINUE -C - RETURN -C *** Last line of TB01XZ *** - END diff --git a/slycot/src/TB01YD.f b/slycot/src/TB01YD.f deleted file mode 100644 index f653ffab..00000000 --- a/slycot/src/TB01YD.f +++ /dev/null @@ -1,188 +0,0 @@ - SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To apply a special similarity transformation to a system given as -C a triple (A,B,C), -C -C A <-- P * A * P, B <-- P * B, C <-- C * P, -C -C where P is a matrix with 1 on the secondary diagonal, and with 0 -C in the other entries. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A, the number of rows of matrix B -C and the number of columns of matrix C. -C N represents the dimension of the state vector. N >= 0. -C -C M (input) INTEGER. -C The number of columns of matrix B. -C M represents the dimension of input vector. M >= 0. -C -C P (input) INTEGER. -C The number of rows of matrix C. -C P represents the dimension of output vector. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the system state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed matrix P*A*P. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the system input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed matrix P*B. -C -C LDB INTEGER -C The leading dimension of the array B. -C LDB >= MAX(1,N) if M > 0. -C LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the system output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*P. -C -C LDC INTEGER -C The leading dimension of the array C. LDC >= MAX(1,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The rows and/or columns of the matrices of the triplet (A,B,C) -C are swapped in a special way. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Matrix algebra, matrix operations, similarity transformation. -C -C ********************************************************************* -C -C .. -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, M, N, P -C .. -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -C .. -C .. Local Scalars .. - INTEGER J, NBY2 -C .. -C .. External Subroutines .. - EXTERNAL DSWAP, XERBLA -C .. -C .. Intrinsic Functions .. - INTRINSIC MAX, MOD -C .. -C .. Executable Statements .. -C -C Test the scalar input arguments. -C - INFO = 0 -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -9 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01YD', -INFO ) - RETURN - END IF -C - IF( N.LE.1 ) - $ RETURN -C -C Transform the matrix A. -C - NBY2 = N/2 -C - DO 10 J = 1, NBY2 - CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 ) - 10 CONTINUE -C - IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 ) - $ CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 ) -C - IF( M.GT.0 ) THEN -C -C Transform the matrix B. -C - DO 20 J = 1, NBY2 - CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB ) - 20 CONTINUE -C - END IF -C - IF( P.GT.0 ) THEN -C -C Transform the matrix C. -C - DO 30 J = 1, NBY2 - CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 ) - 30 CONTINUE -C - END IF -C - RETURN -C *** Last line of TB01YD *** - END diff --git a/slycot/src/TB01ZD.f b/slycot/src/TB01ZD.f deleted file mode 100644 index 6f8acc3a..00000000 --- a/slycot/src/TB01ZD.f +++ /dev/null @@ -1,440 +0,0 @@ - SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, - $ TAU, TOL, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a controllable realization for the linear time-invariant -C single-input system -C -C dX/dt = A * X + B * U, -C Y = C * X, -C -C where A is an N-by-N matrix, B is an N element vector, C is an -C P-by-N matrix, and A and B are reduced by this routine to -C orthogonal canonical form using (and optionally accumulating) -C orthogonal similarity transformations, which are also applied -C to C. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBZ CHARACTER*1 -C Indicates whether the user wishes to accumulate in a -C matrix Z the orthogonal similarity transformations for -C reducing the system, as follows: -C = 'N': Do not form Z and do not store the orthogonal -C transformations; -C = 'F': Do not form Z, but store the orthogonal -C transformations in the factored form; -C = 'I': Z is initialized to the unit matrix and the -C orthogonal transformation matrix Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e. the order of the matrix A. N >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NCONT-by-NCONT upper Hessenberg -C part of this array contains the canonical form of the -C state dynamics matrix, given by Z' * A * Z, of a -C controllable realization for the original system. The -C elements below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, the original input/state vector B. -C On exit, the leading NCONT elements of this array contain -C canonical form of the input/state vector, given by Z' * B, -C with all elements but B(1) set to zero. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output/state matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output/state matrix, given by C * Z, and -C the leading P-by-NCONT part contains the output/state -C matrix of the controllable realization. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C NCONT (output) INTEGER -C The order of the controllable state-space representation. -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C If JOBZ = 'I', then the leading N-by-N part of this array -C contains the matrix of accumulated orthogonal similarity -C transformations which reduces the given system to -C orthogonal canonical form. -C If JOBZ = 'F', the elements below the diagonal, with the -C array TAU, represent the orthogonal transformation matrix -C as a product of elementary reflectors. The transformation -C matrix can then be obtained by calling the LAPACK Library -C routine DORGQR. -C If JOBZ = 'N', the array Z is not referenced and can be -C supplied as a dummy array (i.e. set parameter LDZ = 1 and -C declare this array to be Z(1,1) in the calling program). -C -C LDZ INTEGER -C The leading dimension of array Z. If JOBZ = 'I' or -C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. -C -C TAU (output) DOUBLE PRECISION array, dimension (N) -C The elements of TAU contain the scalar factors of the -C elementary reflectors used in the reduction of B and A. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of (A,B). If the user sets TOL > 0, then -C the given value of TOL is used as an absolute tolerance; -C elements with absolute value less than TOL are considered -C neglijible. If the user sets TOL <= 0, then an implicitly -C computed, default tolerance, defined by -C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, -C where EPS is the machine precision (see LAPACK Library -C routine DLAMCH). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= MAX(1,N,P). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The Householder matrix which reduces all but the first element -C of vector B to zero is found and this orthogonal similarity -C transformation is applied to the matrix A. The resulting A is then -C reduced to upper Hessenberg form by a sequence of Householder -C transformations. Finally, the order of the controllable state- -C space representation (NCONT) is determined by finding the position -C of the first sub-diagonal element of A which is below an -C appropriate zero threshold, either TOL or TOLDEF (see parameter -C TOL); if NORM(B) is smaller than this threshold, NCONT is set to -C zero, and no computations for reducing the system to orthogonal -C canonical form are performed. -C All orthogonal transformations determined in this process are also -C applied to the matrix C, from the right. -C -C REFERENCES -C -C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. -C Orthogonal Invariants and Canonical Forms for Linear -C Controllable Systems. -C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. -C -C [2] Hammarling, S.J. -C Notes on the use of orthogonal similarity transformations in -C control. -C NPL Report DITC 8/82, August 1982. -C -C [3] Paige, C.C -C Properties of numerical algorithms related to computing -C controllability. -C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations and is backward stable. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, -C Sept. 2003. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBZ - INTEGER INFO, LDA, LDC, LDWORK, LDZ, N, NCONT, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), C(LDC,*), DWORK(*), TAU(*), - $ Z(LDZ,*) -C .. Local Scalars .. - LOGICAL LJOBF, LJOBI, LJOBZ - INTEGER ITAU, J - DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, - $ TOLDEF, WRKOPT -C .. Local Arrays .. - DOUBLE PRECISION NBLK(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, - $ DORMHR, MB01PD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -C .. Executable Statements .. -C - INFO = 0 - LJOBF = LSAME( JOBZ, 'F' ) - LJOBI = LSAME( JOBZ, 'I' ) - LJOBZ = LJOBF.OR.LJOBI -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDWORK.LT.MAX( 1, N, P ) ) THEN - INFO = -15 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB01ZD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - NCONT = 0 - DWORK(1) = ONE - IF ( N.EQ.0 ) - $ RETURN -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = ONE -C -C Calculate the absolute norms of A and B (used for scaling). -C - ANORM = DLANGE( 'Max', N, N, A, LDA, DWORK ) - BNORM = DLANGE( 'Max', N, 1, B, N, DWORK ) -C -C Return if matrix B is zero. -C - IF( BNORM.EQ.ZERO ) THEN - IF( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF - RETURN - END IF -C -C Scale (if needed) the matrices A and B. -C - CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) - CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) -C -C Calculate the Frobenius norm of A and the 1-norm of B (used for -C controlability test). -C - FANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - FBNORM = DLANGE( '1-norm', N, 1, B, N, DWORK ) -C - TOLDEF = TOL - IF ( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) - TOLDEF = THRESH*MAX( FANORM, FBNORM ) - END IF -C - ITAU = 1 - IF ( FBNORM.GT.TOLDEF ) THEN -C -C B is not negligible compared with A. -C - IF ( N.GT.1 ) THEN -C -C Transform B by a Householder matrix Z1: store vector -C describing this temporarily in B and in the local scalar H. -C - CALL DLARFG( N, B(1), B(2), 1, H ) -C - B1 = B(1) - B(1) = ONE -C -C Form Z1 * A * Z1. -C Workspace: need N. -C - CALL DLARF( 'Right', N, N, B, 1, H, A, LDA, DWORK ) - CALL DLARF( 'Left', N, N, B, 1, H, A, LDA, DWORK ) -C -C Form C * Z1. -C Workspace: need P. -C - CALL DLARF( 'Right', P, N, B, 1, H, C, LDC, DWORK ) -C - B(1) = B1 - TAU(1) = H - ITAU = ITAU + 1 - ELSE - B1 = B(1) - TAU(1) = ZERO - END IF -C -C Reduce modified A to upper Hessenberg form by an orthogonal -C similarity transformation with matrix Z2. -C Workspace: need N; prefer N*NB. -C - CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) - WRKOPT = DWORK(1) -C -C Form C * Z2. -C Workspace: need P; prefer P*NB. -C - CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, - $ TAU(ITAU), C, LDC, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) -C - IF ( LJOBZ ) THEN -C -C Save the orthogonal transformations used, so that they could -C be accumulated by calling DORGQR routine. -C - IF ( N.GT.1 ) - $ CALL DLACPY( 'Full', N-1, 1, B(2), N-1, Z(2,1), LDZ ) - IF ( N.GT.2 ) - $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, Z(3,2), - $ LDZ ) - IF ( LJOBI ) THEN -C -C Form the orthogonal transformation matrix Z = Z1 * Z2. -C Workspace: need N; prefer N*NB. -C - CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) - WRKOPT = MAX( WRKOPT, DWORK(1) ) - END IF - END IF -C -C Annihilate the lower part of A and B. -C - IF ( N.GT.2 ) - $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) - IF ( N.GT.1 ) - $ CALL DLASET( 'Full', N-1, 1, ZERO, ZERO, B(2), N-1 ) -C -C Find NCONT by checking sizes of the sub-diagonal elements of -C transformed A. -C - IF ( TOL.LE.ZERO ) - $ TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) -C - J = 1 -C -C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO -C - 10 CONTINUE - IF ( J.LT.N ) THEN - IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN - J = J + 1 - GO TO 10 - END IF - END IF -C -C END WHILE 10 -C -C First negligible sub-diagonal element found, if any: set NCONT. -C - NCONT = J - IF ( J.LT.N ) - $ A(J+1,J) = ZERO -C -C Undo scaling of A and B. -C - CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, - $ LDA, INFO ) - CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - IF ( NCONT.LT.N ) - $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, - $ A(1,NCONT+1), LDA, INFO ) - ELSE -C -C B is negligible compared with A. No computations for reducing -C the system to orthogonal canonical form have been performed, -C except scaling (which is undoed). -C - CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, - $ INFO ) - CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) - IF( LJOBF ) THEN - CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) - CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) - ELSE IF( LJOBI ) THEN - CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - END IF - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TB01ZD *** - END diff --git a/slycot/src/TB03AD.f b/slycot/src/TB03AD.f deleted file mode 100644 index 318c2f32..00000000 --- a/slycot/src/TB03AD.f +++ /dev/null @@ -1,746 +0,0 @@ - SUBROUTINE TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, - $ D, LDD, NR, INDEX, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a relatively prime left polynomial matrix representation -C inv(P(s))*Q(s) or right polynomial matrix representation -C Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a -C given state-space representation, i.e. -C -C inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D. -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether the left polynomial matrix -C representation or the right polynomial matrix -C representation is required as follows: -C = 'L': A left matrix fraction is required; -C = 'R': A right matrix fraction is required. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the triplet -C (A,B,C), before computing a minimal state-space -C representation, as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the original state dynamics matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the upper block Hessenberg state dynamics matrix Amin of a -C minimal realization for the original system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B; the remainder -C of the leading N-by-MAX(M,P) part is used as internal -C workspace. -C On exit, the leading NR-by-M part of this array contains -C the transformed input/state matrix Bmin. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C; the remainder -C of the leading MAX(M,P)-by-N part is used as internal -C workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix Cmin. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array must contain the -C original direct transmission matrix D; the remainder of -C the leading MAX(M,P)-by-MAX(M,P) part is used as internal -C workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C NR (output) INTEGER -C The order of the minimal state-space representation -C (Amin,Bmin,Cmin). -C -C INDEX (output) INTEGER array, dimension (P), if LERI = 'L', or -C dimension (M), if LERI = 'R'. -C If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the -C maximum degree of the polynomials in the I-th row of the -C denominator matrix P(s) of the left polynomial matrix -C representation. -C These elements are ordered so that -C INDEX(1) >= INDEX(2) >= ... >= INDEX(P). -C If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the -C maximum degree of the polynomials in the I-th column of -C the denominator matrix P(s) of the right polynomial -C matrix representation. -C These elements are ordered so that -C INDEX(1) >= INDEX(2) >= ... >= INDEX(M). -C -C PCOEFF (output) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,N+1) -C If LERI = 'L' then porm = P, otherwise porm = M. -C The leading porm-by-porm-by-kpcoef part of this array -C contains the coefficients of the denominator matrix P(s), -C where kpcoef = MAX(INDEX(I)) + 1. -C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if -C LERI = 'L' then iorj = I, otherwise iorj = J. -C Thus for LERI = 'L', P(s) = -C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P), if LERI = 'L'; -C LDPCO1 >= MAX(1,M), if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P), if LERI = 'L'; -C LDPCO2 >= MAX(1,M), if LERI = 'R'. -C -C QCOEFF (output) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,N+1) -C If LERI = 'L' then porp = M, otherwise porp = P. -C If LERI = 'L', the leading porm-by-porp-by-kpcoef part -C of this array contains the coefficients of the numerator -C matrix Q(s). -C If LERI = 'R', the leading porp-by-porm-by-kpcoef part -C of this array contains the coefficients of the numerator -C matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,P), if LERI = 'L'; -C LDQCO1 >= MAX(1,M,P), if LERI = 'R'. -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M), if LERI = 'L'; -C LDQCO2 >= MAX(1,M,P), if LERI = 'R'. -C -C VCOEFF (output) DOUBLE PRECISION array, dimension -C (LDVCO1,LDVCO2,N+1) -C The leading porm-by-NR-by-kpcoef part of this array -C contains the coefficients of the intermediate matrix V(s). -C VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C -C LDVCO1 INTEGER -C The leading dimension of array VCOEFF. -C LDVCO1 >= MAX(1,P), if LERI = 'L'; -C LDVCO1 >= MAX(1,M), if LERI = 'R'. -C -C LDVCO2 INTEGER -C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) -C where PM = P, if LERI = 'L'; -C PM = M, if LERI = 'R'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if a singular matrix was encountered during the -C computation of V(s); -C = 2: if a singular matrix was encountered during the -C computation of P(s). -C -C METHOD -C -C The method for a left matrix fraction will be described here: -C right matrix fractions are dealt with by constructing a left -C fraction for the dual of the original system. The first step is to -C obtain, by means of orthogonal similarity transformations, a -C minimal state-space representation (Amin,Bmin,Cmin,D) for the -C original system (A,B,C,D), where Amin is lower block Hessenberg -C with all its superdiagonal blocks upper triangular and Cmin has -C all but its first rank(C) columns zero. The number and dimensions -C of the blocks of Amin now immediately yield the row degrees of -C P(s) with P(s) row proper: furthermore, the P-by-NR polynomial -C matrix V(s) (playing a similar role to S(s) in Wolovich's -C Structure Theorem) can be calculated a column block at a time, in -C reverse order, from Amin. P(s) is then found as if it were the -C O-th column block of V(s) (using Cmin as well as Amin), while -C Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity -C transformation is used to put Amin in an upper block Hessenberg -C form. -C -C REFERENCES -C -C [1] Williams, T.W.C. -C An Orthogonal Structure Theorem for Linear Systems. -C Kingston Polytechnic Control Systems Research Group, -C Internal Report 82/2, July 1982. -C -C [2] Patel, R.V. -C On Computing Matrix Fraction Descriptions and Canonical -C Forms of Linear Time-Invariant Systems. -C UMIST Control Systems Centre Report 489, 1980. -C (Algorithms 1 and 2, extensively modified). -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. -C Supersedes Release 3.0 routine TB01SD. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. -C -C KEYWORDS -C -C Canonical form, coprime matrix fraction, dual system, elementary -C polynomial operations, Hessenberg form, minimal realization, -C orthogonal transformation, polynomial matrix, state-space -C representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, LERI - INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, - $ LDQCO1, LDQCO2, LDVCO1, LDVCO2, LDWORK, M, N, - $ NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*), VCOEFF(LDVCO1,LDVCO2,*) -C .. Local Scalars .. - LOGICAL LEQUIL, LLERIL, LLERIR - INTEGER I, IC, IFIRST, INDBLK, INPLUS, IOFF, IRANKC, - $ ISTART, ISTOP, ITAU, IZ, JOFF, JWORK, K, KMAX, - $ KPCOEF, KPLUS, KWORK, LDWRIC, MAXMP, MPLIM, - $ MWORK, NCOL, NCONT, NREFLC, NROW, PWORK, WRKOPT - DOUBLE PRECISION MAXRED -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DGEMM, DGEQRF, DGETRF, DLACPY, DLASET, - $ DORMQR, DTRSM, MA02GD, TB01ID, TB01UD, TB01YD, - $ TB03AY, TC01OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - LLERIL = LSAME( LERI, 'L' ) - LLERIR = LSAME( LERI, 'R' ) - LEQUIL = LSAME( EQUIL, 'S' ) - MAXMP = MAX( M, P ) - MPLIM = MAX( 1, MAXMP ) - IF ( LLERIR ) THEN -C -C Initialization for right matrix fraction. -C - PWORK = M - MWORK = P - ELSE -C -C Initialization for left matrix fraction. -C - PWORK = P - MWORK = M - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LLERIL .AND. .NOT.LLERIR ) THEN - INFO = -1 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.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( LDC.LT.MPLIM ) THEN - INFO = -11 - ELSE IF( LDD.LT.MPLIM ) THEN - INFO = -13 - ELSE IF( LDPCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -17 - ELSE IF( LDPCO2.LT.MAX( 1, PWORK ) ) THEN - INFO = -18 - ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. LLERIR .AND. - $ LDQCO1.LT.MPLIM ) THEN - INFO = -20 - ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. LLERIR .AND. - $ LDQCO2.LT.MPLIM ) THEN - INFO = -21 - ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -23 - ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN - INFO = -24 - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), - $ PWORK*( PWORK + 2 ) ) ) THEN - INFO = -28 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB03AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF ( LLERIR ) THEN -C -C For right matrix fraction, obtain dual system. -C - CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) - END IF -C -C Obtain minimal realization, in canonical form, for this system. -C Part of the code in SLICOT routine TB01PD is included in-line -C here. (TB01PD cannot be directly used.) -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C If required, balance the triplet (A,B,C) (default MAXRED). -C Workspace: need N. -C - IF ( LEQUIL ) THEN - MAXRED = ZERO - CALL TB01ID( 'A', N, MWORK, PWORK, MAXRED, A, LDA, B, LDB, C, - $ LDC, DWORK, INFO ) - END IF -C - IZ = 1 - ITAU = 1 - JWORK = ITAU + N -C -C Separate out controllable subsystem (of order NCONT): -C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. -C -C Workspace: need N + MAX(N, 3*MWORK, PWORK). -C prefer larger. -C - CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ NCONT, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C -C Separate out the observable subsystem (of order NR): -C Form the dual of the subsystem of order NCONT (which is -C controllable), leaving rest as it is. -C - CALL AB07MD( 'Z', NCONT, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ DWORK, 1, INFO ) -C -C And separate out the controllable part of this dual subsystem. -C -C Workspace: need NCONT + MAX(NCONT, 3*PWORK, MWORK). -C prefer larger. -C - CALL TB01UD( 'No Z', NCONT, PWORK, MWORK, A, LDA, B, LDB, C, LDC, - $ NR, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, - $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Retranspose, giving controllable and observable (i.e. minimal) -C part of original system. -C - CALL AB07MD( 'Z', NR, PWORK, MWORK, A, LDA, B, LDB, C, LDC, DWORK, - $ 1, INFO ) -C -C Annihilate the trailing components of IWORK(1:N). -C - DO 10 I = INDBLK + 1, N - IWORK(I) = 0 - 10 CONTINUE -C -C Initialize polynomial matrices P(s), Q(s) and V(s) to zero. -C - DO 20 K = 1, N + 1 - CALL DLASET( 'Full', PWORK, PWORK, ZERO, ZERO, PCOEFF(1,1,K), - $ LDPCO1 ) - CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, QCOEFF(1,1,K), - $ LDQCO1 ) - CALL DLASET( 'Full', PWORK, NR, ZERO, ZERO, VCOEFF(1,1,K), - $ LDVCO1 ) - 20 CONTINUE -C -C Finish initializing V(s), and set up row degrees of P(s). -C - INPLUS = INDBLK + 1 - ISTART = 1 - JOFF = NR -C - DO 40 K = 1, INDBLK - KWORK = INPLUS - K - KPLUS = KWORK + 1 - ISTOP = IWORK(KWORK) - JOFF = JOFF - ISTOP -C - DO 30 I = ISTART, ISTOP - INDEX(I) = KWORK - VCOEFF(I,JOFF+I,KPLUS) = ONE - 30 CONTINUE -C - ISTART = ISTOP + 1 - 40 CONTINUE -C -C ISTART = IWORK(1)+1 now: if .LE. PWORK, set up final rows of P(s). -C - DO 50 I = ISTART, PWORK - INDEX(I) = 0 - PCOEFF(I,I,1) = ONE - 50 CONTINUE -C -C Triangularize the superdiagonal blocks of Amin. -C - NROW = IWORK(INDBLK) - IOFF = NR - NROW - KMAX = INDBLK - 1 - ITAU = 1 - IFIRST = 0 - IF ( INDBLK.GT.2 ) IFIRST = IOFF - IWORK(KMAX) -C -C QR decomposition of each superdiagonal block of A in turn -C (done in reverse order to preserve upper triangular blocks in A). -C - DO 60 K = 1, KMAX -C -C Calculate dimensions of new block & its position in A. -C - KWORK = INDBLK - K - NCOL = NROW - NROW = IWORK(KWORK) - JOFF = IOFF - IOFF = IOFF - NROW - NREFLC = MIN( NROW, NCOL ) - JWORK = ITAU + NREFLC - IF ( KWORK.GE.2 ) IFIRST = IFIRST - IWORK(KWORK-1) -C -C Find QR decomposition of this (full rank) block: -C block = QR. No pivoting is needed. -C -C Workspace: need MIN(NROW,NCOL) + NCOL; -C prefer MIN(NROW,NCOL) + NCOL*NB. -C - CALL DGEQRF( NROW, NCOL, A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Premultiply appropriate row block of A by Q'. -C -C Workspace: need MIN(NROW,NCOL) + JOFF; -C prefer MIN(NROW,NCOL) + JOFF*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, JOFF, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), A(IOFF+1,1), - $ LDA, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Premultiply appropriate row block of B by Q' also. -C -C Workspace: need MIN(NROW,NCOL) + MWORK; -C prefer MIN(NROW,NCOL) + MWORK*NB. -C - CALL DORMQR( 'Left', 'Transpose', NROW, MWORK, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), B(IOFF+1,1), - $ LDB, DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C And postmultiply the non-zero part of appropriate column -C block of A by Q. -C -C Workspace: need MIN(NROW,NCOL) + NR; -C prefer MIN(NROW,NCOL) + NR*NB. -C - CALL DORMQR( 'Right', 'No Transpose', NR-IFIRST, NROW, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), - $ A(IFIRST+1,IOFF+1), LDA, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Annihilate the lower triangular part of the block in A. -C - IF ( K.NE.KMAX .AND. NROW.GT.1 ) - $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, - $ A(IOFF+2,JOFF+1), LDA ) -C - 60 CONTINUE -C -C Finally: postmultiply non-zero columns of C by Q (K = KMAX). -C -C Workspace: need MIN(NROW,NCOL) + PWORK; -C prefer MIN(NROW,NCOL) + PWORK*NB. -C - CALL DORMQR( 'Right', 'No Transpose', PWORK, NROW, NREFLC, - $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), C, LDC, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Annihilate the lower triangular part of the block in A. -C - IF ( NROW.GT.1 ) - $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, - $ A(IOFF+2,JOFF+1), LDA ) -C -C Calculate the (PWORK x NR) polynomial matrix V(s) ... -C - CALL TB03AY( NR, A, LDA, INDBLK, IWORK, VCOEFF, LDVCO1, LDVCO2, - $ PCOEFF, LDPCO1, LDPCO2, INFO) -C - IF ( INFO.NE.0 ) THEN - INFO = 1 - RETURN - ELSE -C -C And then use this matrix to calculate P(s): first store -C C1 from C. -C - IC = 1 - IRANKC = IWORK(1) - LDWRIC = MAX( 1, PWORK ) - CALL DLACPY( 'Full', PWORK, IRANKC, C, LDC, DWORK(IC), LDWRIC ) -C - IF ( IRANKC.LT.PWORK ) THEN -C -C rank(C) .LT. PWORK: obtain QR decomposition of C1, -C giving R and Q. -C -C Workspace: need PWORK*IRANKC + 2*IRANKC; -C prefer PWORK*IRANKC + IRANKC + IRANKC*NB. -C - ITAU = IC + LDWRIC*IRANKC - JWORK = ITAU + IRANKC -C - CALL DGEQRF( PWORK, IRANKC, DWORK(IC), LDWRIC, DWORK(ITAU), - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C First IRANKC rows of Pbar(s) are given by Wbar(s) * inv(R). -C Check for zero diagonal elements of R. -C - DO 70 I = 1, IRANKC - IF ( DWORK(IC+(I-1)*LDWRIC+I-1).EQ.ZERO ) THEN -C -C Error return. -C - INFO = 2 - RETURN - END IF - 70 CONTINUE -C - NROW = IRANKC -C - DO 80 K = 1, INPLUS - CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', - $ NROW, IRANKC, ONE, DWORK(IC), LDWRIC, - $ PCOEFF(1,1,K), LDPCO1 ) - NROW = IWORK(K) - 80 CONTINUE -C -C P(s) itself is now given by Pbar(s) * Q'. -C - NROW = PWORK -C - DO 90 K = 1, INPLUS -C -C Workspace: need PWORK*IRANKC + IRANKC + NROW; -C prefer PWORK*IRANKC + IRANKC + NROW*NB. -C - CALL DORMQR( 'Right', 'Transpose', NROW, PWORK, IRANKC, - $ DWORK(IC), LDWRIC, DWORK(ITAU), - $ PCOEFF(1,1,K), LDPCO1, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - NROW = IWORK(K) - 90 CONTINUE -C - ELSE -C -C Special case rank(C) = PWORK, full: -C no QR decomposition (P(s)=Wbar(s)*inv(C1)). -C - CALL DGETRF( PWORK, PWORK, DWORK(IC), LDWRIC, IWORK(N+1), - $ INFO ) -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - INFO = 2 - RETURN - ELSE -C - NROW = IRANKC -C -C Workspace: need PWORK*IRANKC + N. -C - DO 100 K = 1, INPLUS - CALL DTRSM( 'Right', 'Upper', 'No Transpose', - $ 'Non-unit', NROW, PWORK, ONE, DWORK(IC), - $ LDWRIC, PCOEFF(1,1,K), LDPCO1 ) - CALL DTRSM( 'Right', 'Lower', 'No Transpose', 'Unit', - $ NROW, PWORK, ONE, DWORK(IC), LDWRIC, - $ PCOEFF(1,1,K), LDPCO1 ) - CALL MA02GD( NROW, PCOEFF(1,1,K), LDPCO1, 1, PWORK, - $ IWORK(N+1), -1 ) - NROW = IWORK(K) - 100 CONTINUE - END IF - END IF -C -C Finally, Q(s) = V(s) * B + P(s) * D can now be evaluated. -C - NROW = PWORK -C - DO 110 K = 1, INPLUS - CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, - $ NR, ONE, VCOEFF(1,1,K), LDVCO1, B, LDB, ZERO, - $ QCOEFF(1,1,K), LDQCO1 ) - CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, - $ PWORK, ONE, PCOEFF(1,1,K), LDPCO1, D, LDD, ONE, - $ QCOEFF(1,1,K), LDQCO1 ) - NROW = IWORK(K) - 110 CONTINUE -C - END IF -C - IF ( LLERIR ) THEN -C -C For right matrix fraction, return to original (dual of dual) -C system. -C - CALL AB07MD( 'Z', NR, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ DWORK, 1, INFO ) -C -C Also, obtain the dual of the polynomial matrix representation. -C - KPCOEF = 0 -C - DO 120 I = 1, PWORK - KPCOEF = MAX( KPCOEF, INDEX(I) ) - 120 CONTINUE -C - KPCOEF = KPCOEF + 1 - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) - ELSE -C -C Reorder the rows and columns of the system, to get an upper -C block Hessenberg matrix A of the minimal system. -C - CALL TB01YD( NR, M, P, A, LDA, B, LDB, C, LDC, INFO ) - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT - RETURN -C *** Last line of TB03AD *** - END diff --git a/slycot/src/TB03AY.f b/slycot/src/TB03AY.f deleted file mode 100644 index eeffc6e2..00000000 --- a/slycot/src/TB03AY.f +++ /dev/null @@ -1,159 +0,0 @@ - SUBROUTINE TB03AY( NR, A, LDA, INDBLK, NBLK, VCOEFF, LDVCO1, - $ LDVCO2, PCOEFF, LDPCO1, LDPCO2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To calculate the (PWORK-by-NR) polynomial matrix V(s) one -C (PWORK-by-NBLK(L-1)) block V:L-1(s) at a time, in reverse order -C (L = INDBLK,...,1). At each stage, the (NBLK(L)-by-NBLK(L)) poly- -C nomial matrix W(s) = V2(s) * A2 is formed, where V2(s) is that -C part of V(s) already computed and A2 is the subdiagonal (incl.) -C part of the L-th column block of A; W(s) is temporarily stored in -C the top left part of P(s), as is subsequently the further matrix -C Wbar(s) = s * V:L(s) - W(s). Then, except for the final stage -C L = 1 (when the next step is to calculate P(s) itself, not here), -C the top left part of V:L-1(s) is given by Wbar(s) * inv(R), where -C R is the upper triangular part of the L-th superdiagonal block of -C A. Finally, note that the coefficient matrices W(.,.,K) can only -C be non-zero for K = L + 1,...,INPLUS, with each of these matrices -C having only its first NBLK(L-1) rows non-trivial. Similarly, -C Wbar(.,.,K) (and so clearly V:L-1(.,.,K) ) can only be non-zero -C for K = L,...,INPLUS, with each of these having only its first -C NBLK(K-1) rows non-trivial except for K = L, which has NBLK(L) -C such rows. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C NOTE: In the interests of speed, this routine does not check the -C inputs for errors. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INDBLK, INFO, LDA, LDPCO1, LDPCO2, LDVCO1, - $ LDVCO2, NR -C .. Array Arguments .. - INTEGER NBLK(*) - DOUBLE PRECISION A(LDA,*), PCOEFF(LDPCO1,LDPCO2,*), - $ VCOEFF(LDVCO1,LDVCO2,*) -C .. Local Scalars .. - INTEGER I, INPLUS, IOFF, J, JOFF, K, KPLUS, L, LSTART, - $ LSTOP, LWORK, NCOL, NROW -C .. External Subroutines .. - EXTERNAL DAXPY, DGEMM, DLACPY, DSCAL, DTRSM -C .. Executable Statements .. -C - INFO = 0 - INPLUS = INDBLK + 1 - JOFF = NR -C -C Calculate each column block V:LWORK-1(s) of V(s) in turn. -C - DO 70 L = 1, INDBLK - LWORK = INPLUS - L -C -C Determine number of columns of V:LWORK(s) & its position in V. -C - NCOL = NBLK(LWORK) - JOFF = JOFF - NCOL -C -C Find limits for V2(s) * A2 calculation: skips zero rows -C in V(s). -C - LSTART = JOFF + 1 - LSTOP = JOFF -C -C Calculate W(s) and store (temporarily) in top left part -C of P(s). -C - DO 10 K = LWORK + 1, INPLUS - NROW = NBLK(K-1) - LSTOP = LSTOP + NROW - CALL DGEMM( 'No transpose', 'No transpose', NROW, NCOL, - $ LSTOP-LSTART+1, ONE, VCOEFF(1,LSTART,K), LDVCO1, - $ A(LSTART,JOFF+1), LDA, ZERO, PCOEFF(1,1,K), - $ LDPCO1 ) - 10 CONTINUE -C -C Replace W(s) by Wbar(s) = s * V:L(s) - W(s). -C - NROW = NCOL -C - DO 30 K = LWORK, INDBLK - KPLUS = K + 1 -C - DO 20 J = 1, NCOL - CALL DSCAL( NROW, -ONE, PCOEFF(1,J,K), 1 ) - CALL DAXPY( NROW, ONE, VCOEFF(1,JOFF+J,KPLUS), 1, - $ PCOEFF(1,J,K), 1 ) - 20 CONTINUE -C - NROW = NBLK(K) - 30 CONTINUE -C - DO 40 J = 1, NCOL - CALL DSCAL( NROW, -ONE, PCOEFF(1,J,INPLUS), 1 ) - 40 CONTINUE -C - IF ( LWORK.NE.1 ) THEN -C -C If not final stage, use the upper triangular R (from A) -C to calculate V:L-1(s), finally storing this new block. -C - IOFF = JOFF - NBLK(LWORK-1) -C - DO 50 I = 1, NCOL - IF ( A(IOFF+I,JOFF+I).EQ.ZERO ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - 50 CONTINUE -C - NROW = NBLK(LWORK) -C - DO 60 K = LWORK, INPLUS - CALL DLACPY( 'Full', NROW, NCOL, PCOEFF(1,1,K), LDPCO1, - $ VCOEFF(1,IOFF+1,K), LDVCO1 ) - CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', - $ NROW, NCOL, ONE, A(IOFF+1,JOFF+1), LDA, - $ VCOEFF(1,IOFF+1,K), LDVCO1 ) - NROW = NBLK(K) - 60 CONTINUE -C - END IF - 70 CONTINUE -C - RETURN -C *** Last line of TB03AY *** - END diff --git a/slycot/src/TB04AD.f b/slycot/src/TB04AD.f deleted file mode 100644 index d864d191..00000000 --- a/slycot/src/TB04AD.f +++ /dev/null @@ -1,395 +0,0 @@ - SUBROUTINE TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D, - $ LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, - $ LDUCO2, TOL1, TOL2, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the transfer matrix T(s) of a given state-space -C representation (A,B,C,D). T(s) is expressed as either row or -C column polynomial vectors over monic least common denominator -C polynomials. -C -C ARGUMENTS -C -C Mode Parameters -C -C ROWCOL CHARACTER*1 -C Indicates whether the transfer matrix T(s) is required -C as rows or columns over common denominators as follows: -C = 'R': T(s) is required as rows over common denominators; -C = 'C': T(s) is required as columns over common -C denominators. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the state-space representation, i.e. the -C order of the original state dynamics matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the upper block Hessenberg state dynamics matrix A of a -C transformed representation for the original system: this -C is completely controllable if ROWCOL = 'R', or completely -C observable if ROWCOL = 'C'. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), -C if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'. -C On entry, the leading N-by-M part of this array must -C contain the original input/state matrix B; if -C ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P) -C part is used as internal workspace. -C On exit, the leading NR-by-M part of this array contains -C the transformed input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original state/output matrix C; if -C ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N -C part is used as internal workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix C. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,P) if ROWCOL = 'R'; -C LDC >= MAX(1,M,P) if ROWCOL = 'C'. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M), -C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. -C The leading P-by-M part of this array must contain the -C original direct transmission matrix D; if ROWCOL = 'C', -C this array is modified internally, but restored on exit, -C and the remainder of the leading MAX(M,P)-by-MAX(M,P) -C part is used as internal workspace. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if ROWCOL = 'R'; -C LDD >= MAX(1,M,P) if ROWCOL = 'C'. -C -C NR (output) INTEGER -C The order of the transformed state-space representation. -C -C INDEX (output) INTEGER array, dimension (porm), where porm = P, -C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. -C The degrees of the denominator polynomials. -C -C DCOEFF (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1) -C The leading porm-by-kdcoef part of this array contains -C the coefficients of each denominator polynomial, where -C kdcoef = MAX(INDEX(I)) + 1. -C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of -C the I-th denominator polynomial, where K = 1,2,...,kdcoef. -C -C LDDCOE INTEGER -C The leading dimension of array DCOEFF. -C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; -C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. -C -C UCOEFF (output) DOUBLE PRECISION array, dimension -C (LDUCO1,LDUCO2,N+1) -C If ROWCOL = 'R' then porp = M, otherwise porp = P. -C The leading porm-by-porp-by-kdcoef part of this array -C contains the coefficients of the numerator matrix U(s). -C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; -C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. -C Thus for ROWCOL = 'R', U(s) = -C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). -C -C LDUCO1 INTEGER -C The leading dimension of array UCOEFF. -C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; -C LDUCO1 >= MAX(1,M) if ROWCOL = 'C'. -C -C LDUCO2 INTEGER -C The second dimension of array UCOEFF. -C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; -C LDUCO2 >= MAX(1,P) if ROWCOL = 'C'. -C -C Tolerances -C -C TOL1 DOUBLE PRECISION -C The tolerance to be used in determining the i-th row of -C T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0, -C then the given value of TOL1 is used as an absolute -C tolerance; elements with absolute value less than TOL1 are -C considered neglijible. If the user sets TOL1 <= 0, then -C an implicitly computed, default tolerance, defined in -C the SLICOT Library routine TB01ZD, is used instead. -C -C TOL2 DOUBLE PRECISION -C The tolerance to be used to separate out a controllable -C subsystem of (A,B,C). If the user sets TOL2 > 0, then -C the given value of TOL2 is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL2 is considered to be of full rank. If the user sets -C TOL2 <= 0, then an implicitly computed, default tolerance, -C defined in the SLICOT Library routine TB01UD, is used -C instead. -C -C Workspace -C -C IWORK DOUBLE PRECISION array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP), -C 3*MP, PM)), -C where MP = M, PM = P, if ROWCOL = 'R'; -C MP = P, PM = M, if ROWCOL = 'C'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The method for transfer matrices factorized by rows will be -C described here: T(s) factorized by columns is dealt with by -C operating on the dual of the original system. Each row of -C T(s) is simply a single-output relatively left prime polynomial -C matrix representation, so can be calculated by applying a -C simplified version of the Orthogonal Structure Theorem to a -C minimal state-space representation for the corresponding row of -C the given system. A minimal state-space representation is obtained -C using the Orthogonal Canonical Form to first separate out a -C completely controllable one for the overall system and then, for -C each row in turn, applying it again to the resulting dual SIMO -C (single-input multi-output) system. Note that the elements of the -C transformed matrix A so calculated are individually scaled in a -C way which guarantees a monic denominator polynomial. -C -C REFERENCES -C -C [1] Williams, T.W.C. -C An Orthogonal Structure Theorem for Linear Systems. -C Control Systems Research Group, Kingston Polytechnic, -C Internal Report 82/2, 1982. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. -C Supersedes Release 3.0 routine TB01QD. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Controllability, dual system, minimal realization, orthogonal -C canonical form, orthogonal transformation, polynomial matrix, -C transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ROWCOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), DWORK(*), - $ UCOEFF(LDUCO1,LDUCO2,*) -C .. Local Scalars .. - LOGICAL LROCOC, LROCOR - CHARACTER*1 JOBD - INTEGER I, IA, ITAU, J, JWORK, K, KDCOEF, MAXMP, MAXMPN, - $ MPLIM, MWORK, N1, PWORK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DLASET, DSWAP, TB01XD, TB04AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -C .. Executable Statements .. -C - INFO = 0 - LROCOR = LSAME( ROWCOL, 'R' ) - LROCOC = LSAME( ROWCOL, 'C' ) - MAXMP = MAX( M, P ) - MPLIM = MAX( 1, MAXMP ) - MAXMPN = MAX( MAXMP, N ) - N1 = MAX( 1, N ) - IF ( LROCOR ) THEN -C -C T(s) given as rows over common denominators. -C - PWORK = P - MWORK = M - ELSE -C -C T(s) given as columns over common denominators. -C - PWORK = M - MWORK = P - END IF -C -C Test the input scalar arguments. -C - IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -6 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -8 - ELSE IF( ( LROCOC .AND. LDC.LT.MPLIM ) - $ .OR. LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( ( LROCOC .AND. LDD.LT.MPLIM ) - $ .OR. LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN - INFO = -16 - ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -18 - ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*( N + 1 ) + - $ MAX( N*MWORK + 2*N + MAX( N, MWORK ), - $ 3*MWORK, PWORK ) ) ) THEN - INFO = -24 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAXMPN.EQ.0 ) - $ RETURN -C - JOBD = 'D' - IA = 1 - ITAU = IA + N*N - JWORK = ITAU + N -C - IF ( LROCOC ) THEN -C -C Initialization for T(s) given as columns over common -C denominators. -C - CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, - $ INFO ) - END IF -C -C Initialize polynomial matrix U(s) to zero. -C - DO 10 K = 1, N + 1 - CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, UCOEFF(1,1,K), - $ LDUCO1 ) - 10 CONTINUE -C -C Calculate T(s) by applying the Orthogonal Structure Theorem to -C each of the PWORK MISO subsystems (A,B,C:I,D:I) in turn. -C - CALL TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, LDD, - $ NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, LDUCO2, - $ DWORK(IA), N1, DWORK(ITAU), TOL1, TOL2, IWORK, - $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) - DWORK(1) = DWORK(JWORK) + DBLE( JWORK-1 ) -C - IF ( LROCOC ) THEN -C -C For T(s) factorized by columns, return to original (dual of -C dual) system, and reorder the rows and columns to get an upper -C block Hessenberg state dynamics matrix. -C - CALL TB01XD( JOBD, N, MWORK, PWORK, IWORK(1)+IWORK(2)-1, N-1, - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) -C - IF ( MPLIM.NE.1 ) THEN -C -C Also, transpose U(s) (not 1-by-1). -C - KDCOEF = 0 -C - DO 20 I = 1, PWORK - KDCOEF = MAX( KDCOEF, INDEX(I) ) - 20 CONTINUE -C - KDCOEF = KDCOEF + 1 -C - DO 50 K = 1, KDCOEF -C - DO 40 J = 1, MPLIM - 1 - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 40 CONTINUE -C - 50 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TB04AD *** - END diff --git a/slycot/src/TB04AY.f b/slycot/src/TB04AY.f deleted file mode 100644 index afce62c3..00000000 --- a/slycot/src/TB04AY.f +++ /dev/null @@ -1,246 +0,0 @@ - SUBROUTINE TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, - $ LDD, NCONT, INDEXD, DCOEFF, LDDCOE, UCOEFF, - $ LDUCO1, LDUCO2, AT, N1, TAU, TOL1, TOL2, IWORK, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Calculates the (PWORK x MWORK) transfer matrix T(s), in the form -C of polynomial row vectors over monic least common denominator -C polynomials, of a given state-space representation (ssr). Each -C such row of T(s) is simply a single-output relatively left prime -C polynomial matrix representation (pmr), so can be calculated by -C applying a simplified version of the Orthogonal Structure -C Theorem to a minimal ssr for the corresponding row of the given -C system: such an ssr is obtained by using the Orthogonal Canon- -C ical Form to first separate out a completely controllable one -C for the overall system and then, for each row in turn, applying -C it again to the resulting dual SIMO system. The Orthogonal -C Structure Theorem produces non-monic denominator and V:I(s) -C polynomials: this is avoided here by first scaling AT (the -C transpose of the controllable part of A, found in this routine) -C by suitable products of its sub-diagonal elements (these are then -C no longer needed, so freeing the entire lower triangle for -C storing the coefficients of V(s) apart from the leading 1's, -C which are treated implicitly). These polynomials are calculated -C in reverse order (IW = NMINL - 1,...,1), the monic denominator -C D:I(s) found exactly as if it were V:0(s), and finally the -C numerator vector U:I(s) obtained from the Orthogonal Structure -C Theorem relation. -C -C ****************************************************************** -C - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, LDWORK, MWORK, N, N1, NCONT, PWORK - DOUBLE PRECISION TOL1, TOL2 -C .. Array Arguments .. - INTEGER INDEXD(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), AT(N1,*), B(LDB,*), C(LDC,*), - $ D(LDD,*), DCOEFF(LDDCOE,*), DWORK(*), - $ UCOEFF(LDUCO1,LDUCO2,*), TAU(*) -C .. Local Scalars .. - INTEGER I, IB, IBI, IC, INDCON, IS, IV, IVMIN1, IWPLUS, - $ IZ, J, JWORK, K, L, LWORK, MAXM, NMINL, NPLUS, - $ WRKOPT - DOUBLE PRECISION TEMP -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, TB01UD, TB01ZD -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C -C Separate out controllable subsystem (of order NCONT). -C -C Workspace: MAX(N, 3*MWORK, PWORK). -C - CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, - $ NCONT, INDCON, IWORK, AT, 1, TAU, TOL2, IWORK(N+1), - $ DWORK, LDWORK, INFO ) - WRKOPT = INT( DWORK(1) ) -C - IS = 1 - IC = IS + NCONT - IZ = IC - IB = IC + NCONT - LWORK = IB + MWORK*NCONT - MAXM = MAX( 1, MWORK ) -C -C Calculate each row of T(s) in turn. -C - DO 140 I = 1, PWORK -C -C Form the dual of I-th NCONT-order MISO subsystem ... -C - CALL DCOPY( NCONT, C(I,1), LDC, DWORK(IC), 1 ) -C - DO 10 J = 1, NCONT - CALL DCOPY( NCONT, A(J,1), LDA, AT(1,J), 1 ) - CALL DCOPY( MWORK, B(J,1), LDB, DWORK((J-1)*MAXM+IB), 1 ) - 10 CONTINUE -C -C and separate out its controllable part, giving minimal -C state-space realization for row I. -C -C Workspace: MWORK*NCONT + 2*NCONT + MAX(NCONT,MWORK). -C - CALL TB01ZD( 'No Z', NCONT, MWORK, AT, N1, DWORK(IC), - $ DWORK(IB), MAXM, NMINL, DWORK(IZ), 1, TAU, TOL1, - $ DWORK(LWORK), LDWORK-LWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(LWORK) )+LWORK-1 ) -C -C Store degree of (monic) denominator, and leading coefficient -C vector of numerator. -C - INDEXD(I) = NMINL - DCOEFF(I,1) = ONE - CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,1), LDUCO1 ) -C - IF ( NMINL.EQ.1 ) THEN -C -C Finish off numerator, denominator for simple case NMINL=1. -C - TEMP = -AT(1,1) - DCOEFF(I,2) = TEMP - CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,2), LDUCO1 ) - CALL DSCAL( MWORK, TEMP, UCOEFF(I,1,2), LDUCO1 ) - CALL DAXPY( MWORK, DWORK(IC), DWORK(IB), 1, UCOEFF(I,1,2), - $ LDUCO1 ) - ELSE IF ( NMINL.GT.1 ) THEN -C -C Set up factors for scaling upper triangle of AT ... -C - CALL DCOPY( NMINL-1, AT(2,1), N1+1, DWORK(IC+1), 1 ) - NPLUS = NMINL + 1 -C - DO 20 L = IS, IS + NMINL - 1 - DWORK(L) = ONE - 20 CONTINUE -C -C and scale it, row by row, starting with row NMINL. -C - DO 40 JWORK = NMINL, 1, -1 -C - DO 30 J = JWORK, NMINL - AT(JWORK,J) = DWORK(IS+J-1)*AT(JWORK,J) - 30 CONTINUE -C -C Update scale factors for next row. -C - CALL DSCAL( NMINL-JWORK+1, DWORK(IC+JWORK-1), - $ DWORK(IS+JWORK-1), 1 ) - 40 CONTINUE -C -C Calculate each monic polynomial V:JWORK(s) in turn: -C K-th coefficient stored as AT(IV,K-1). -C - DO 70 IV = 2, NMINL - JWORK = NPLUS - IV - IWPLUS = JWORK + 1 - IVMIN1 = IV - 1 -C -C Set up coefficients due to leading 1's of existing -C V:I(s)'s. -C - DO 50 K = 1, IVMIN1 - AT(IV,K) = -AT(IWPLUS,JWORK+K) - 50 CONTINUE -C - IF ( IV.NE.2 ) THEN -C -C Then add contribution from s * V:JWORK+1(s) term. -C - CALL DAXPY( IV-2, ONE, AT(IVMIN1,1), N1, AT(IV,1), - $ N1 ) -C -C Finally, add effect of lower coefficients of existing -C V:I(s)'s. -C - DO 60 K = 2, IVMIN1 - AT(IV,K) = AT(IV,K) - DDOT( K-1, - $ AT(IWPLUS,JWORK+1), N1, - $ AT(IV-K+1,1), -(N1+1) ) - 60 CONTINUE -C - END IF - 70 CONTINUE -C -C Determine denominator polynomial D(s) as if it were V:0(s). -C - DO 80 K = 2, NPLUS - DCOEFF(I,K) = -AT(1,K-1) - 80 CONTINUE -C - CALL DAXPY( NMINL-1, ONE, AT(NMINL,1), N1, DCOEFF(I,2), - $ LDDCOE ) -C - DO 90 K = 3, NPLUS - DCOEFF(I,K) = DCOEFF(I,K) - DDOT( K-2, AT, N1, - $ AT(NMINL-K+3,1), -(N1+1) ) - 90 CONTINUE -C -C Scale (B' * Z), stored in DWORK(IB). -C - IBI = IB -C - DO 100 L = 1, NMINL - CALL DSCAL( MWORK, DWORK(IS+L-1), DWORK(IBI), 1 ) - IBI = IBI + MAXM - 100 CONTINUE -C -C Evaluate numerator polynomial vector (V(s) * B) + (D(s) -C * D:I): first set up coefficients due to D:I and leading -C 1's of V(s). -C - IBI = IB -C - DO 110 K = 2, NPLUS - CALL DCOPY( MWORK, DWORK(IBI), 1, UCOEFF(I,1,K), LDUCO1 ) - CALL DAXPY( MWORK, DCOEFF(I,K), D(I,1), LDD, - $ UCOEFF(I,1,K), LDUCO1 ) - IBI = IBI + MAXM - 110 CONTINUE -C -C Add contribution from lower coefficients of V(s). -C - DO 130 K = 3, NPLUS -C - DO 120 J = 1, MWORK - UCOEFF(I,J,K) = UCOEFF(I,J,K) + DDOT( K-2, - $ AT(NMINL-K+3,1), -(N1+1), - $ DWORK(IB+J-1), MAXM ) - 120 CONTINUE -C - 130 CONTINUE -C - END IF - 140 CONTINUE -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TB04AY *** - END diff --git a/slycot/src/TB04BD.f b/slycot/src/TB04BD.f deleted file mode 100644 index 0d8d5d0c..00000000 --- a/slycot/src/TB04BD.f +++ /dev/null @@ -1,600 +0,0 @@ - SUBROUTINE TB04BD( JOBD, ORDER, EQUIL, N, M, P, MD, A, LDA, B, - $ LDB, C, LDC, D, LDD, IGN, LDIGN, IGD, LDIGD, - $ GN, GD, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the transfer function matrix G of a state-space -C representation (A,B,C,D) of a linear time-invariant multivariable -C system, using the pole-zeros method. Each element of the transfer -C function matrix is returned in a cancelled, minimal form, with -C numerator and denominator polynomials stored either in increasing -C or decreasing order of the powers of the indeterminate. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state-space model: -C = 'D': D is present; -C = 'Z': D is assumed to be a zero matrix. -C -C ORDER CHARACTER*1 -C Specifies the order in which the polynomial coefficients -C are stored, as follows: -C = 'I': Increasing order of powers of the indeterminate; -C = 'D': Decreasing order of powers of the indeterminate. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system (A,B,C,D). N >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C MD (input) INTEGER -C The maximum degree of the polynomials in G, plus 1. An -C upper bound for MD is N+1. MD >= 1. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if EQUIL = 'S', the leading N-by-N part of this -C array contains the balanced matrix inv(S)*A*S, as returned -C by SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the contents of B are destroyed: all elements but -C those in the first row are set to zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, if EQUIL = 'S', the leading P-by-N part of this -C array contains the balanced matrix C*S, as returned by -C SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this array must -C contain the matrix D. -C If JOBD = 'Z', the array D is not referenced. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C IGN (output) INTEGER array, dimension (LDIGN,M) -C The leading P-by-M part of this array contains the degrees -C of the numerator polynomials in the transfer function -C matrix G. Specifically, the (i,j) element of IGN contains -C the degree of the numerator polynomial of the transfer -C function G(i,j) from the j-th input to the i-th output. -C -C LDIGN INTEGER -C The leading dimension of array IGN. LDIGN >= max(1,P). -C -C IGD (output) INTEGER array, dimension (LDIGD,M) -C The leading P-by-M part of this array contains the degrees -C of the denominator polynomials in the transfer function -C matrix G. Specifically, the (i,j) element of IGD contains -C the degree of the denominator polynomial of the transfer -C function G(i,j). -C -C LDIGD INTEGER -C The leading dimension of array IGD. LDIGD >= max(1,P). -C -C GN (output) DOUBLE PRECISION array, dimension (P*M*MD) -C This array contains the coefficients of the numerator -C polynomials, Num(i,j), of the transfer function matrix G. -C The polynomials are stored in a column-wise order, i.e., -C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), -C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); -C MD memory locations are reserved for each polynomial, -C hence, the (i,j) polynomial is stored starting from the -C location ((j-1)*P+i-1)*MD+1. The coefficients appear in -C increasing or decreasing order of the powers of the -C indeterminate, according to ORDER. -C -C GD (output) DOUBLE PRECISION array, dimension (P*M*MD) -C This array contains the coefficients of the denominator -C polynomials, Den(i,j), of the transfer function matrix G. -C The polynomials are stored in the same way as the -C numerator polynomials. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of a single-input system (A,b) or (A',c'), -C where b and c' are columns in B and C' (C transposed). If -C the user sets TOL > 0, then the given value of TOL is used -C as an absolute tolerance; elements with absolute value -C less than TOL are considered neglijible. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used -C instead, where EPS is the machine precision (see LAPACK -C Library routine DLAMCH), and bc denotes the currently used -C column in B or C' (see METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N+P) + -C MAX( N + MAX( N,P ), N*(2*N+5))) -C If N >= P, N >= 1, the formula above can be written as -C LDWORK >= N*(3*N + P + 5). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to converge when trying to -C compute the zeros of a transfer function; -C = 2: the QR algorithm failed to converge when trying to -C compute the poles of a transfer function. -C The errors INFO = 1 or 2 are unlikely to appear. -C -C METHOD -C -C The routine implements the pole-zero method proposed in [1]. -C This method is based on an algorithm for computing the transfer -C function of a single-input single-output (SISO) system. -C Let (A,b,c,d) be a SISO system. Its transfer function is computed -C as follows: -C -C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). -C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). -C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). -C 4) Compute the zeros of (Ao,bo,co,d). -C 5) Compute the gain of (Ao,bo,co,d). -C -C This algorithm can be implemented using only orthogonal -C transformations [1]. However, for better efficiency, the -C implementation in TB04BD uses one elementary transformation -C in Step 4 and r elementary transformations in Step 5 (to reduce -C an upper Hessenberg matrix to upper triangular form). These -C special elementary transformations are numerically stable -C in practice. -C -C In the multi-input multi-output (MIMO) case, the algorithm -C computes each element (i,j) of the transfer function matrix G, -C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 -C is performed once for each value of j (each column of B). The -C matrices Ac and Ao result in Hessenberg form. -C -C REFERENCES -C -C [1] Varga, A. and Sima, V. -C Numerically Stable Algorithm for Transfer Function Matrix -C Evaluation. -C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable in practice and requires about -C 20*N**3 floating point operations at most, but usually much less. -C -C FURTHER COMMENTS -C -C For maximum efficiency of index calculations, GN and GD are -C implemented as one-dimensional arrays. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Partly based on the BIMASC Library routine TSMT1 by A. Varga. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, state-space representation, transfer function, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOBD, ORDER - DOUBLE PRECISION TOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDIGD, LDIGN, LDWORK, - $ M, MD, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), GD(*), GN(*) - INTEGER IGD(LDIGD,*), IGN(LDIGN,*), IWORK(*) -C .. Local Scalars .. - DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF, X - INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IIP, IM, - $ IP, IPM1, IRP, ITAU, ITAU1, IZ, J, JJ, JWORK, - $ JWORK1, K, L, NCONT, WRKOPT - LOGICAL ASCEND, DIJNZ, FNDEIG, WITHD -C .. Local Arrays .. - DOUBLE PRECISION Z(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, MC01PD, - $ MC01PY, TB01ID, TB01ZD, TB04BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - WITHD = LSAME( JOBD, 'D' ) - ASCEND = LSAME( ORDER, 'I' ) - IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN - INFO = -2 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( MD.LT.1 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -15 - ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN - INFO = -17 - ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN - INFO = -19 - ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + - $ MAX( N + MAX( N, P ), N*( 2*N + 5 ) ) ) - $ ) THEN - INFO = -25 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04BD', -INFO ) - RETURN - END IF -C -C Initialize GN and GD to zero. -C - Z(1) = ZERO - CALL DCOPY( P*M*MD, Z, 0, GN, 1 ) - CALL DCOPY( P*M*MD, Z, 0, GD, 1 ) -C -C Quick return if possible. -C - IF( MIN( N, P, M ).EQ.0 ) THEN - IF( MIN( P, M ).GT.0 ) THEN - K = 1 -C - DO 20 J = 1, M -C - DO 10 I = 1, P - IGN(I,J) = 0 - IGD(I,J) = 0 - IF ( WITHD ) - $ GN(K) = D(I,J) - GD(K) = ONE - K = K + MD - 10 CONTINUE -C - 20 CONTINUE -C - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Prepare the computation of the default tolerance. -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN - EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) - ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - END IF -C -C Initializations. -C - IA = 1 - IC = IA + N*N - ITAU = IC + P*N - JWORK = ITAU + N - IAC = ITAU -C - K = 1 - DIJ = ZERO -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a -C diagonal scaling matrix. -C Workspace: need N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, IERR ) - END IF -C -C Compute the transfer function matrix of the system (A,B,C,D). -C - DO 80 J = 1, M -C -C Save A and C. -C Workspace: need W1 = N*(N+P). -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) -C -C Remove the uncontrollable part of the system (A,B(J),C). -C Workspace: need W1+N+MAX(N,P); -C prefer larger. -C - CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, - $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( J.EQ.1 ) - $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C - IB = IAC + NCONT*NCONT - ICC = IB + NCONT - ITAU1 = ICC + NCONT - IRP = ITAU1 - IIP = IRP + NCONT - IAS = IIP + NCONT - JWORK1 = IAS + NCONT*NCONT -C - DO 70 I = 1, P - IF ( WITHD ) - $ DIJ = D(I,J) - IF ( NCONT.GT.0 ) THEN -C -C Form the matrices of the state-space representation of -C the dual system for the controllable part. -C Workspace: need W2 = W1+N*(N+2). -C - CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, - $ DWORK(IAC), NCONT ) - CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) - CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) -C -C Remove the unobservable part of the system (A,B(J),C(I)). -C Workspace: need W2+2*N; -C prefer larger. -C - CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, - $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, - $ DWORK(ITAU1), TOL, DWORK(IIP), LDWORK-IIP+1, - $ IERR ) - IF ( I.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(IIP) ) + IIP - 1 ) -C - IF ( IP.GT.0 ) THEN -C -C Save the state matrix of the minimal part. -C Workspace: need W3 = W2+N*(N+2). -C - CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, - $ DWORK(IAS), IP ) -C -C Compute the poles of the transfer function. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, - $ DWORK(IAC), NCONT, DWORK(IRP), - $ DWORK(IIP), Z, 1, DWORK(JWORK1), - $ LDWORK-JWORK1+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WRKOPT = MAX( WRKOPT, - $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) -C -C Compute the zeros of the transfer function. -C - IPM1 = IP - 1 - DIJNZ = WITHD .AND. DIJ.NE.ZERO - FNDEIG = DIJNZ .OR. IPM1.GT.0 - IF ( .NOT.FNDEIG ) THEN - IZ = 0 - ELSE IF ( DIJNZ ) THEN -C -C Add the contribution due to D(i,j). -C Note that the matrix whose eigenvalues have to -C be computed remains in an upper Hessenberg form. -C - IZ = IP - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, - $ DWORK(IAC), NCONT ) - CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, - $ DWORK(IAC), NCONT ) - ELSE - IF( TOL.LE.ZERO ) - $ TOLDEF = EPSN*MAX( ANORM, - $ DLANGE( 'Frobenius', IP, 1, - $ DWORK(IB), 1, DWORK ) - $ ) -C - DO 30 IM = 1, IPM1 - IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 - 30 CONTINUE -C - IZ = 0 - GO TO 50 -C - 40 CONTINUE -C -C Restore (part of) the saved state matrix. -C - IZ = IP - IM - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), - $ IP, DWORK(IAC), NCONT ) -C -C Apply the output injection. -C - CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ - $ DWORK(IB+IM-1), DWORK(IB+IM), 1, - $ DWORK(IAC), NCONT ) - END IF -C - IF ( FNDEIG ) THEN -C -C Find the zeros. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, - $ IZ, DWORK(IAC), NCONT, GN(K), GD(K), - $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, - $ IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - END IF -C -C Compute the gain. -C - 50 CONTINUE - IF ( DIJNZ ) THEN - X = DIJ - ELSE - CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), - $ DWORK(IB), DIJ, DWORK(IRP), - $ DWORK(IIP), GN(K), GD(K), X, IWORK ) - END IF -C -C Form the numerator coefficients in increasing or -C decreasing powers of the indeterminate. -C IAS is used here as pointer to the workspace. -C - IF ( ASCEND ) THEN - CALL MC01PD( IZ, GN(K), GD(K), DWORK(IB), - $ DWORK(IAS), IERR ) - ELSE - CALL MC01PY( IZ, GN(K), GD(K), DWORK(IB), - $ DWORK(IAS), IERR ) - END IF - JJ = K -C - DO 60 L = IB, IB + IZ - GN(JJ) = DWORK(L)*X - JJ = JJ + 1 - 60 CONTINUE -C -C Form the denominator coefficients. -C - IF ( ASCEND ) THEN - CALL MC01PD( IP, DWORK(IRP), DWORK(IIP), GD(K), - $ DWORK(IAS), IERR ) - ELSE - CALL MC01PY( IP, DWORK(IRP), DWORK(IIP), GD(K), - $ DWORK(IAS), IERR ) - END IF - IGN(I,J) = IZ - IGD(I,J) = IP - ELSE -C -C Null element. -C - IGN(I,J) = 0 - IGD(I,J) = 0 - GN(K) = DIJ - GD(K) = ONE - END IF -C - ELSE -C -C Null element. -C - IGN(I,J) = 0 - IGD(I,J) = 0 - GN(K) = DIJ - GD(K) = ONE - END IF -C - K = K + MD - 70 CONTINUE -C - 80 CONTINUE -C - RETURN -C *** Last line of TB04BD *** - END diff --git a/slycot/src/TB04BV.f b/slycot/src/TB04BV.f deleted file mode 100644 index 10b58b59..00000000 --- a/slycot/src/TB04BV.f +++ /dev/null @@ -1,343 +0,0 @@ - SUBROUTINE TB04BV( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, - $ GD, D, LDD, TOL, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To separate the strictly proper part G0 from the constant part D -C of an P-by-M proper transfer function matrix G. -C -C ARGUMENTS -C -C Mode Parameters -C -C ORDER CHARACTER*1 -C Specifies the order in which the polynomial coefficients -C of the transfer function matrix are stored, as follows: -C = 'I': Increasing order of powers of the indeterminate; -C = 'D': Decreasing order of powers of the indeterminate. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C MD (input) INTEGER -C The maximum degree of the polynomials in G, plus 1, i.e., -C MD = MAX(IGD(I,J)) + 1. -C I,J -C -C IGN (input/output) INTEGER array, dimension (LDIGN,M) -C On entry, the leading P-by-M part of this array must -C contain the degrees of the numerator polynomials in G: -C the (i,j) element of IGN must contain the degree of the -C numerator polynomial of the polynomial ratio G(i,j). -C On exit, the leading P-by-M part of this array contains -C the degrees of the numerator polynomials in G0. -C -C LDIGN INTEGER -C The leading dimension of array IGN. LDIGN >= max(1,P). -C -C IGD (input) INTEGER array, dimension (LDIGD,M) -C The leading P-by-M part of this array must contain the -C degrees of the denominator polynomials in G (and G0): -C the (i,j) element of IGD contains the degree of the -C denominator polynomial of the polynomial ratio G(i,j). -C -C LDIGD INTEGER -C The leading dimension of array IGD. LDIGD >= max(1,P). -C -C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) -C On entry, this array must contain the coefficients of the -C numerator polynomials, Num(i,j), of the transfer function -C matrix G. The polynomials are stored in a column-wise -C order, i.e., Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), -C Num(2,2), ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., -C Num(P,M); MD memory locations are reserved for each -C polynomial, hence, the (i,j) polynomial is stored starting -C from the location ((j-1)*P+i-1)*MD+1. The coefficients -C appear in increasing or decreasing order of the powers -C of the indeterminate, according to ORDER. -C On exit, this array contains the coefficients of the -C numerator polynomials of the strictly proper part G0 of -C the transfer function matrix G, stored similarly. -C -C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) -C This array must contain the coefficients of the -C denominator polynomials, Den(i,j), of the transfer -C function matrix G. The polynomials are stored as for the -C numerator polynomials. -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array contains the -C matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= max(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the degrees of -C the numerators Num0(i,j) of the strictly proper part of -C the transfer function matrix G. If the user sets TOL > 0, -C then the given value of TOL is used as an absolute -C tolerance; the leading coefficients with absolute value -C less than TOL are considered neglijible. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = IGN(i,j)*EPS*NORM( Num(i,j) ) is used -C instead, where EPS is the machine precision (see LAPACK -C Library routine DLAMCH), and NORM denotes the infinity -C norm (the maximum coefficient in absolute value). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the transfer function matrix is not proper; -C = 2: if a denominator polynomial is null. -C -C METHOD -C -C The (i,j) entry of the real matrix D is zero, if the degree of -C Num(i,j), IGN(i,j), is less than the degree of Den(i,j), IGD(i,j), -C and it is given by the ratio of the leading coefficients of -C Num(i,j) and Den(i,j), if IGN(i,j) is equal to IGD(i,j), -C for i = 1 : P, and for j = 1 : M. -C -C FURTHER COMMENTS -C -C For maximum efficiency of index calculations, GN and GD are -C implemented as one-dimensional arrays. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Based on the BIMASC Library routine TMPRP by A. Varga. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C State-space representation, transfer function. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ORDER - DOUBLE PRECISION TOL - INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P -C .. Array Arguments .. - DOUBLE PRECISION D(LDD,*), GD(*), GN(*) - INTEGER IGD(LDIGD,*), IGN(LDIGN,*) -C .. Local Scalars .. - LOGICAL ASCEND - INTEGER I, II, J, K, KK, KM, ND, NN - DOUBLE PRECISION DIJ, EPS, TOLDEF -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - ASCEND = LSAME( ORDER, 'I' ) - IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN - INFO = -1 - ELSE IF( P.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( MD.LT.1 ) THEN - INFO = -4 - ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN - INFO = -6 - ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04BV', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( P, M ).EQ.0 ) - $ RETURN -C -C Prepare the computation of the default tolerance. -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) - $ EPS = DLAMCH( 'Epsilon' ) -C - K = 1 -C - IF ( ASCEND ) THEN -C -C Polynomial coefficients are stored in increasing order. -C - DO 40 J = 1, M -C - DO 30 I = 1, P - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.GT.ND ) THEN -C -C Error return: the transfer function matrix is -C not proper. -C - INFO = 1 - RETURN - ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) - $ THEN - D(I,J) = ZERO - ELSE -C -C Here NN = ND. -C - KK = K + NN -C - IF ( GD(KK).EQ.ZERO ) THEN -C -C Error return: the denominator is null. -C - INFO = 2 - RETURN - ENDIF -C - DIJ = GN(KK) / GD(KK) - D(I,J) = DIJ - GN(KK) = ZERO - IF ( NN.GT.0 ) THEN - CALL DAXPY( NN, -DIJ, GD(K), 1, GN(K), 1 ) - IF ( TOL.LE.ZERO ) - $ TOLDEF = DBLE( NN )*EPS* - $ ABS( GN(IDAMAX( NN, GN(K), 1 ) ) ) - KM = NN - DO 10 II = 1, KM - KK = KK - 1 - NN = NN - 1 - IF ( ABS( GN(KK) ).GT.TOLDEF ) - $ GO TO 20 - 10 CONTINUE -C - 20 CONTINUE -C - IGN(I,J) = NN - ENDIF - ENDIF - K = K + MD - 30 CONTINUE -C - 40 CONTINUE -C - ELSE -C -C Polynomial coefficients are stored in decreasing order. -C - DO 90 J = 1, M -C - DO 80 I = 1, P - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.GT.ND ) THEN -C -C Error return: the transfer function matrix is -C not proper. -C - INFO = 1 - RETURN - ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) - $ THEN - D(I,J) = ZERO - ELSE -C -C Here NN = ND. -C - KK = K -C - IF ( GD(KK).EQ.ZERO ) THEN -C -C Error return: the denominator is null. -C - INFO = 2 - RETURN - ENDIF -C - DIJ = GN(KK) / GD(KK) - D(I,J) = DIJ - GN(KK) = ZERO - IF ( NN.GT.0 ) THEN - CALL DAXPY( NN, -DIJ, GD(K+1), 1, GN(K+1), 1 ) - IF ( TOL.LE.ZERO ) - $ TOLDEF = DBLE( NN )*EPS* - $ ABS( GN(IDAMAX( NN, GN(K+1), 1 ) ) ) - KM = NN - DO 50 II = 1, KM - KK = KK + 1 - NN = NN - 1 - IF ( ABS( GN(KK) ).GT.TOLDEF ) - $ GO TO 60 - 50 CONTINUE -C - 60 CONTINUE -C - IGN(I,J) = NN - DO 70 II = 0, NN - GN(K+II) = GN(KK+II) - 70 CONTINUE -C - ENDIF - ENDIF - K = K + MD - 80 CONTINUE -C - 90 CONTINUE -C - ENDIF -C - RETURN -C *** Last line of TB04BV *** - END diff --git a/slycot/src/TB04BW.f b/slycot/src/TB04BW.f deleted file mode 100644 index 7fb2a321..00000000 --- a/slycot/src/TB04BW.f +++ /dev/null @@ -1,280 +0,0 @@ - SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, - $ GD, D, LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the sum of an P-by-M rational matrix G and a real -C P-by-M matrix D. -C -C ARGUMENTS -C -C Mode Parameters -C -C ORDER CHARACTER*1 -C Specifies the order in which the polynomial coefficients -C of the rational matrix are stored, as follows: -C = 'I': Increasing order of powers of the indeterminate; -C = 'D': Decreasing order of powers of the indeterminate. -C -C Input/Output Parameters -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C MD (input) INTEGER -C The maximum degree of the polynomials in G, plus 1, i.e., -C MD = MAX(IGN(I,J),IGD(I,J)) + 1. -C I,J -C -C IGN (input/output) INTEGER array, dimension (LDIGN,M) -C On entry, the leading P-by-M part of this array must -C contain the degrees of the numerator polynomials in G: -C the (i,j) element of IGN must contain the degree of the -C numerator polynomial of the polynomial ratio G(i,j). -C On exit, the leading P-by-M part of this array contains -C the degrees of the numerator polynomials in G + D. -C -C LDIGN INTEGER -C The leading dimension of array IGN. LDIGN >= max(1,P). -C -C IGD (input) INTEGER array, dimension (LDIGD,M) -C The leading P-by-M part of this array must contain the -C degrees of the denominator polynomials in G (and G + D): -C the (i,j) element of IGD contains the degree of the -C denominator polynomial of the polynomial ratio G(i,j). -C -C LDIGD INTEGER -C The leading dimension of array IGD. LDIGD >= max(1,P). -C -C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) -C On entry, this array must contain the coefficients of the -C numerator polynomials, Num(i,j), of the rational matrix G. -C The polynomials are stored in a column-wise order, i.e., -C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), -C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); -C MD memory locations are reserved for each polynomial, -C hence, the (i,j) polynomial is stored starting from the -C location ((j-1)*P+i-1)*MD+1. The coefficients appear in -C increasing or decreasing order of the powers of the -C indeterminate, according to ORDER. -C On exit, this array contains the coefficients of the -C numerator polynomials of the rational matrix G + D, -C stored similarly. -C -C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) -C This array must contain the coefficients of the -C denominator polynomials, Den(i,j), of the rational -C matrix G. The polynomials are stored as for the -C numerator polynomials. -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C matrix D. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= max(1,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The (i,j) entry of the real matrix D is added to the (i,j) entry -C of the matrix G, g(i,j), which is a ratio of two polynomials, -C for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed -C that its denominator is 1. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable. -C -C FURTHER COMMENTS -C -C Often, the rational matrix G is found from a state-space -C representation (A,B,C), and D corresponds to the direct -C feedthrough matrix of the system. The sum G + D gives the -C transfer function matrix of the system (A,B,C,D). -C For maximum efficiency of index calculations, GN and GD are -C implemented as one-dimensional arrays. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Based on the BIMASC Library routine TMCADD by A. Varga. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. -C -C KEYWORDS -C -C State-space representation, transfer function. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER ORDER - INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P -C .. Array Arguments .. - DOUBLE PRECISION D(LDD,*), GD(*), GN(*) - INTEGER IGD(LDIGD,*), IGN(LDIGN,*) -C .. Local Scalars .. - LOGICAL ASCEND - INTEGER I, II, J, K, KK, KM, ND, NN - DOUBLE PRECISION DIJ -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - ASCEND = LSAME( ORDER, 'I' ) - IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN - INFO = -1 - ELSE IF( P.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( MD.LT.1 ) THEN - INFO = -4 - ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN - INFO = -6 - ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN - INFO = -8 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04BW', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( MIN( P, M ).EQ.0 ) - $ RETURN -C - K = 1 -C - IF ( ASCEND ) THEN -C -C Polynomial coefficients are stored in increasing order. -C - DO 30 J = 1, M -C - DO 20 I = 1, P - DIJ = D(I,J) - IF ( DIJ.NE.ZERO ) THEN - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN - IF ( GN(K).EQ.ZERO ) THEN - GN(K) = DIJ - ELSE - GN(K) = GN(K) + DIJ*GD(K) - ENDIF - ELSE - KM = MIN( NN, ND ) + 1 - CALL DAXPY( KM, DIJ, GD(K), 1, GN(K), 1 ) - IF ( NN.LT.ND ) THEN -C - DO 10 II = K + KM, K + ND - GN(II) = DIJ*GD(II) - 10 CONTINUE -C - IGN(I,J) = ND - ENDIF - ENDIF - ENDIF - K = K + MD - 20 CONTINUE -C - 30 CONTINUE -C - ELSE -C -C Polynomial coefficients are stored in decreasing order. -C - DO 60 J = 1, M -C - DO 50 I = 1, P - DIJ = D(I,J) - IF ( DIJ.NE.ZERO ) THEN - NN = IGN(I,J) - ND = IGD(I,J) - IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN - IF ( GN(K).EQ.ZERO ) THEN - GN(K) = DIJ - ELSE - GN(K) = GN(K) + DIJ*GD(K) - ENDIF - ELSE - KM = MIN( NN, ND ) + 1 - IF ( NN.LT.ND ) THEN - KK = K + ND - NN -C - DO 35 II = K + NN, K, -1 - GN(II+ND-NN) = GN(II) - 35 CONTINUE -C - DO 40 II = K, KK - 1 - GN(II) = DIJ*GD(II) - 40 CONTINUE -C - IGN(I,J) = ND - CALL DAXPY( KM, DIJ, GD(KK), 1, GN(KK), 1 ) - ELSE - KK = K + NN - ND - CALL DAXPY( KM, DIJ, GD(K), 1, GN(KK), 1 ) - ENDIF - ENDIF - ENDIF - K = K + MD - 50 CONTINUE -C - 60 CONTINUE -C - ENDIF -C - RETURN -C *** Last line of TB04BW *** - END diff --git a/slycot/src/TB04BX.f b/slycot/src/TB04BX.f deleted file mode 100644 index ff0e004f..00000000 --- a/slycot/src/TB04BX.f +++ /dev/null @@ -1,246 +0,0 @@ - SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN, - $ IWORK ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the gain of a single-input single-output linear system, -C given its state-space representation (A,b,c,d), and its poles and -C zeros. The matrix A is assumed to be in an upper Hessenberg form. -C The gain is computed using the formula -C -C -1 IP IZ -C g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) , -C i=1 i=1 (1) -C -C where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros, -C respectively, and S0 is a real scalar different from all poles and -C zeros. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C IP (input) INTEGER -C The number of the system poles. IP >= 0. -C -C IZ (input) INTEGER -C The number of the system zeros. IZ >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,IP) -C On entry, the leading IP-by-IP part of this array must -C contain the state dynamics matrix A in an upper Hessenberg -C form. The elements below the second diagonal are not -C referenced. -C On exit, the leading IP-by-IP upper Hessenberg part of -C this array contains the LU factorization of the matrix -C A - S0*I, as computed by SLICOT Library routine MB02SD. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= max(1,IP). -C -C B (input/output) DOUBLE PRECISION array, dimension (IP) -C On entry, this array must contain the system input -C vector b. -C On exit, this array contains the solution of the linear -C system ( A - S0*I )x = b . -C -C C (input) DOUBLE PRECISION array, dimension (IP) -C This array must contain the system output vector c. -C -C D (input) DOUBLE PRECISION -C The variable must contain the system feedthrough scalar d. -C -C PR (input) DOUBLE PRECISION array, dimension (IP) -C This array must contain the real parts of the system -C poles. Pairs of complex conjugate poles must be stored in -C consecutive memory locations. -C -C PI (input) DOUBLE PRECISION array, dimension (IP) -C This array must contain the imaginary parts of the system -C poles. -C -C ZR (input) DOUBLE PRECISION array, dimension (IZ) -C This array must contain the real parts of the system -C zeros. Pairs of complex conjugate zeros must be stored in -C consecutive memory locations. -C -C ZI (input) DOUBLE PRECISION array, dimension (IZ) -C This array must contain the imaginary parts of the system -C zeros. -C -C GAIN (output) DOUBLE PRECISION -C The gain of the linear system (A,b,c,d), given by (1). -C -C Workspace -C -C IWORK INTEGER array, dimension (IP) -C On exit, it contains the pivot indices; for 1 <= i <= IP, -C row i of the matrix A - S0*I was interchanged with -C row IWORK(i). -C -C METHOD -C -C The routine implements the method presented in [1]. A suitable -C value of S0 is chosen based on the system poles and zeros. -C Then, the LU factorization of the upper Hessenberg, nonsingular -C matrix A - S0*I is computed and used to solve the linear system -C in (1). -C -C REFERENCES -C -C [1] Varga, A. and Sima, V. -C Numerically Stable Algorithm for Transfer Function Matrix -C Evaluation. -C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable in practice and requires -C O(IP*IP) floating point operations. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C Partly based on the BIMASC Library routine GAIN by A. Varga. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, state-space representation, transfer function, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, P1, ONEP1 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ P1 = 0.1D0, ONEP1 = 1.1D0 ) -C .. Scalar Arguments .. - DOUBLE PRECISION D, GAIN - INTEGER IP, IZ, LDA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(*), C(*), PI(*), PR(*), ZI(*), - $ ZR(*) - INTEGER IWORK(*) -C .. Local Scalars .. - INTEGER I, INFO - DOUBLE PRECISION S0, S -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL MB02RD, MB02SD -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX -C .. -C .. Executable Statements .. -C -C For efficiency, the input scalar parameters are not checked. -C -C Quick return if possible. -C - IF( IP.EQ.0 ) THEN - GAIN = ZERO - RETURN - END IF -C -C Compute a suitable value for S0 . -C - S0 = ZERO -C - DO 10 I = 1, IP - S = ABS( PR(I) ) - IF ( PI(I).NE.ZERO ) - $ S = S + ABS( PI(I) ) - S0 = MAX( S0, S ) - 10 CONTINUE -C - DO 20 I = 1, IZ - S = ABS( ZR(I) ) - IF ( ZI(I).NE.ZERO ) - $ S = S + ABS( ZI(I) ) - S0 = MAX( S0, S ) - 20 CONTINUE -C - S0 = TWO*S0 + P1 - IF ( S0.LE.ONE ) - $ S0 = ONEP1 -C -C Form A - S0*I . -C - DO 30 I = 1, IP - A(I,I) = A(I,I) - S0 - 30 CONTINUE -C -C Compute the LU factorization of the matrix A - S0*I -C (guaranteed to be nonsingular). -C - CALL MB02SD( IP, A, LDA, IWORK, INFO ) -C -C Solve the linear system (A - S0*I)*x = b . -C - CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO ) -C -1 -C Compute c*(S0*I - A) *b + d . -C - GAIN = D - DDOT( IP, C, 1, B, 1 ) -C -C Multiply by the products in terms of poles and zeros in (1). -C - I = 1 -C -C WHILE ( I <= IP ) DO -C - 40 IF ( I.LE.IP ) THEN - IF ( PI(I).EQ.ZERO ) THEN - GAIN = GAIN*( S0 - PR(I) ) - I = I + 1 - ELSE - GAIN = GAIN*( S0*( S0 - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 ) - I = I + 2 - END IF - GO TO 40 - END IF -C -C END WHILE 40 -C - I = 1 -C -C WHILE ( I <= IZ ) DO -C - 50 IF ( I.LE.IZ ) THEN - IF ( ZI(I).EQ.ZERO ) THEN - GAIN = GAIN/( S0 - ZR(I) ) - I = I + 1 - ELSE - GAIN = GAIN/( S0*( S0 - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 ) - I = I + 2 - END IF - GO TO 50 - END IF -C -C END WHILE 50 -C - RETURN -C *** Last line of TB04BX *** - END diff --git a/slycot/src/TB04CD.f b/slycot/src/TB04CD.f deleted file mode 100644 index 012548be..00000000 --- a/slycot/src/TB04CD.f +++ /dev/null @@ -1,568 +0,0 @@ - SUBROUTINE TB04CD( JOBD, EQUIL, N, M, P, NPZ, A, LDA, B, LDB, C, - $ LDC, D, LDD, NZ, LDNZ, NP, LDNP, ZEROSR, - $ ZEROSI, POLESR, POLESI, GAINS, LDGAIN, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the transfer function matrix G of a state-space -C representation (A,B,C,D) of a linear time-invariant multivariable -C system, using the pole-zeros method. The transfer function matrix -C is returned in a minimal pole-zero-gain form. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBD CHARACTER*1 -C Specifies whether or not a non-zero matrix D appears in -C the given state-space model: -C = 'D': D is present; -C = 'Z': D is assumed to be a zero matrix. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily -C equilibrate the triplet (A,B,C) as follows: -C = 'S': perform equilibration (scaling); -C = 'N': do not perform equilibration. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the system (A,B,C,D). N >= 0. -C -C M (input) INTEGER -C The number of the system inputs. M >= 0. -C -C P (input) INTEGER -C The number of the system outputs. P >= 0. -C -C NPZ (input) INTEGER -C The maximum number of poles or zeros of the single-input -C single-output channels in the system. An upper bound -C for NPZ is N. NPZ >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, if EQUIL = 'S', the leading N-by-N part of this -C array contains the balanced matrix inv(S)*A*S, as returned -C by SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the contents of B are destroyed: all elements but -C those in the first row are set to zero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, if EQUIL = 'S', the leading P-by-N part of this -C array contains the balanced matrix C*S, as returned by -C SLICOT Library routine TB01ID. -C If EQUIL = 'N', this array is unchanged on exit. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C If JOBD = 'D', the leading P-by-M part of this array must -C contain the matrix D. -C If JOBD = 'Z', the array D is not referenced. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P), if JOBD = 'D'; -C LDD >= 1, if JOBD = 'Z'. -C -C NZ (output) INTEGER array, dimension (LDNZ,M) -C The leading P-by-M part of this array contains the numbers -C of zeros of the elements of the transfer function -C matrix G. Specifically, the (i,j) element of NZ contains -C the number of zeros of the transfer function G(i,j) from -C the j-th input to the i-th output. -C -C LDNZ INTEGER -C The leading dimension of array NZ. LDNZ >= max(1,P). -C -C NP (output) INTEGER array, dimension (LDNP,M) -C The leading P-by-M part of this array contains the numbers -C of poles of the elements of the transfer function -C matrix G. Specifically, the (i,j) element of NP contains -C the number of poles of the transfer function G(i,j). -C -C LDNP INTEGER -C The leading dimension of array NP. LDNP >= max(1,P). -C -C ZEROSR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the real parts of the zeros of the -C transfer function matrix G. The real parts of the zeros -C are stored in a column-wise order, i.e., for the transfer -C functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ..., -C (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations -C are reserved for each transfer function, hence, the real -C parts of the zeros for the (i,j) transfer function -C are stored starting from the location ((j-1)*P+i-1)*NPZ+1. -C Pairs of complex conjugate zeros are stored in consecutive -C memory locations. Note that only the first NZ(i,j) entries -C are initialized for the (i,j) transfer function. -C -C ZEROSI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the imaginary parts of the zeros of -C the transfer function matrix G, stored in a similar way -C as the real parts of the zeros. -C -C POLESR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the real parts of the poles of the -C transfer function matrix G, stored in the same way as -C the zeros. Note that only the first NP(i,j) entries are -C initialized for the (i,j) transfer function. -C -C POLESI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) -C This array contains the imaginary parts of the poles of -C the transfer function matrix G, stored in the same way as -C the poles. -C -C GAINS (output) DOUBLE PRECISION array, dimension (LDGAIN,M) -C The leading P-by-M part of this array contains the gains -C of the transfer function matrix G. Specifically, -C GAINS(i,j) contains the gain of the transfer function -C G(i,j). -C -C LDGAIN INTEGER -C The leading dimension of array GAINS. LDGAIN >= max(1,P). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the -C controllability of a single-input system (A,b) or (A',c'), -C where b and c' are columns in B and C' (C transposed). If -C the user sets TOL > 0, then the given value of TOL is used -C as an absolute tolerance; elements with absolute value -C less than TOL are considered neglijible. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used -C instead, where EPS is the machine precision (see LAPACK -C Library routine DLAMCH), and bc denotes the currently used -C column in B or C' (see METHOD). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N*(N+P) + -C MAX( N + MAX( N,P ), N*(2*N+3))) -C If N >= P, N >= 1, the formula above can be written as -C LDWORK >= N*(3*N + P + 3). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: the QR algorithm failed to converge when trying to -C compute the zeros of a transfer function; -C = 2: the QR algorithm failed to converge when trying to -C compute the poles of a transfer function. -C The errors INFO = 1 or 2 are unlikely to appear. -C -C METHOD -C -C The routine implements the pole-zero method proposed in [1]. -C This method is based on an algorithm for computing the transfer -C function of a single-input single-output (SISO) system. -C Let (A,b,c,d) be a SISO system. Its transfer function is computed -C as follows: -C -C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). -C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). -C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). -C 4) Compute the zeros of (Ao,bo,co,d). -C 5) Compute the gain of (Ao,bo,co,d). -C -C This algorithm can be implemented using only orthogonal -C transformations [1]. However, for better efficiency, the -C implementation in TB04CD uses one elementary transformation -C in Step 4 and r elementary transformations in Step 5 (to reduce -C an upper Hessenberg matrix to upper triangular form). These -C special elementary transformations are numerically stable -C in practice. -C -C In the multi-input multi-output (MIMO) case, the algorithm -C computes each element (i,j) of the transfer function matrix G, -C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 -C is performed once for each value of j (each column of B). The -C matrices Ac and Ao result in Hessenberg form. -C -C REFERENCES -C -C [1] Varga, A. and Sima, V. -C Numerically Stable Algorithm for Transfer Function Matrix -C Evaluation. -C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically stable in practice and requires about -C 20*N**3 floating point operations at most, but usually much less. -C -C CONTRIBUTORS -C -C V. Sima, Research Institute for Informatics, Bucharest, May 2002. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, state-space representation, transfer function, zeros. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, C100 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOBD - DOUBLE PRECISION TOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ, - $ LDWORK, M, N, NPZ, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), GAINS(LDGAIN,*), POLESI(*), - $ POLESR(*), ZEROSI(*), ZEROSR(*) - INTEGER IWORK(*), NP(LDNP,*), NZ(LDNZ,*) -C .. Local Scalars .. - DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF - INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IM, IP, - $ IPM1, ITAU, ITAU1, IZ, J, JWK, JWORK, JWORK1, - $ K, NCONT, WRKOPT - LOGICAL DIJNZ, FNDEIG, WITHD -C .. Local Arrays .. - DOUBLE PRECISION Z(1) -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, TB01ID, - $ TB01ZD, TB04BX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, MAX, MIN -C .. -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - INFO = 0 - WITHD = LSAME( JOBD, 'D' ) - IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN - INFO = -1 - ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. - $ LSAME( EQUIL, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( NPZ.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN - INFO = -14 - ELSE IF( LDNZ.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( LDNP.LT.MAX( 1, P ) ) THEN - INFO = -18 - ELSE IF( LDGAIN.LT.MAX( 1, P ) ) THEN - INFO = -24 - ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + - $ MAX( N + MAX( N, P ), N*( 2*N + 3 ) ) ) - $ ) THEN - INFO = -28 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TB04CD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - DIJ = ZERO - IF( MIN( N, P, M ).EQ.0 ) THEN - IF( MIN( P, M ).GT.0 ) THEN -C - DO 20 J = 1, M -C - DO 10 I = 1, P - NZ(I,J) = 0 - NP(I,J) = 0 - IF ( WITHD ) - $ DIJ = D(I,J) - GAINS(I,J) = DIJ - 10 CONTINUE -C - 20 CONTINUE -C - END IF - DWORK(1) = ONE - RETURN - END IF -C -C Prepare the computation of the default tolerance. -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN - EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) - ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) - END IF -C -C Initializations. -C - IA = 1 - IC = IA + N*N - ITAU = IC + P*N - JWORK = ITAU + N - IAC = ITAU -C - K = 1 -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance.) -C - IF( LSAME( EQUIL, 'S' ) ) THEN -C -C Scale simultaneously the matrices A, B and C: -C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a -C diagonal scaling matrix. -C Workspace: need N. -C - MAXRED = C100 - CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, - $ DWORK, IERR ) - END IF -C -C Compute the transfer function matrix of the system (A,B,C,D), -C in the pole-zero-gain form. -C - DO 80 J = 1, M -C -C Save A and C. -C Workspace: need W1 = N*(N+P). -C - CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) - CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) -C -C Remove the uncontrollable part of the system (A,B(J),C). -C Workspace: need W1+N+MAX(N,P); -C prefer larger. -C - CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, - $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), - $ LDWORK-JWORK+1, IERR ) - IF ( J.EQ.1 ) - $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 -C - IB = IAC + NCONT*NCONT - ICC = IB + NCONT - ITAU1 = ICC + NCONT - JWK = ITAU1 + NCONT - IAS = ITAU1 - JWORK1 = IAS + NCONT*NCONT -C - DO 70 I = 1, P - IF ( NCONT.GT.0 ) THEN - IF ( WITHD ) - $ DIJ = D(I,J) -C -C Form the matrices of the state-space representation of -C the dual system for the controllable part. -C Workspace: need W2 = W1+N*(N+2). -C - CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, - $ DWORK(IAC), NCONT ) - CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) - CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) -C -C Remove the unobservable part of the system (A,B(J),C(I)). -C Workspace: need W2+2*N; -C prefer larger. -C - CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, - $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, - $ DWORK(ITAU1), TOL, DWORK(JWK), LDWORK-JWK+1, - $ IERR ) - IF ( I.EQ.1 ) - $ WRKOPT = MAX( WRKOPT, INT( DWORK(JWK) ) + JWK - 1 ) -C - IF ( IP.GT.0 ) THEN -C -C Save the state matrix of the minimal part. -C Workspace: need W3 = W2+N*N. -C - CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, - $ DWORK(IAS), IP ) -C -C Compute the poles of the transfer function. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, - $ DWORK(IAC), NCONT, POLESR(K), POLESI(K), - $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, - $ IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 2 - RETURN - END IF - WRKOPT = MAX( WRKOPT, - $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) -C -C Compute the zeros of the transfer function. -C - IPM1 = IP - 1 - DIJNZ = WITHD .AND. DIJ.NE.ZERO - FNDEIG = DIJNZ .OR. IPM1.GT.0 - IF ( .NOT.FNDEIG ) THEN - IZ = 0 - ELSE IF ( DIJNZ ) THEN -C -C Add the contribution due to D(i,j). -C Note that the matrix whose eigenvalues have to -C be computed remains in an upper Hessenberg form. -C - IZ = IP - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, - $ DWORK(IAC), NCONT ) - CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, - $ DWORK(IAC), NCONT ) - ELSE - IF( TOL.LE.ZERO ) - $ TOLDEF = EPSN*MAX( ANORM, - $ DLANGE( 'Frobenius', IP, 1, - $ DWORK(IB), 1, DWORK ) - $ ) -C - DO 30 IM = 1, IPM1 - IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 - 30 CONTINUE -C - IZ = 0 - GO TO 50 -C - 40 CONTINUE -C -C Restore (part of) the saved state matrix. -C - IZ = IP - IM - CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), - $ IP, DWORK(IAC), NCONT ) -C -C Apply the output injection. -C - CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ - $ DWORK(IB+IM-1), DWORK(IB+IM), 1, - $ DWORK(IAC), NCONT ) - END IF -C - IF ( FNDEIG ) THEN -C -C Find the zeros. -C Workspace: need W3+N; -C prefer larger. -C - CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, - $ IZ, DWORK(IAC), NCONT, ZEROSR(K), - $ ZEROSI(K), Z, 1, DWORK(JWORK1), - $ LDWORK-JWORK1+1, IERR ) - IF ( IERR.NE.0 ) THEN - INFO = 1 - RETURN - END IF - END IF -C -C Compute the gain. -C - 50 CONTINUE - IF ( DIJNZ ) THEN - GAINS(I,J) = DIJ - ELSE - CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), - $ DWORK(IB), DIJ, POLESR(K), POLESI(K), - $ ZEROSR(K), ZEROSI(K), GAINS(I,J), - $ IWORK ) - END IF - NZ(I,J) = IZ - NP(I,J) = IP - ELSE -C -C Null element. -C - NZ(I,J) = 0 - NP(I,J) = 0 - END IF -C - ELSE -C -C Null element. -C - NZ(I,J) = 0 - NP(I,J) = 0 - END IF -C - K = K + NPZ - 70 CONTINUE -C - 80 CONTINUE -C - RETURN -C *** Last line of TB04CD *** - END diff --git a/slycot/src/TB05AD.f b/slycot/src/TB05AD.f deleted file mode 100644 index 55490b84..00000000 --- a/slycot/src/TB05AD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB, - $ C, LDC, RCOND, G, LDG, EVRE, EVIM, HINVB, - $ LDHINV, IWORK, DWORK, LDWORK, ZWORK, LZWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the complex frequency response matrix (transfer matrix) -C G(freq) of the state-space representation (A,B,C) given by -C -1 -C G(freq) = C * ((freq*I - A) ) * B -C -C where A, B and C are real N-by-N, N-by-M and P-by-N matrices -C respectively and freq is a complex scalar. -C -C ARGUMENTS -C -C Mode Parameters -C -C BALEIG CHARACTER*1 -C Determines whether the user wishes to balance matrix A -C and/or compute its eigenvalues and/or estimate the -C condition number of the problem as follows: -C = 'N': The matrix A should not be balanced and neither -C the eigenvalues of A nor the condition number -C estimate of the problem are to be calculated; -C = 'C': The matrix A should not be balanced and only an -C estimate of the condition number of the problem -C is to be calculated; -C = 'B' or 'E' and INITA = 'G': The matrix A is to be -C balanced and its eigenvalues calculated; -C = 'A' and INITA = 'G': The matrix A is to be balanced, -C and its eigenvalues and an estimate of the -C condition number of the problem are to be -C calculated. -C -C INITA CHARACTER*1 -C Specifies whether or not the matrix A is already in upper -C Hessenberg form as follows: -C = 'G': The matrix A is a general matrix; -C = 'H': The matrix A is in upper Hessenberg form and -C neither balancing nor the eigenvalues of A are -C required. -C INITA must be set to 'G' for the first call to the -C routine, unless the matrix A is already in upper -C Hessenberg form and neither balancing nor the eigenvalues -C of A are required. Thereafter, it must be set to 'H' for -C all subsequent calls. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The number of states, i.e. the order of the state -C transition matrix A. N >= 0. -C -C M (input) INTEGER -C The number of inputs, i.e. the number of columns in the -C matrix B. M >= 0. -C -C P (input) INTEGER -C The number of outputs, i.e. the number of rows in the -C matrix C. P >= 0. -C -C FREQ (input) COMPLEX*16 -C The frequency freq at which the frequency response matrix -C (transfer matrix) is to be evaluated. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state transition matrix A. -C If INITA = 'G', then, on exit, the leading N-by-N part of -C this array contains an upper Hessenberg matrix similar to -C (via an orthogonal matrix consisting of a sequence of -C Householder transformations) the original state transition -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix B. -C If INITA = 'G', then, on exit, the leading N-by-M part of -C this array contains the product of the transpose of the -C orthogonal transformation matrix used to reduce A to upper -C Hessenberg form and the original input/state matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C If INITA = 'G', then, on exit, the leading P-by-N part of -C this array contains the product of the original output/ -C state matrix C and the orthogonal transformation matrix -C used to reduce A to upper Hessenberg form. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C RCOND (output) DOUBLE PRECISION -C If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an -C estimate of the reciprocal of the condition number of -C matrix H with respect to inversion (see METHOD). -C -C G (output) COMPLEX*16 array, dimension (LDG,M) -C The leading P-by-M part of this array contains the -C frequency response matrix G(freq). -C -C LDG INTEGER -C The leading dimension of array G. LDG >= MAX(1,P). -C -C EVRE, (output) DOUBLE PRECISION arrays, dimension (N) -C EVIM If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A', -C then these arrays contain the real and imaginary parts, -C respectively, of the eigenvalues of the matrix A. -C Otherwise, these arrays are not referenced. -C -C HINVB (output) COMPLEX*16 array, dimension (LDHINV,M) -C The leading N-by-M part of this array contains the -C -1 -C product H B. -C -C LDHINV INTEGER -C The leading dimension of array HINVB. LDHINV >= MAX(1,N). -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N - 1 + MAX(N,M,P)), -C if INITA = 'G' and BALEIG = 'N', or 'B', or 'E'; -C LDWORK >= MAX(1, N + MAX(N,M-1,P-1)), -C if INITA = 'G' and BALEIG = 'C', or 'A'; -C LDWORK >= MAX(1, 2*N), -C if INITA = 'H' and BALEIG = 'C', or 'A'; -C LDWORK >= 1, otherwise. -C For optimum performance when INITA = 'G' LDWORK should be -C larger. -C -C ZWORK COMPLEX*16 array, dimension (LZWORK) -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A'; -C LZWORK >= MAX(1,N*N), otherwise. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if more than 30*N iterations are required to -C isolate all the eigenvalues of the matrix A; the -C computations are continued; -C = 2: if either FREQ is too near to an eigenvalue of the -C matrix A, or RCOND is less than EPS, where EPS is -C the machine precision (see LAPACK Library routine -C DLAMCH). -C -C METHOD -C -C The matrix A is first balanced (if BALEIG = 'B' or 'E', or -C BALEIG = 'A') and then reduced to upper Hessenberg form; the same -C transformations are applied to the matrix B and the matrix C. -C The complex Hessenberg matrix H = (freq*I - A) is then used -C -1 -C to solve for C * H * B. -C -C Depending on the input values of parameters BALEIG and INITA, -C the eigenvalues of matrix A and the condition number of -C matrix H with respect to inversion are also calculated. -C -C REFERENCES -C -C [1] Laub, A.J. -C Efficient Calculation of Frequency Response Matrices from -C State-Space Models. -C ACM TOMS, 12, pp. 26-33, 1986. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TB01FD by A.J.Laub, University of -C Southern California, Los Angeles, CA 90089, United States of -C America, June 1982. -C -C REVISIONS -C -C V. Sima, February 22, 1998 (changed the name of TB01RD). -C V. Sima, February 12, 1999, August 7, 2003. -C A. Markovski, Technical University of Sofia, September 30, 2003. -C V. Sima, October 1, 2003. -C -C KEYWORDS -C -C Frequency response, Hessenberg form, matrix algebra, input output -C description, multivariable system, orthogonal transformation, -C similarity transformation, state-space representation, transfer -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) - COMPLEX*16 CZERO - PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) -C .. Scalar Arguments .. - CHARACTER BALEIG, INITA - INTEGER INFO, LDA, LDB, LDC, LDG, LDHINV, LDWORK, - $ LZWORK, M, N, P - DOUBLE PRECISION RCOND - COMPLEX*16 FREQ -C .. Array Arguments .. - INTEGER IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), EVIM(*), - $ EVRE(*) - COMPLEX*16 ZWORK(*), G(LDG,*), HINVB(LDHINV,*) -C .. Local Scalars .. - CHARACTER BALANC - LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA - INTEGER I, IGH, IJ, ITAU, J, JJ, JP, JWORK, K, LOW, - $ WRKOPT - DOUBLE PRECISION HNORM, T -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DASUM, DLAMCH - EXTERNAL DASUM, DLAMCH, LSAME -C .. External Subroutines .. - EXTERNAL DGEBAL, DGEHRD, DHSEQR, DORMHR, DSCAL, DSWAP, - $ MB02RZ, MB02SZ, MB02TZ, XERBLA, ZLASET -C .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, INT, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LBALEC = LSAME( BALEIG, 'C' ) - LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) - LBALEA = LSAME( BALEIG, 'A' ) - LBALBA = LBALEB.OR.LBALEA - LINITA = LSAME( INITA, 'G' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LBALEC .AND. .NOT.LBALBA .AND. - $ .NOT.LSAME( BALEIG, 'N' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LINITA .AND. .NOT.LSAME( INITA, 'H' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDG.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( LDHINV.LT.MAX( 1, N ) ) THEN - INFO = -19 - ELSE IF( ( LINITA .AND. .NOT.LBALEC .AND. .NOT.LBALEA .AND. - $ LDWORK.LT.N - 1 + MAX( N, M, P ) ) .OR. - $ ( LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. - $ LDWORK.LT.N + MAX( N, M-1, P-1 ) ) .OR. - $ ( .NOT.LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. - $ LDWORK.LT.2*N ) .OR. ( LDWORK.LT.1 ) ) THEN - INFO = -22 - ELSE IF( ( ( LBALEC .OR. LBALEA ) .AND. LZWORK.LT.N*( N + 2 ) ) - $ .OR. ( LZWORK.LT.MAX( 1, N*N ) ) ) THEN - INFO = -24 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return -C - CALL XERBLA( 'TB05AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( N.EQ.0 ) THEN - IF ( MIN( M, P ).GT.0 ) - $ CALL ZLASET( 'Full', P, M, CZERO, CZERO, G, LDG ) - RCOND = ONE - DWORK(1) = ONE - RETURN - END IF -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - WRKOPT = 1 -C - IF ( LINITA ) THEN - BALANC = 'N' - IF ( LBALBA ) BALANC = 'B' -C -C Workspace: need N. -C - CALL DGEBAL( BALANC, N, A, LDA, LOW, IGH, DWORK, INFO ) - IF ( LBALBA ) THEN -C -C Adjust B and C matrices based on information in the -C vector DWORK which describes the balancing of A and is -C defined in the subroutine DGEBAL. -C - DO 10 J = 1, N - JJ = N + 1 - J ! RvP, rabraker, slycot #11 - IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN - IF ( JJ.LT.LOW ) JJ = LOW - JJ - JP = INT( DWORK(JJ) ) - IF ( JP.NE.JJ ) THEN -C -C Permute rows of B. -C - IF ( M.GT.0 ) - $ CALL DSWAP( M, B(JJ,1), LDB, B(JP,1), LDB ) -C -C Permute columns of C. -C - IF ( P.GT.0 ) - $ CALL DSWAP( P, C(1,JJ), 1, C(1,JP), 1 ) - END IF - END IF - 10 CONTINUE -C - IF ( IGH.NE.LOW ) THEN -C - DO 20 J = LOW, IGH - T = DWORK(J) -C -C Scale rows of permuted B. -C - IF ( M.GT.0 ) - $ CALL DSCAL( M, ONE/T, B(J,1), LDB ) -C -C Scale columns of permuted C. -C - IF ( P.GT.0 ) - $ CALL DSCAL( P, T, C(1,J), 1 ) - 20 CONTINUE -C - END IF - END IF -C -C Reduce A to Hessenberg form by orthogonal similarities and -C accumulate the orthogonal transformations into B and C. -C Workspace: need 2*N - 1; prefer N - 1 + N*NB. -C - ITAU = 1 - JWORK = ITAU + N - 1 - CALL DGEHRD( N, LOW, IGH, A, LDA, DWORK(ITAU), DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need N - 1 + M; prefer N - 1 + M*NB. -C - CALL DORMHR( 'Left', 'Transpose', N, M, LOW, IGH, A, LDA, - $ DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) -C -C Workspace: need N - 1 + P; prefer N - 1 + P*NB. -C - CALL DORMHR( 'Right', 'No transpose', P, N, LOW, IGH, A, LDA, - $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - IF ( LBALBA ) THEN -C -C Temporarily store Hessenberg form of A in array ZWORK. -C - IJ = 0 - DO 40 J = 1, N -C - DO 30 I = 1, N - IJ = IJ + 1 - ZWORK(IJ) = DCMPLX( A(I,J), ZERO ) - 30 CONTINUE -C - 40 CONTINUE -C -C Compute the eigenvalues of A if that option is requested. -C Workspace: need N. -C - CALL DHSEQR( 'Eigenvalues', 'No Schur', N, LOW, IGH, A, LDA, - $ EVRE, EVIM, DWORK, 1, DWORK, LDWORK, INFO ) -C -C Restore upper Hessenberg form of A. -C - IJ = 0 - DO 60 J = 1, N -C - DO 50 I = 1, N - IJ = IJ + 1 - A(I,J) = DBLE( ZWORK(IJ) ) - 50 CONTINUE -C - 60 CONTINUE -C - IF ( INFO.GT.0 ) THEN -C -C DHSEQR could not evaluate the eigenvalues of A. -C - INFO = 1 - END IF - END IF - END IF -C -C Update H := (FREQ * I) - A with appropriate value of FREQ. -C - IJ = 0 - JJ = 1 - DO 80 J = 1, N -C - DO 70 I = 1, N - IJ = IJ + 1 - ZWORK(IJ) = -DCMPLX( A(I,J), ZERO ) - 70 CONTINUE -C - ZWORK(JJ) = FREQ + ZWORK(JJ) - JJ = JJ + N + 1 - 80 CONTINUE -C - IF ( LBALEC .OR. LBALEA ) THEN -C -C Efficiently compute the 1-norm of the matrix for condition -C estimation. -C - HNORM = ZERO - JJ = 1 -C - DO 90 J = 1, N - T = ABS( ZWORK(JJ) ) + DASUM( J-1, A(1,J), 1 ) - IF ( J.LT.N ) T = T + ABS( A(J+1,J) ) - HNORM = MAX( HNORM, T ) - JJ = JJ + N + 1 - 90 CONTINUE -C - END IF -C -C Factor the complex Hessenberg matrix. -C - CALL MB02SZ( N, ZWORK, N, IWORK, INFO ) - IF ( INFO.NE.0 ) INFO = 2 -C - IF ( LBALEC .OR. LBALEA ) THEN -C -C Estimate the condition of the matrix. -C -C Workspace: need 2*N. -C - CALL MB02TZ( '1-norm', N, HNORM, ZWORK, N, IWORK, RCOND, DWORK, - $ ZWORK(N*N+1), INFO ) - WRKOPT = MAX( WRKOPT, 2*N ) - IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) INFO = 2 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return: Linear system is numerically or exactly singular. -C - RETURN - END IF -C -C Compute (H-INVERSE)*B. -C - DO 110 J = 1, M -C - DO 100 I = 1, N - HINVB(I,J) = DCMPLX( B(I,J), ZERO ) - 100 CONTINUE -C - 110 CONTINUE -C - CALL MB02RZ( 'No transpose', N, M, ZWORK, N, IWORK, HINVB, LDHINV, - $ INFO ) -C -C Compute C*(H-INVERSE)*B. -C - DO 150 J = 1, M -C - DO 120 I = 1, P - G(I,J) = CZERO - 120 CONTINUE -C - DO 140 K = 1, N -C - DO 130 I = 1, P - G(I,J) = G(I,J) + DCMPLX( C(I,K), ZERO )*HINVB(K,J) - 130 CONTINUE -C - 140 CONTINUE -C - 150 CONTINUE -C -C G now contains the desired frequency response matrix. -C Set the optimal workspace. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TB05AD *** - END diff --git a/slycot/src/TC01OD.f b/slycot/src/TC01OD.f deleted file mode 100644 index 3e7bd25a..00000000 --- a/slycot/src/TC01OD.f +++ /dev/null @@ -1,236 +0,0 @@ - SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find the dual right (left) polynomial matrix representation of -C a given left (right) polynomial matrix representation, where the -C right and left polynomial matrix representations are of the form -C Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively. -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether a left or right matrix fraction is input -C as follows: -C = 'L': A left matrix fraction is input; -C = 'R': A right matrix fraction is input. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDLIM (input) INTEGER -C The highest value of K for which PCOEFF(.,.,K) and -C QCOEFF(.,.,K) are to be transposed. -C K = kpcoef + 1, where kpcoef is the maximum degree of the -C polynomials in P(s). INDLIM >= 1. -C -C PCOEFF (input/output) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,INDLIM) -C If LERI = 'L' then porm = P, otherwise porm = M. -C On entry, the leading porm-by-porm-by-INDLIM part of this -C array must contain the coefficients of the denominator -C matrix P(s). -C PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of -C polynomial (I,J) of P(s), where K = 1,2,...,INDLIM. -C On exit, the leading porm-by-porm-by-INDLIM part of this -C array contains the coefficients of the denominator matrix -C P'(s) of the dual system. -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P) if LERI = 'L', -C LDPCO1 >= MAX(1,M) if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P) if LERI = 'L', -C LDPCO2 >= MAX(1,M) if LERI = 'R'. -C -C QCOEFF (input/output) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,INDLIM) -C On entry, the leading P-by-M-by-INDLIM part of this array -C must contain the coefficients of the numerator matrix -C Q(s). -C QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of -C polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM. -C On exit, the leading M-by-P-by-INDLIM part of the array -C contains the coefficients of the numerator matrix Q'(s) -C of the dual system. -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,M,P). -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M,P). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C If the given M-input/P-output left (right) polynomial matrix -C representation has numerator matrix Q(s) and denominator matrix -C P(s), its dual P-input/M-output right (left) polynomial matrix -C representation simply has numerator matrix Q'(s) and denominator -C matrix P'(s). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TC01CD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER LERI - INTEGER INFO, INDLIM, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, - $ P -C .. Array Arguments .. - DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,*), QCOEFF(LDQCO1,LDQCO2,*) -C .. Local Scalars .. - LOGICAL LLERI - INTEGER J, K, MINMP, MPLIM, PORM -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LLERI = LSAME( LERI, 'L' ) - MPLIM = MAX( M, P ) - MINMP = MIN( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( INDLIM.LT.1 ) THEN - INFO = -4 - ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN - INFO = -6 - ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF( LDQCO1.LT.MAX( 1, MPLIM ) ) THEN - INFO = -9 - ELSE IF( LDQCO2.LT.MAX( 1, MPLIM ) ) THEN - INFO = -10 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TC01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 .OR. P.EQ.0 ) - $ RETURN -C - IF ( MPLIM.NE.1 ) THEN -C -C Non-scalar system: transpose numerator matrix Q(s). -C - DO 20 K = 1, INDLIM -C - DO 10 J = 1, MPLIM - IF ( J.LT.MINMP ) THEN - CALL DSWAP( MINMP-J, QCOEFF(J+1,J,K), 1, - $ QCOEFF(J,J+1,K), LDQCO1 ) - ELSE IF ( J.GT.P ) THEN - CALL DCOPY( P, QCOEFF(1,J,K), 1, QCOEFF(J,1,K), - $ LDQCO1 ) - ELSE IF ( J.GT.M ) THEN - CALL DCOPY( M, QCOEFF(J,1,K), LDQCO1, QCOEFF(1,J,K), - $ 1 ) - END IF - 10 CONTINUE -C - 20 CONTINUE -C -C Find dimension of denominator matrix P(s): M (P) for -C right (left) polynomial matrix representation. -C - PORM = M - IF ( LLERI ) PORM = P - IF ( PORM.NE.1 ) THEN -C -C Non-scalar P(s): transpose it. -C - DO 40 K = 1, INDLIM -C - DO 30 J = 1, PORM - 1 - CALL DSWAP( PORM-J, PCOEFF(J+1,J,K), 1, - $ PCOEFF(J,J+1,K), LDPCO1 ) - 30 CONTINUE -C - 40 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TC01OD *** - END diff --git a/slycot/src/TC04AD.f b/slycot/src/TC04AD.f deleted file mode 100644 index d0ce99d1..00000000 --- a/slycot/src/TC04AD.f +++ /dev/null @@ -1,483 +0,0 @@ - SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B, - $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a state-space representation (A,B,C,D) with the same -C transfer matrix T(s) as that of a given left or right polynomial -C matrix representation, i.e. -C -C C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)). -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether a left polynomial matrix representation -C or a right polynomial matrix representation is input as -C follows: -C = 'L': A left matrix fraction is input; -C = 'R': A right matrix fraction is input. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDEX (input) INTEGER array, dimension (MAX(M,P)) -C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the -C maximum degree of the polynomials in the I-th row of the -C denominator matrix P(s) of the given left polynomial -C matrix representation. -C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the -C maximum degree of the polynomials in the I-th column of -C the denominator matrix P(s) of the given right polynomial -C matrix representation. -C -C PCOEFF (input) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. -C If LERI = 'L' then porm = P, otherwise porm = M. -C The leading porm-by-porm-by-kpcoef part of this array must -C contain the coefficients of the denominator matrix P(s). -C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if -C LERI = 'L' then iorj = I, otherwise iorj = J. -C Thus for LERI = 'L', P(s) = -C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C If LERI = 'R', PCOEFF is modified by the routine but -C restored on exit. -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P) if LERI = 'L', -C LDPCO1 >= MAX(1,M) if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P) if LERI = 'L', -C LDPCO2 >= MAX(1,M) if LERI = 'R'. -C -C QCOEFF (input) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,kpcoef) -C If LERI = 'L' then porp = M, otherwise porp = P. -C The leading porm-by-porp-by-kpcoef part of this array must -C contain the coefficients of the numerator matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C If LERI = 'R', QCOEFF is modified by the routine but -C restored on exit. -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,P) if LERI = 'L', -C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M) if LERI = 'L', -C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. -C -C N (output) INTEGER -C The order of the resulting state-space representation. -C porm -C That is, N = SUM INDEX(I). -C I=1 -C -C RCOND (output) DOUBLE PRECISION -C The estimated reciprocal of the condition number of the -C leading row (if LERI = 'L') or the leading column (if -C LERI = 'R') coefficient matrix of P(s). -C If RCOND is nearly zero, P(s) is nearly row or column -C non-proper. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array contains the state -C dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) -C The leading N-by-M part of this array contains the -C input/state matrix B; the remainder of the leading -C N-by-MAX(M,P) part is used as internal workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array contains the -C state/output matrix C; the remainder of the leading -C MAX(M,P)-by-N part is used as internal workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array contains the direct -C transmission matrix D; the remainder of the leading -C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C Workspace -C -C IWORK INTEGER array, dimension (2*MAX(M,P)) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if P(s) is not row (if LERI = 'L') or column -C (if LERI = 'R') proper. Consequently, no state-space -C representation is calculated. -C -C METHOD -C -C The method for a left matrix fraction will be described here; -C right matrix fractions are dealt with by obtaining the dual left -C polynomial matrix representation and constructing an equivalent -C state-space representation for this. The first step is to check -C if the denominator matrix P(s) is row proper; if it is not then -C the routine returns with the Error Indicator (INFO) set to 1. -C Otherwise, Wolovich's Observable Structure Theorem is used to -C construct a state-space representation (A,B,C,D) in observable -C companion form. The sizes of the blocks of matrix A and matrix C -C here are precisely the row degrees of P(s), while their -C 'non-trivial' columns are given easily from its coefficients. -C Similarly, the matrix D is obtained from the leading coefficients -C of P(s) and of the numerator matrix Q(s), while matrix B is given -C by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a -C polynomial matrix whose (j,k)(th) element is given by -C -C j-u(k-1)-1 -C ( s , j = u(k-1)+1,u(k-1)+2,....,u(k) -C Sbar = ( -C j,k ( 0 , otherwise -C -C k -C u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d are the -C i=1 i 1 2 M -C controllability indices. For convenience in solving this, C' and B -C are initially set up to contain the coefficients of P(s) and Q(s), -C respectively, stored by rows. -C -C REFERENCES -C -C [1] Wolovich, W.A. -C Linear Multivariate Systems, (Theorem 4.3.3). -C Springer-Verlag, 1974. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C February 22, 1998 (changed the name of TC01ND). -C May 12, 1998. -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER LERI - INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, - $ LDQCO1, LDQCO2, LDWORK, M, N, P - DOUBLE PRECISION RCOND -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*) -C .. Local Scalars .. - LOGICAL LLERI - INTEGER I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K, - $ KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK, - $ WRKOPT - DOUBLE PRECISION DWNORM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL LSAME, DLAMCH, DLANGE -C .. External Subroutines .. - EXTERNAL AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI, - $ DGETRS, DLACPY, DLASET, TC01OD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C .. Executable Statements .. -C - INFO = 0 - LLERI = LSAME( LERI, 'L' ) - MINDEX = MAX( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN - INFO = -6 - ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN - INFO = -9 - ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN - INFO = -10 - END IF -C - N = 0 - IF ( INFO.EQ.0 ) THEN - IF ( LLERI ) THEN - PWORK = P - MWORK = M - ELSE - PWORK = M - MWORK = P - END IF -C - MAXIND = 0 - DO 10 I = 1, PWORK - N = N + INDEX(I) - IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) - 10 CONTINUE - KPCOEF = MAXIND + 1 - END IF -C - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN - INFO = -18 - ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN - INFO = -20 - ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN - INFO = -23 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TC04AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 .OR. P.EQ.0 ) THEN - N = 0 - RCOND = ONE - DWORK(1) = ONE - RETURN - END IF -C - IF ( .NOT.LLERI ) THEN -C -C Initialization for right matrix fraction: obtain the dual -C system. -C - CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) - END IF -C -C Store leading row coefficient matrix of P(s). -C - LDW = MAX( 1, PWORK ) - CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW ) -C -C Check if P(s) is row proper: if not, exit. -C - DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK ) -C - CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO ) -C -C Workspace: need PWORK*(PWORK + 4). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C - JWORK = LDW*PWORK + 1 -C - CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND, - $ DWORK(JWORK), IWORK(PWORK+1), INFO ) -C - WRKOPT = MAX( 1, PWORK*(PWORK + 4) ) -C - IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN -C -C Error return: P(s) is not row proper. -C - INFO = 1 - RETURN - ELSE -C -C Calculate the order of equivalent state-space representation, -C and initialize A. -C - CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) -C - DWORK(JWORK) = ONE - IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 ) -C -C Find the PWORK ordered 'non-trivial' columns row by row, -C in PWORK row blocks, the I-th having INDEX(I) rows. -C - IBIAS = 2 -C - DO 50 I = 1, PWORK - KSTOP = INDEX(I) + 1 - IF ( KSTOP.NE.1 ) THEN - IBIAS = IBIAS + INDEX(I) -C -C These rows given from the lower coefficients of row I -C of P(s). -C - DO 40 K = 2, KSTOP - IA = IBIAS - K -C - DO 20 J = 1, PWORK - DWORK(JWORK+J-1) = -PCOEFF(I,J,K) - 20 CONTINUE -C - CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW, - $ IWORK, DWORK(JWORK), LDW, INFO ) -C - JA = 0 -C - DO 30 J = 1, PWORK - IF ( INDEX(J).NE.0 ) THEN - JA = JA + INDEX(J) - A(IA,JA) = DWORK(JWORK+J-1) - END IF - 30 CONTINUE -C -C Also, set up B and C (temporarily) for use when -C finding B. -C - CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1), - $ LDB ) - CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 ) - 40 CONTINUE -C - END IF - 50 CONTINUE -C -C Calculate D from the leading coefficients of P and Q. -C - CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD ) -C - CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK, - $ D, LDD, INFO ) -C -C For B and C as set up above, desired B = B - (C' * D). -C - CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE, - $ C, LDC, D, LDD, ONE, B, LDB ) -C -C Finally, calculate C: zero, apart from ... -C - CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) -C -C PWORK ordered 'non-trivial' columns, equal to those -C of inv(DWORK). -C -C Workspace: need PWORK*(PWORK + 1); -C prefer PWORK*PWORK + PWORK*NB. -C - CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK), - $ LDWORK-JWORK+1, INFO ) -C - WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) - JC = 0 - JW = 1 -C - DO 60 J = 1, PWORK - IF ( INDEX(J).NE.0 ) THEN - JC = JC + INDEX(J) - CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 ) - END IF - JW = JW + LDW - 60 CONTINUE -C - END IF -C -C For right matrix fraction, return to original (dual of dual) -C system. -C - IF ( .NOT.LLERI ) THEN - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) -C -C Also, obtain dual of state-space representation. -C - CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO ) - END IF -C -C Set optimal workspace dimension. -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TC04AD *** - END diff --git a/slycot/src/TC05AD.f b/slycot/src/TC05AD.f deleted file mode 100644 index fc9f65ab..00000000 --- a/slycot/src/TC05AD.f +++ /dev/null @@ -1,403 +0,0 @@ - SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, - $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To evaluate the transfer matrix T(s) of a left polynomial matrix -C representation [T(s) = inv(P(s))*Q(s)] or a right polynomial -C matrix representation [T(s) = Q(s)*inv(P(s))] at any specified -C complex frequency s = SVAL. -C -C This routine will calculate the standard frequency response -C matrix at frequency omega if SVAL is supplied as (0.0,omega). -C -C ARGUMENTS -C -C Mode Parameters -C -C LERI CHARACTER*1 -C Indicates whether a left polynomial matrix representation -C or a right polynomial matrix representation is to be used -C to evaluate the transfer matrix as follows: -C = 'L': A left matrix fraction is input; -C = 'R': A right matrix fraction is input. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C SVAL (input) COMPLEX*16 -C The frequency at which the transfer matrix or the -C frequency respose matrix is to be evaluated. -C For a standard frequency response set the real part -C of SVAL to zero. -C -C INDEX (input) INTEGER array, dimension (MAX(M,P)) -C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the -C maximum degree of the polynomials in the I-th row of the -C denominator matrix P(s) of the given left polynomial -C matrix representation. -C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the -C maximum degree of the polynomials in the I-th column of -C the denominator matrix P(s) of the given right polynomial -C matrix representation. -C -C PCOEFF (input) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. -C If LERI = 'L' then porm = P, otherwise porm = M. -C The leading porm-by-porm-by-kpcoef part of this array must -C contain the coefficients of the denominator matrix P(s). -C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if -C LERI = 'L' then iorj = I, otherwise iorj = J. -C Thus for LERI = 'L', P(s) = -C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C If LERI = 'R', PCOEFF is modified by the routine but -C restored on exit. -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P) if LERI = 'L', -C LDPCO1 >= MAX(1,M) if LERI = 'R'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P) if LERI = 'L', -C LDPCO2 >= MAX(1,M) if LERI = 'R'. -C -C QCOEFF (input) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,kpcoef) -C If LERI = 'L' then porp = M, otherwise porp = P. -C The leading porm-by-porp-by-kpcoef part of this array must -C contain the coefficients of the numerator matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C If LERI = 'R', QCOEFF is modified by the routine but -C restored on exit. -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C LDQCO1 >= MAX(1,P) if LERI = 'L', -C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C LDQCO2 >= MAX(1,M) if LERI = 'L', -C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. -C -C RCOND (output) DOUBLE PRECISION -C The estimated reciprocal of the condition number of the -C denominator matrix P(SVAL). -C If RCOND is nearly zero, SVAL is approximately a system -C pole. -C -C CFREQR (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P)) -C The leading porm-by-porp part of this array contains the -C frequency response matrix T(SVAL). -C -C LDCFRE INTEGER -C The leading dimension of array CFREQR. -C LDCFRE >= MAX(1,P) if LERI = 'L', -C LDCFRE >= MAX(1,M,P) if LERI = 'R'. -C -C Workspace -C -C IWORK INTEGER array, dimension (liwork) -C where liwork = P, if LERI = 'L', -C liwork = M, if LERI = 'R'. -C -C DWORK DOUBLE PRECISION array, dimension (ldwork) -C where ldwork = 2*P, if LERI = 'L', -C ldwork = 2*M, if LERI = 'R'. -C -C ZWORK COMPLEX*16 array, dimension (lzwork), -C where lzwork = P*(P+2), if LERI = 'L', -C lzwork = M*(M+2), if LERI = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if P(SVAL) is exactly or nearly singular; -C no frequency response is calculated. -C -C METHOD -C -C The method for a left matrix fraction will be described here; -C right matrix fractions are dealt with by obtaining the dual left -C fraction and calculating its frequency response (see SLICOT -C Library routine TC01OD). The first step is to calculate the -C complex value P(SVAL) of the denominator matrix P(s) at the -C desired frequency SVAL. If P(SVAL) is approximately singular, -C SVAL is approximately a pole of this system and so the frequency -C response matrix T(SVAL) is not calculated; in this case, the -C routine returns with the Error Indicator (INFO) set to 1. -C Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s) -C at frequency SVAL is calculated in a similar way to P(SVAL), and -C the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is -C found by solving the corresponding system of complex linear -C equations. -C -C REFERENCES -C -C None -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston -C Polytechnic, United Kingdom, March 1982. -C -C REVISIONS -C -C February 22, 1998 (changed the name of TC01MD). -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER LERI - INTEGER INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, - $ P - DOUBLE PRECISION RCOND - COMPLEX*16 SVAL -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*) - COMPLEX*16 CFREQR(LDCFRE,*), ZWORK(*) -C .. Local Scalars .. - LOGICAL LLERI - INTEGER I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR, - $ MAXIND, MINMP, MPLIM, MWORK, PWORK - DOUBLE PRECISION CNORM -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS, - $ ZSWAP -C .. Intrinsic Functions .. - INTRINSIC DCMPLX, MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LLERI = LSAME( LERI, 'L' ) - MPLIM = MAX( M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN - INFO = -7 - ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN - INFO = -8 - ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN - INFO = -10 - ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN - INFO = -11 - ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR. - $ ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TC05AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 .OR. P.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -C - IF ( LLERI ) THEN -C -C Initialization for left matrix fraction. -C - PWORK = P - MWORK = M - ELSE -C -C Initialization for right matrix fraction: obtain dual system. -C - PWORK = M - MWORK = P - IF ( MPLIM.GT.1 ) - $ CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) - END IF -C - LDZWOR = PWORK - IZWORK = LDZWOR*LDZWOR + 1 - MAXIND = 0 -C - DO 10 I = 1, PWORK - IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) - 10 CONTINUE -C - KPCOEF = MAXIND + 1 -C -C Calculate the complex denominator matrix P(SVAL), row by row. -C - DO 50 I = 1, PWORK - IJ = I -C - DO 20 J = 1, PWORK - ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO ) - IJ = IJ + PWORK - 20 CONTINUE -C -C Possibly non-constant row: finish evaluating it. -C - DO 40 K = 2, INDEX(I) + 1 -C - IJ = I -C - DO 30 J = 1, PWORK - ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) + - $ DCMPLX( PCOEFF(I,J,K), ZERO ) - IJ = IJ + PWORK - 30 CONTINUE -C - 40 CONTINUE -C - 50 CONTINUE -C -C Check if this P(SVAL) is singular: if so, don't compute T(SVAL). -C Note that DWORK is not actually referenced in ZLANGE routine. -C - CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK ) -C - CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO ) -C - IF ( INFO.GT.0 ) THEN -C -C Singular matrix. Set INFO and RCOND for error return. -C - INFO = 1 - RCOND = ZERO - ELSE -C -C Estimate the reciprocal condition of P(SVAL). -C Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK. -C - CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND, - $ ZWORK(IZWORK), DWORK, INFO ) -C - IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN -C -C Nearly singular matrix. Set INFO for error return. -C - INFO = 1 - ELSE -C -C Calculate the complex numerator matrix Q(SVAL), row by row. -C - DO 90 I = 1, PWORK -C - DO 60 J = 1, MWORK - CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO ) - 60 CONTINUE -C -C Possibly non-constant row: finish evaluating it. -C - DO 80 K = 2, INDEX(I) + 1 -C - DO 70 J = 1, MWORK - CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) + - $ DCMPLX( QCOEFF(I,J,K), ZERO ) - 70 CONTINUE -C - 80 CONTINUE -C - 90 CONTINUE -C -C Now calculate frequency response T(SVAL). -C - CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR, - $ IWORK, CFREQR, LDCFRE, INFO ) - END IF - END IF -C -C For right matrix fraction, return to original (dual of the dual) -C system. -C - IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 ) -C - IF ( INFO.EQ.0 ) THEN -C -C Also, transpose T(SVAL) here if this was successfully -C calculated. -C - MINMP = MIN( M, P ) -C - DO 100 J = 1, MPLIM - IF ( J.LT.MINMP ) THEN - CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1), - $ LDCFRE ) - ELSE IF ( J.GT.P ) THEN - CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE ) - ELSE IF ( J.GT.M ) THEN - CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 ) - END IF - 100 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TC05AD *** - END diff --git a/slycot/src/TD03AD.f b/slycot/src/TD03AD.f deleted file mode 100644 index b06678a7..00000000 --- a/slycot/src/TD03AD.f +++ /dev/null @@ -1,581 +0,0 @@ - SUBROUTINE TD03AD( ROWCOL, LERI, EQUIL, M, P, INDEXD, DCOEFF, - $ LDDCOE, UCOEFF, LDUCO1, LDUCO2, NR, A, LDA, B, - $ LDB, C, LDC, D, LDD, INDEXP, PCOEFF, LDPCO1, - $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, - $ LDVCO2, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a relatively prime left or right polynomial matrix -C representation for a proper transfer matrix T(s) given as either -C row or column polynomial vectors over common denominator -C polynomials, possibly with uncancelled common terms. -C -C ARGUMENTS -C -C Mode Parameters -C -C ROWCOL CHARACTER*1 -C Indicates whether T(s) is to be factorized by rows or by -C columns as follows: -C = 'R': T(s) is factorized by rows; -C = 'C': T(s) is factorized by columns. -C -C LERI CHARACTER*1 -C Indicates whether a left or a right polynomial matrix -C representation is required as follows: -C = 'L': A left polynomial matrix representation -C inv(P(s))*Q(s) is required; -C = 'R': A right polynomial matrix representation -C Q(s)*inv(P(s)) is required. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to balance the triplet -C (A,B,C), before computing a minimal state-space -C representation, as follows: -C = 'S': Perform balancing (scaling); -C = 'N': Do not perform balancing. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDEXD (input) INTEGER array, dimension (P), if ROWCOL = 'R', or -C dimension (M), if ROWCOL = 'C'. -C The leading pormd elements of this array must contain the -C row degrees of the denominator polynomials in D(s). -C pormd = P if the transfer matrix T(s) is given as row -C polynomial vectors over denominator polynomials; -C pormd = M if the transfer matrix T(s) is given as column -C polynomial vectors over denominator polynomials. -C -C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), -C where kdcoef = MAX(INDEXD(I)) + 1. -C The leading pormd-by-kdcoef part of this array must -C contain the coefficients of each denominator polynomial. -C DCOEFF(I,K) is the coefficient in s**(INDEXD(I)-K+1) of -C the I-th denominator polynomial in D(s), where K = 1,2, -C ...,kdcoef. -C -C LDDCOE INTEGER -C The leading dimension of array DCOEFF. -C LDDCOE >= MAX(1,P), if ROWCOL = 'R'; -C LDDCOE >= MAX(1,M), if ROWCOL = 'C'. -C -C UCOEFF (input) DOUBLE PRECISION array, dimension -C (LDUCO1,LDUCO2,kdcoef) -C The leading P-by-M-by-kdcoef part of this array must -C contain the coefficients of the numerator matrix U(s); -C if ROWCOL = 'C', this array is modified internally but -C restored on exit, and the remainder of the leading -C MAX(M,P)-by-MAX(M,P)-by-kdcoef part is used as internal -C workspace. -C UCOEFF(I,J,K) is the coefficient in s**(INDEXD(iorj)-K+1) -C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; -C iorj = I if T(s) is given as row polynomial vectors over -C denominator polynomials; iorj = J if T(s) is given as -C column polynomial vectors over denominator polynomials. -C Thus for ROWCOL = 'R', U(s) = -C diag(s**INDEXD(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). -C -C LDUCO1 INTEGER -C The leading dimension of array UCOEFF. -C LDUCO1 >= MAX(1,P), if ROWCOL = 'R'; -C LDUCO1 >= MAX(1,M,P), if ROWCOL = 'C'. -C -C LDUCO2 INTEGER -C The second dimension of array UCOEFF. -C LDUCO2 >= MAX(1,M), if ROWCOL = 'R'; -C LDUCO2 >= MAX(1,M,P), if ROWCOL = 'C'. -C -C NR (output) INTEGER -C The order of the resulting minimal realization, i.e. the -C order of the state dynamics matrix A. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N), -C pormd -C where N = SUM INDEXD(I) -C I=1 -C The leading NR-by-NR part of this array contains the upper -C block Hessenberg state dynamics matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) -C The leading NR-by-M part of this array contains the -C input/state matrix B; the remainder of the leading -C N-by-MAX(M,P) part is used as internal workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-NR part of this array contains the -C state/output matrix C; the remainder of the leading -C MAX(M,P)-by-N part is used as internal workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) -C The leading P-by-M part of this array contains the direct -C transmission matrix D; the remainder of the leading -C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,M,P). -C -C INDEXP (output) INTEGER array, dimension (P), if ROWCOL = 'R', or -C dimension (M), if ROWCOL = 'C'. -C The leading pormp elements of this array contain the -C row (column if ROWCOL = 'C') degrees of the denominator -C matrix P(s). -C pormp = P if a left polynomial matrix representation -C is requested; pormp = M if a right polynomial matrix -C representation is requested. -C These elements are ordered so that -C INDEXP(1) >= INDEXP(2) >= ... >= INDEXP(pormp). -C -C PCOEFF (output) DOUBLE PRECISION array, dimension -C (LDPCO1,LDPCO2,N+1) -C The leading pormp-by-pormp-by-kpcoef part of this array -C contains the coefficients of the denominator matrix P(s), -C where kpcoef = MAX(INDEXP(I)) + 1. -C PCOEFF(I,J,K) is the coefficient in s**(INDEXP(iorj)-K+1) -C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; -C iorj = I if a left polynomial matrix representation is -C requested; iorj = J if a right polynomial matrix -C representation is requested. -C Thus for a left polynomial matrix representation, P(s) = -C diag(s**INDEXP(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). -C -C LDPCO1 INTEGER -C The leading dimension of array PCOEFF. -C LDPCO1 >= MAX(1,P), if ROWCOL = 'R'; -C LDPCO1 >= MAX(1,M), if ROWCOL = 'C'. -C -C LDPCO2 INTEGER -C The second dimension of array PCOEFF. -C LDPCO2 >= MAX(1,P), if ROWCOL = 'R'; -C LDPCO2 >= MAX(1,M), if ROWCOL = 'C'. -C -C QCOEFF (output) DOUBLE PRECISION array, dimension -C (LDQCO1,LDQCO2,N+1) -C The leading pormp-by-pormd-by-kpcoef part of this array -C contains the coefficients of the numerator matrix Q(s). -C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). -C -C LDQCO1 INTEGER -C The leading dimension of array QCOEFF. -C If LERI = 'L', LDQCO1 >= MAX(1,PM), -C where PM = P, if ROWCOL = 'R'; -C PM = M, if ROWCOL = 'C'. -C If LERI = 'R', LDQCO1 >= MAX(1,M,P). -C -C LDQCO2 INTEGER -C The second dimension of array QCOEFF. -C If LERI = 'L', LDQCO2 >= MAX(1,MP), -C where MP = M, if ROWCOL = 'R'; -C MP = P, if ROWCOL = 'C'. -C If LERI = 'R', LDQCO2 >= MAX(1,M,P). -C -C VCOEFF (output) DOUBLE PRECISION array, dimension -C (LDVCO1,LDVCO2,N+1) -C The leading pormp-by-NR-by-kpcoef part of this array -C contains the coefficients of the intermediate matrix -C V(s) as produced by SLICOT Library routine TB03AD. -C -C LDVCO1 INTEGER -C The leading dimension of array VCOEFF. -C LDVCO1 >= MAX(1,P), if ROWCOL = 'R'; -C LDVCO1 >= MAX(1,M), if ROWCOL = 'C'. -C -C LDVCO2 INTEGER -C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) -C where PM = P, if ROWCOL = 'R'; -C PM = M, if ROWCOL = 'C'. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i (i <= k = pormd), then i is the first -C integer I for which ABS( DCOEFF(I,1) ) is so small -C that the calculations would overflow (see SLICOT -C Library routine TD03AY); that is, the leading -C coefficient of a polynomial is nearly zero; no -C state-space representation or polynomial matrix -C representation is calculated; -C = k+1: if a singular matrix was encountered during the -C computation of V(s); -C = k+2: if a singular matrix was encountered during the -C computation of P(s). -C -C METHOD -C -C The method for transfer matrices factorized by rows will be -C described here; T(s) factorized by columns is dealt with by -C operating on the dual T'(s). The description for T(s) is actually -C the left polynomial matrix representation -C -C T(s) = inv(D(s))*U(s), -C -C where D(s) is diagonal with its (I,I)-th polynomial element of -C degree INDEXD(I). The first step is to check whether the leading -C coefficient of any polynomial element of D(s) is approximately -C zero, if so the routine returns with INFO > 0. Otherwise, -C Wolovich's Observable Structure Theorem is used to construct a -C state-space representation in observable companion form which is -C equivalent to the above polynomial matrix representation. The -C method is particularly easy here due to the diagonal form of D(s). -C This state-space representation is not necessarily controllable -C (as D(s) and U(s) are not necessarily relatively left prime), but -C it is in theory completely observable; however, its observability -C matrix may be poorly conditioned, so it is treated as a general -C state-space representation and SLICOT Library routine TB03AD is -C used to separate out a minimal realization for T(s) from it by -C means of orthogonal similarity transformations and then to -C calculate a relatively prime (left or right) polynomial matrix -C representation which is equivalent to this. -C -C REFERENCES -C -C [1] Patel, R.V. -C On Computing Matrix Fraction Descriptions and Canonical -C Forms of Linear Time-Invariant Systems. -C UMIST Control Systems Centre Report 489, 1980. -C -C [2] Wolovich, W.A. -C Linear Multivariable Systems, (Theorem 4.3.3). -C Springer-Verlag, 1974. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. -C Supersedes Release 3.0 routine TD01ND. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, LERI, ROWCOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, - $ LDPCO2, LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, - $ LDVCO2, LDWORK, M, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INDEXD(*), INDEXP(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), DWORK(*), - $ PCOEFF(LDPCO1,LDPCO2,*), - $ QCOEFF(LDQCO1,LDQCO2,*), - $ UCOEFF(LDUCO1,LDUCO2,*), VCOEFF(LDVCO1,LDVCO2,*) -C .. Local Scalars .. - LOGICAL LEQUIL, LLERI, LROWCO - INTEGER I, IDUAL, ITEMP, J, JSTOP, K, KDCOEF, KPCOEF, - $ MAXMP, MPLIM, MWORK, N, PWORK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DLACPY, DSWAP, TB01XD, TB03AD, TC01OD, - $ TD03AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - LROWCO = LSAME( ROWCOL, 'R' ) - LLERI = LSAME( LERI, 'L' ) - LEQUIL = LSAME( EQUIL, 'S' ) -C -C Test the input scalar arguments. -C - MAXMP = MAX( M, P ) - MPLIM = MAX( 1, MAXMP ) - IF ( LROWCO ) THEN -C -C Initialization for T(s) given as rows over common denominators. -C - PWORK = P - MWORK = M - ELSE -C -C Initialization for T(s) given as columns over common -C denominators. -C - PWORK = M - MWORK = P - END IF -C - IF( .NOT.LROWCO .AND. .NOT.LSAME( ROWCOL, 'C' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN - INFO = -8 - ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LROWCO .AND. - $ LDUCO1.LT.MPLIM ) ) THEN - INFO = -10 - ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LROWCO .AND. - $ LDUCO2.LT.MPLIM ) ) THEN - INFO = -11 - END IF -C - N = 0 - IF ( INFO.EQ.0 ) THEN -C -C Calculate N, the order of the resulting state-space -C representation, and the index kdcoef. -C - KDCOEF = 0 -C - DO 10 I = 1, PWORK - KDCOEF = MAX( KDCOEF, INDEXD(I) ) - N = N + INDEXD(I) - 10 CONTINUE -C - KDCOEF = KDCOEF + 1 -C - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -16 - ELSE IF( LDC.LT.MPLIM ) THEN - INFO = -18 - ELSE IF( LDD.LT.MPLIM ) THEN - INFO = -20 - ELSE IF( LDPCO1.LT.PWORK ) THEN - INFO = -23 - ELSE IF( LDPCO2.LT.PWORK ) THEN - INFO = -24 - ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LLERI .AND. - $ LDQCO1.LT.MPLIM ) ) THEN - INFO = -26 - ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LLERI .AND. - $ LDQCO2.LT.MPLIM ) ) THEN - INFO = -27 - ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN - INFO = -29 - ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN - INFO = -30 -C - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), - $ PWORK*( PWORK + 2 ) ) ) THEN - INFO = -34 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TD03AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C -C IDUAL = 1 iff precisely ROWCOL = 'C' or (exclusively) LERI = 'R', -C i.e. iff AB07MD call is required before TB03AD. -C - IDUAL = 0 - IF ( .NOT.LROWCO ) IDUAL = 1 - IF ( .NOT.LLERI ) IDUAL = IDUAL + 1 -C - IF ( .NOT.LROWCO ) THEN -C -C Initialize the remainder of the leading -C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. -C - IF ( P.LT.M ) THEN -C - DO 20 K = 1, KDCOEF - CALL DLACPY( 'Full', M-P, MPLIM, ZERO, ZERO, - $ UCOEFF(P+1,1,K), LDUCO1 ) - 20 CONTINUE -C - ELSE IF ( P.GT.M ) THEN -C - DO 30 K = 1, KDCOEF - CALL DLACPY( 'Full', MPLIM, P-M, ZERO, ZERO, - $ UCOEFF(1,M+1,K), LDUCO1 ) - 30 CONTINUE -C - END IF -C - IF ( MPLIM.NE.1 ) THEN -C -C Non-scalar T(s) factorized by columns: transpose it -C (i.e. U(s)). -C - JSTOP = MPLIM - 1 -C - DO 50 K = 1, KDCOEF -C - DO 40 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 40 CONTINUE -C - 50 CONTINUE -C - END IF - END IF -C -C Construct non-minimal state-space representation (by Wolovich's -C Structure Theorem) which has transfer matrix T(s) or T'(s) as -C appropriate, -C - CALL TD03AY( MWORK, PWORK, INDEXD, DCOEFF, LDDCOE, UCOEFF, LDUCO1, - $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) - IF ( INFO.GT.0 ) - $ RETURN -C - IF ( IDUAL.EQ.1 ) THEN -C -C and then obtain (MWORK x PWORK) dual of this system if -C appropriate. -C - CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO ) - ITEMP = PWORK - PWORK = MWORK - MWORK = ITEMP - END IF -C -C Find left polynomial matrix representation (and minimal -C state-space representation en route) for the relevant state-space -C representation ... -C - CALL TB03AD( 'Left', EQUIL, N, MWORK, PWORK, A, LDA, B, LDB, C, - $ LDC, D, LDD, NR, INDEXP, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, TOL, - $ IWORK, DWORK, LDWORK, INFO ) -C - IF ( INFO.GT.0 ) THEN - INFO = PWORK + INFO - RETURN - END IF -C - IF ( .NOT.LLERI ) THEN -C -C and, if a right polynomial matrix representation is required, -C transpose and reorder (to get a block upper Hessenberg -C matrix A). -C - K = IWORK(1) - 1 - IF ( N.GE.2 ) - $ K = K + IWORK(2) - CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, C, - $ LDC, D, LDD, INFO ) -C - KPCOEF = 0 -C - DO 60 I = 1, PWORK - KPCOEF = MAX( KPCOEF, INDEXP(I) ) - 60 CONTINUE -C - KPCOEF = KPCOEF + 1 - CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, LDPCO2, - $ QCOEFF, LDQCO1, LDQCO2, INFO ) - END IF -C - IF ( ( .NOT.LROWCO ) .AND. ( MPLIM.NE.1 ) ) THEN -C -C If non-scalar T(s) originally given by columns, -C retranspose U(s). -C - DO 80 K = 1, KDCOEF -C - DO 70 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, UCOEFF(J,J+1,K), - $ LDUCO1 ) - 70 CONTINUE -C - 80 CONTINUE -C - END IF - RETURN -C *** Last line of TD03AD *** - END diff --git a/slycot/src/TD03AY.f b/slycot/src/TD03AY.f deleted file mode 100644 index 90d53eee..00000000 --- a/slycot/src/TD03AY.f +++ /dev/null @@ -1,171 +0,0 @@ - SUBROUTINE TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, - $ LDUCO1, LDUCO2, N, A, LDA, B, LDB, C, LDC, D, - $ LDD, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Calculates a state-space representation for a (PWORK x MWORK) -C transfer matrix given in the form of polynomial row vectors over -C common denominators (not necessarily lcd's). Such a description -C is simply the polynomial matrix representation -C -C T(s) = inv(D(s)) * U(s), -C -C where D(s) is diagonal with (I,I)-th element D:I(s) of degree -C INDEX(I); applying Wolovich's Observable Structure Theorem to -C this left matrix fraction then yields an equivalent state-space -C representation in observable companion form, of order -C N = sum(INDEX(I)). As D(s) is diagonal, the PWORK ordered -C 'non-trivial' columns of C and A are very simply calculated, these -C submatrices being diagonal and (INDEX(I) x 1) - block diagonal, -C respectively: finding B and D is also somewhat simpler than for -C general P(s) as dealt with in TC04AD. Finally, the state-space -C representation obtained here is not necessarily controllable -C (as D(s) and U(s) are not necessarily relatively left prime), but -C it is theoretically completely observable: however, its -C observability matrix may be poorly conditioned, so it is safer -C not to assume observability either. -C -C REVISIONS -C -C May 13, 1998. -C -C KEYWORDS -C -C Coprime matrix fraction, elementary polynomial operations, -C polynomial matrix, state-space representation, transfer matrix. -C -C ****************************************************************** -C - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, MWORK, N, PWORK -C .. Array Arguments .. - INTEGER INDEX(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), UCOEFF(LDUCO1,LDUCO2,*) -C .. Local Scalars .. - INTEGER I, IA, IBIAS, INDCUR, JA, JMAX1, K - DOUBLE PRECISION ABSDIA, ABSDMX, BIGNUM, DIAG, SMLNUM, UMAX1, - $ TEMP -C .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH, IDAMAX -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLASET, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. Executable Statements .. -C - INFO = 0 -C -C Initialize A and C to be zero, apart from 1's on the subdiagonal -C of A. -C - CALL DLASET( 'Upper', N, N, ZERO, ZERO, A, LDA ) - IF ( N.GT.1 ) CALL DLASET( 'Lower', N-1, N-1, ZERO, ONE, A(2,1), - $ LDA ) -C - CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) -C -C Calculate B and D, as well as 'non-trivial' elements of A and C. -C Check if any leading coefficient of D(s) nearly zero: if so, exit. -C Caution is taken to avoid overflow. -C - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM -C - IBIAS = 2 - JA = 0 -C - DO 20 I = 1, PWORK - ABSDIA = ABS( DCOEFF(I,1) ) - JMAX1 = IDAMAX( MWORK, UCOEFF(I,1,1), LDUCO1 ) - UMAX1 = ABS( UCOEFF(I,JMAX1,1) ) - IF ( ( ABSDIA.LT.SMLNUM ) .OR. - $ ( ABSDIA.LT.ONE .AND. UMAX1.GT.ABSDIA*BIGNUM ) ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - DIAG = ONE/DCOEFF(I,1) - INDCUR = INDEX(I) - IF ( INDCUR.NE.0 ) THEN - IBIAS = IBIAS + INDCUR - JA = JA + INDCUR - IF ( INDCUR.GE.1 ) THEN - JMAX1 = IDAMAX( INDCUR, DCOEFF(I,2), LDDCOE ) - ABSDMX = ABS( DCOEFF(I,JMAX1) ) - IF ( ABSDIA.GE.ONE ) THEN - IF ( UMAX1.GT.ONE ) THEN - IF ( ( ABSDMX/ABSDIA ).GT.( BIGNUM/UMAX1 ) ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - END IF - ELSE - IF ( UMAX1.GT.ONE ) THEN - IF ( ABSDMX.GT.( BIGNUM*ABSDIA )/UMAX1 ) THEN -C -C Error return. -C - INFO = I - RETURN - END IF - END IF - END IF - END IF -C -C I-th 'non-trivial' sub-vector of A given from coefficients -C of D:I(s), while I-th row block of B given from this and -C row I of U(s). -C - DO 10 K = 2, INDCUR + 1 - IA = IBIAS - K - TEMP = -DIAG*DCOEFF(I,K) - A(IA,JA) = TEMP -C - CALL DCOPY( MWORK, UCOEFF(I,1,K), LDUCO1, B(IA,1), LDB ) - CALL DAXPY( MWORK, TEMP, UCOEFF(I,1,1), LDUCO1, B(IA,1), - $ LDB ) - 10 CONTINUE -C - IF ( JA.LT.N ) A(JA+1,JA) = ZERO -C -C Finally, I-th 'non-trivial' entry of C and row of D obtained -C also. -C - C(I,JA) = DIAG - END IF -C - CALL DCOPY( MWORK, UCOEFF(I,1,1), LDUCO1, D(I,1), LDD ) - CALL DSCAL( MWORK, DIAG, D(I,1), LDD ) - 20 CONTINUE -C - RETURN -C *** Last line of TD03AY *** - END diff --git a/slycot/src/TD04AD.f b/slycot/src/TD04AD.f deleted file mode 100644 index 2dde49ad..00000000 --- a/slycot/src/TD04AD.f +++ /dev/null @@ -1,436 +0,0 @@ - SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, - $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, - $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a minimal state-space representation (A,B,C,D) for a -C proper transfer matrix T(s) given as either row or column -C polynomial vectors over denominator polynomials, possibly with -C uncancelled common terms. -C -C ARGUMENTS -C -C Mode Parameters -C -C ROWCOL CHARACTER*1 -C Indicates whether the transfer matrix T(s) is given as -C rows or columns over common denominators as follows: -C = 'R': T(s) is given as rows over common denominators; -C = 'C': T(s) is given as columns over common denominators. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C INDEX (input) INTEGER array, dimension (porm), where porm = P, -C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. -C This array must contain the degrees of the denominator -C polynomials in D(s). -C -C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), -C where kdcoef = MAX(INDEX(I)) + 1. -C The leading porm-by-kdcoef part of this array must contain -C the coefficients of each denominator polynomial. -C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the -C I-th denominator polynomial in D(s), where -C K = 1,2,...,kdcoef. -C -C LDDCOE INTEGER -C The leading dimension of array DCOEFF. -C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; -C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. -C -C UCOEFF (input) DOUBLE PRECISION array, dimension -C (LDUCO1,LDUCO2,kdcoef) -C The leading P-by-M-by-kdcoef part of this array must -C contain the numerator matrix U(s); if ROWCOL = 'C', this -C array is modified internally but restored on exit, and the -C remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef -C part is used as internal workspace. -C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) -C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; -C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. -C Thus for ROWCOL = 'R', U(s) = -C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). -C -C LDUCO1 INTEGER -C The leading dimension of array UCOEFF. -C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; -C LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'. -C -C LDUCO2 INTEGER -C The second dimension of array UCOEFF. -C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; -C LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'. -C -C NR (output) INTEGER -C The order of the resulting minimal realization, i.e. the -C order of the state dynamics matrix A. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N), -C porm -C where N = SUM INDEX(I). -C I=1 -C The leading NR-by-NR part of this array contains the upper -C block Hessenberg state dynamics matrix A of a minimal -C realization. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) -C The leading NR-by-M part of this array contains the -C input/state matrix B of a minimal realization; the -C remainder of the leading N-by-MAX(M,P) part is used as -C internal workspace. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (output) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-NR part of this array contains the -C state/output matrix C of a minimal realization; the -C remainder of the leading MAX(M,P)-by-N part is used as -C internal workspace. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C D (output) DOUBLE PRECISION array, dimension (LDD,M), -C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. -C The leading P-by-M part of this array contains the direct -C transmission matrix D; if ROWCOL = 'C', the remainder of -C the leading MAX(M,P)-by-MAX(M,P) part is used as internal -C workspace. -C -C LDD INTEGER -C The leading dimension of array D. -C LDD >= MAX(1,P) if ROWCOL = 'R'; -C LDD >= MAX(1,M,P) if ROWCOL = 'C'. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determination when -C transforming (A, B, C). If the user sets TOL > 0, then -C the given value of TOL is used as a lower bound for the -C reciprocal condition number (see the description of the -C argument RCOND in the SLICOT routine MB03OD); a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance -C (determined by the SLICOT routine TB01UD) is used instead. -C -C Workspace -C -C IWORK INTEGER array, dimension (N+MAX(M,P)) -C On exit, if INFO = 0, the first nonzero elements of -C IWORK(1:N) return the orders of the diagonal blocks of A. -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, then i is the first integer for which -C ABS( DCOEFF(I,1) ) is so small that the calculations -C would overflow (see SLICOT Library routine TD03AY); -C that is, the leading coefficient of a polynomial is -C nearly zero; no state-space representation is -C calculated. -C -C METHOD -C -C The method for transfer matrices factorized by rows will be -C described here: T(s) factorized by columns is dealt with by -C operating on the dual T'(s). This description for T(s) is -C actually the left polynomial matrix representation -C -C T(s) = inv(D(s))*U(s), -C -C where D(s) is diagonal with its (I,I)-th polynomial element of -C degree INDEX(I). The first step is to check whether the leading -C coefficient of any polynomial element of D(s) is approximately -C zero; if so the routine returns with INFO > 0. Otherwise, -C Wolovich's Observable Structure Theorem is used to construct a -C state-space representation in observable companion form which -C is equivalent to the above polynomial matrix representation. -C The method is particularly easy here due to the diagonal form -C of D(s). This state-space representation is not necessarily -C controllable (as D(s) and U(s) are not necessarily relatively -C left prime), but it is in theory completely observable; however, -C its observability matrix may be poorly conditioned, so it is -C treated as a general state-space representation and SLICOT -C Library routine TB01PD is then called to separate out a minimal -C realization from this general state-space representation by means -C of orthogonal similarity transformations. -C -C REFERENCES -C -C [1] Patel, R.V. -C Computation of Minimal-Order State-Space Realizations and -C Observability Indices using Orthogonal Transformations. -C Int. J. Control, 33, pp. 227-246, 1981. -C -C [2] Wolovich, W.A. -C Linear Multivariable Systems, (Theorem 4.3.3). -C Springer-Verlag, 1974. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires 0(N ) operations. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. -C Supersedes Release 3.0 routine TD01OD. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Controllability, elementary polynomial operations, minimal -C realization, polynomial matrix, state-space representation, -C transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER ROWCOL - INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, - $ LDUCO2, LDWORK, M, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INDEX(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DCOEFF(LDDCOE,*), DWORK(*), - $ UCOEFF(LDUCO1,LDUCO2,*) -C .. Local Scalars .. - LOGICAL LROCOC, LROCOR - INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK, - $ KU -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLASET, DSWAP, TB01PD, TB01XD, TD03AY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - LROCOR = LSAME( ROWCOL, 'R' ) - LROCOC = LSAME( ROWCOL, 'C' ) - MPLIM = MAX( 1, M, P ) -C -C Test the input scalar arguments. -C - IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( ( LROCOR .AND. LDDCOE.LT.MAX( 1, P ) ) .OR. - $ ( LROCOC .AND. LDDCOE.LT.MAX( 1, M ) ) ) THEN - INFO = -6 - ELSE IF( ( LROCOR .AND. LDUCO1.LT.MAX( 1, P ) ) .OR. - $ ( LROCOC .AND. LDUCO1.LT.MPLIM ) ) THEN - INFO = -8 - ELSE IF( ( LROCOR .AND. LDUCO2.LT.MAX( 1, M ) ) .OR. - $ ( LROCOC .AND. LDUCO2.LT.MPLIM ) ) THEN - INFO = -9 - END IF -C - N = 0 - IF ( INFO.EQ.0 ) THEN - IF ( LROCOR ) THEN -C -C Initialization for T(s) given as rows over common -C denominators. -C - PWORK = P - MWORK = M - ELSE -C -C Initialization for T(s) given as columns over common -C denominators. -C - PWORK = M - MWORK = P - END IF -C -C Calculate N, the order of the resulting state-space -C representation. -C - KDCOEF = 0 -C - DO 10 I = 1, PWORK - KDCOEF = MAX( KDCOEF, INDEX(I) ) - N = N + INDEX(I) - 10 CONTINUE -C - KDCOEF = KDCOEF + 1 -C - IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MPLIM ) THEN - INFO = -16 - ELSE IF( ( LROCOR .AND. LDD.LT.MAX( 1, P ) ) .OR. - $ ( LROCOC .AND. LDD.LT.MPLIM ) ) THEN - INFO = -18 - ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*M, 3*P ) ) ) THEN - INFO = -22 - END IF - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TD04AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( N, M, P ).EQ.0 ) THEN - NR = 0 - DWORK(1) = ONE - RETURN - END IF -C - IF ( LROCOC ) THEN -C -C Initialize the remainder of the leading -C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. -C - IF ( P.LT.M ) THEN -C - DO 20 K = 1, KDCOEF - CALL DLASET( 'Full', M-P, MPLIM, ZERO, ZERO, - $ UCOEFF(P+1,1,K), LDUCO1 ) - 20 CONTINUE -C - ELSE IF ( P.GT.M ) THEN -C - DO 30 K = 1, KDCOEF - CALL DLASET( 'Full', MPLIM, P-M, ZERO, ZERO, - $ UCOEFF(1,M+1,K), LDUCO1 ) - 30 CONTINUE -C - END IF -C - IF ( MPLIM.NE.1 ) THEN -C -C Non-scalar T(s) factorized by columns: transpose it (i.e. -C U(s)). -C - JSTOP = MPLIM - 1 -C - DO 50 K = 1, KDCOEF -C - DO 40 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 40 CONTINUE -C - 50 CONTINUE -C - END IF - END IF -C -C Construct non-minimal state-space representation (by Wolovich's -C Structure Theorem) which has transfer matrix T(s) or T'(s) as -C appropriate ... -C - CALL TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, - $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) - IF ( INFO.GT.0 ) - $ RETURN -C -C and then separate out a minimal realization from this. -C -C Workspace: need N + MAX(N, 3*MWORK, 3*PWORK). -C - CALL TB01PD( 'Minimal', 'Scale', N, MWORK, PWORK, A, LDA, B, LDB, - $ C, LDC, NR, TOL, IWORK, DWORK, LDWORK, INFO ) -C - IF ( LROCOC ) THEN -C -C If T(s) originally factorized by columns, find dual of minimal -C state-space representation, and reorder the rows and columns -C to get an upper block Hessenberg state dynamics matrix. -C -C IWORK contains the orders of the diagnonal blocks -C RvP, In TB01PD, IWORK is zeroed from INDCON to N, beyond N it may -C contain nonsense? - K = -1 - DO 55 I = 1, N - K = K + IWORK(I) - 55 CONTINUE -C -C RvP 180615 Try to protect against re-working an empty [] A -C matrix, failed with K < 0 -C - CALL TB01XD( 'D', NR, MWORK, PWORK, MAX(0, K), MAX(0,NR-1), - $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) - IF ( MPLIM.NE.1 ) THEN -C -C Also, retranspose U(s) if this is non-scalar. -C - DO 70 K = 1, KDCOEF -C - DO 60 J = 1, JSTOP - CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, - $ UCOEFF(J,J+1,K), LDUCO1 ) - 60 CONTINUE -C - 70 CONTINUE -C - END IF - END IF -C - RETURN -C *** Last line of TD04AD *** - END diff --git a/slycot/src/TD05AD.f b/slycot/src/TD05AD.f deleted file mode 100644 index 0b527c4a..00000000 --- a/slycot/src/TD05AD.f +++ /dev/null @@ -1,314 +0,0 @@ - SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Given a complex valued rational function of frequency (transfer -C function) G(jW) this routine will calculate its complex value or -C its magnitude and phase for a specified frequency value. -C -C ARGUMENTS -C -C Mode Parameters -C -C UNITF CHARACTER*1 -C Indicates the choice of frequency unit as follows: -C = 'R': Input frequency W in radians/second; -C = 'H': Input frequency W in hertz. -C -C OUTPUT CHARACTER*1 -C Indicates the choice of co-ordinates for output as folows: -C = 'C': Cartesian co-ordinates (output real and imaginary -C parts of G(jW)); -C = 'P': Polar co-ordinates (output magnitude and phase -C of G(jW)). -C -C Input/Output Parameters -C -C NP1 (input) INTEGER -C The order of the denominator + 1, i.e. N + 1. NP1 >= 1. -C -C MP1 (input) INTEGER -C The order of the numerator + 1, i.e. M + 1. MP1 >= 1. -C -C W (input) DOUBLE PRECISION -C The frequency value W for which the transfer function is -C to be evaluated. -C -C A (input) DOUBLE PRECISION array, dimension (NP1) -C This array must contain the vector of denominator -C coefficients in ascending order of powers. That is, A(i) -C must contain the coefficient of (jW)**(i-1) for i = 1, -C 2,...,NP1. -C -C B (input) DOUBLE PRECISION array, dimension (MP1) -C This array must contain the vector of numerator -C coefficients in ascending order of powers. That is, B(i) -C must contain the coefficient of (jW)**(i-1) for i = 1, -C 2,...,MP1. -C -C VALR (output) DOUBLE PRECISION -C If OUTPUT = 'C', VALR contains the real part of G(jW). -C If OUTPUT = 'P', VALR contains the magnitude of G(jW) -C in dBs. -C -C VALI (output) DOUBLE PRECISION -C If OUTPUT = 'C', VALI contains the imaginary part of -C G(jW). -C If OUTPUT = 'P', VALI contains the phase of G(jW) in -C degrees. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1: if the frequency value W is a pole of G(jW), or all -C the coefficients of the A polynomial are zero. -C -C METHOD -C -C By substituting the values of A, B and W in the following -C formula: -C -C B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1) -C G(jW) = ---------------------------------------------------. -C A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1) -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C The algorithm requires 0(N+M) operations. -C -C CONTRIBUTORS -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TD01AD by Control Systems Research -C Group, Kingston Polytechnic, United Kingdom, March 1981. -C -C REVISIONS -C -C February 1997. -C February 22, 1998 (changed the name of TD01MD). -C -C KEYWORDS -C -C Elementary polynomial operations, frequency response, matrix -C fraction, polynomial matrix, state-space representation, transfer -C matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60 - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0, - $ TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0, - $ THRE60=360.0D0 ) -C .. Scalar Arguments .. - CHARACTER OUTPUT, UNITF - INTEGER INFO, MP1, NP1 - DOUBLE PRECISION VALI, VALR, W -C .. Array Arguments .. - DOUBLE PRECISION A(*), B(*) -C .. Local Scalars .. - LOGICAL LOUTPU, LUNITF - INTEGER I, IPHASE, M, M2, N, N2, NPZERO, NZZERO - DOUBLE PRECISION BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC - COMPLEX*16 ZTEMP -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAPY2 - COMPLEX*16 ZLADIV - EXTERNAL DLAPY2, LSAME, ZLADIV -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD, - $ SIGN -C .. Executable Statements .. -C - INFO = 0 - LUNITF = LSAME( UNITF, 'H' ) - LOUTPU = LSAME( OUTPUT, 'P' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN - INFO = -2 - ELSE IF( NP1.LT.1 ) THEN - INFO = -3 - ELSE IF( MP1.LT.1 ) THEN - INFO = -4 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TD05AD', -INFO ) - RETURN - END IF -C - M = MP1 - 1 - N = NP1 - 1 - WC = W - TWOPI = EIGHT*ATAN( ONE ) - IF ( LUNITF ) WC = WC*TWOPI - W2 = WC**2 -C -C Determine the orders z (NZZERO) and p (NPZERO) of the factors -C (jW)**k in the numerator and denominator polynomials, by counting -C the zero trailing coefficients. The value of G(jW) will then be -C computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n. -C - I = 0 -C - 10 CONTINUE - I = I + 1 - IF ( I.LE.M ) THEN - IF ( B(I).EQ.ZERO ) GO TO 10 - END IF -C - NZZERO = I - 1 - I = 0 -C - 20 CONTINUE - I = I + 1 - IF ( I.LE.N ) THEN - IF ( A(I).EQ.ZERO ) GO TO 20 - END IF -C - NPZERO = I - 1 - IPHASE = NZZERO - NPZERO -C - M2 = MOD( M - NZZERO, 2 ) -C -C Add real parts of the numerator m(jW). -C - TREAL = B(MP1-M2) -C - DO 30 I = M - 1 - M2, NZZERO + 1, -2 - TREAL = B(I) - W2*TREAL - 30 CONTINUE -C -C Add imaginary parts of the numerator m(jW). -C - IF ( M.EQ.0 ) THEN - TIMAG = ZERO - ELSE - TIMAG = B(M+M2) -C - DO 40 I = M + M2 - 2, NZZERO + 2, -2 - TIMAG = B(I) - W2*TIMAG - 40 CONTINUE -C - TIMAG = TIMAG*WC - END IF -C - N2 = MOD( N - NPZERO, 2 ) -C -C Add real parts of the denominator n(jW). -C - BREAL = A(NP1-N2) -C - DO 50 I = N - 1 - N2, NPZERO + 1, -2 - BREAL = A(I) - W2*BREAL - 50 CONTINUE -C -C Add imaginary parts of the denominator n(jW). -C - IF ( N.EQ.0 ) THEN - BIMAG = ZERO - ELSE - BIMAG = A(N+N2) -C - DO 60 I = N + N2 - 2, NPZERO + 2, -2 - BIMAG = A(I) - W2*BIMAG - 60 CONTINUE -C - BIMAG = BIMAG*WC - END IF -C - IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR. - $ ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN -C -C Error return: The specified frequency W is a pole of G(jW), -C or all the coefficients of the A polynomial are zero. -C - INFO = 1 - ELSE -C -C Evaluate the complex number W**(z-p)*m(jW)/n(jW). -C - ZTEMP = - $ ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) ) - VALR = DBLE( ZTEMP )*WC**IPHASE - VALI = DIMAG( ZTEMP )*WC**IPHASE -C - IF ( .NOT.LOUTPU ) THEN -C -C Cartesian co-ordinates: Update the result for j**(z-p). -C - I = MOD( ABS( IPHASE ), 4 ) - IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR. - $ ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN - VALR = -VALR - VALI = -VALI - END IF -C - IF ( MOD( I, 2 ).NE.0 ) THEN - G = VALR - VALR = -VALI - VALI = G - END IF -C - ELSE -C -C Polar co-ordinates: Compute the magnitude and phase. -C - G = DLAPY2( VALR, VALI ) -C - IF ( VALR.EQ.ZERO ) THEN - VALI = SIGN( NINETY, VALI ) - ELSE - VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60 - IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N - $ .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO ) - $ VALI = ONE80 - END IF -C - VALR = TWENTY*LOG10( G ) -C - IF ( IPHASE.NE.0 ) - $ VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY - END IF -C - END IF -C - RETURN -C *** Last line of TD05AD *** - END diff --git a/slycot/src/TF01MD.f b/slycot/src/TF01MD.f deleted file mode 100644 index 1b33b81c..00000000 --- a/slycot/src/TF01MD.f +++ /dev/null @@ -1,233 +0,0 @@ - SUBROUTINE TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, - $ U, LDU, X, Y, LDY, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C (A,B,C,D), where A is an N-by-N general matrix. -C -C The initial state vector x(1) must be supplied by the user. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct link matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,NY) -C The leading M-by-NY part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th column of U must contain u(k). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) -C The leading P-by-NY part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C column of Y contains y(k) (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,P). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (N + M) x (N + P) x NY -C multiplications and additions. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01AD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. -C -C KEYWORDS -C -C Discrete-time system, multivariable system, state-space model, -C state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER IK -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( NY.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDU.LT.MAX( 1, M ) ) THEN - INFO = -14 - ELSE IF( LDY.LT.MAX( 1, P ) ) THEN - INFO = -17 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01MD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( P, NY ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, - $ D, LDD, U, LDU, ZERO, Y, LDY ) - END IF - RETURN - END IF -C - DO 10 IK = 1, NY - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, - $ Y(1,IK), 1 ) -C - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, - $ DWORK, 1 ) -C - CALL DCOPY( N, DWORK, 1, X, 1 ) - 10 CONTINUE -C - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, - $ U, LDU, ONE, Y, LDY ) -C - RETURN -C *** Last line of TF01MD *** - END diff --git a/slycot/src/TF01MX.f b/slycot/src/TF01MX.f deleted file mode 100644 index aaaf7aaf..00000000 --- a/slycot/src/TF01MX.f +++ /dev/null @@ -1,457 +0,0 @@ - SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C with an (N+P)-by-(N+M) general system matrix S, -C -C ( A B ) -C S = ( ) . -C ( C D ) -C -C The initial state vector x(1) must be supplied by the user. -C -C The input and output trajectories are stored as in the SLICOT -C Library routine TF01MY. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C S (input) DOUBLE PRECISION array, dimension (LDS,N+M) -C The leading (N+P)-by-(N+M) part of this array must contain -C the system matrix S. -C -C LDS INTEGER -C The leading dimension of array S. LDS >= MAX(1,N+P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NY-by-M part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th row of U must contain u(k)'. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NY). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY+1. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,P) -C The leading NY-by-P part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C row of Y contains y(k)' (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NY). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= 0, if MIN(N,P,NY) = 0; otherwise, -C LDWORK >= N+P, if M = 0; -C LDWORK >= 2*N+M+P, if M > 0. -C For better performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C ( x(k+1) ) ( x(k) ) -C ( ) = S ( ) , -C ( y(k) ) ( u(k) ) -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k, and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (N + M) x (N + P) x NY -C multiplications and additions. -C -C FURTHER COMMENTS -C -C The implementation exploits data locality as much as possible, -C given the workspace length. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 2002. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, multivariable system, state-space model, -C state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDS, LDU, LDWORK, LDY, M, N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION DWORK(*), S(LDS,*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER I, IC, IU, IW, IY, J, JW, K, N2M, N2P, NB, NF, - $ NM, NP, NS -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - NP = N + P - NM = N + M - IW = NM + NP - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( NY.LT.0 ) THEN - INFO = -4 - ELSE IF( LDS.LT.MAX( 1, NP ) ) THEN - INFO = -6 - ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN - INFO = -8 - ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN - INFO = -11 - ELSE - IF( MIN( N, P, NY ).EQ.0 ) THEN - JW = 0 - ELSE IF( M.EQ.0 ) THEN - JW = NP - ELSE - JW = IW - END IF - IF( LDWORK.LT.JW ) - $ INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01MX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( NY, P ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, - $ U, LDU, S, LDS, ZERO, Y, LDY ) - END IF - RETURN - END IF -C -C Determine the block size (taken as for LAPACK routine DGETRF). -C - NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) -C -C Find the number of state vectors, extended with inputs (if M > 0) -C and outputs, that can be accommodated in the provided workspace. -C - NS = MIN( LDWORK/JW, NB*NB/JW, NY ) - N2P = N + NP -C - IF ( M.EQ.0 ) THEN -C -C System with no inputs. -C Workspace: need N + P; -C prefer larger. -C - IF( NS.LE.1 .OR. NY*P.LE.NB*NB ) THEN - IY = N + 1 -C -C LDWORK < 2*(N+P), or small problem. -C One row of array Y is computed for each loop index value. -C - DO 10 I = 1, NY -C -C Compute -C -C /x(i+1)\ /A\ -C | | = | | * x(i). -C \ y(i) / \C/ -C - CALL DGEMV( 'NoTranspose', NP, N, ONE, S, LDS, X, 1, - $ ZERO, DWORK, 1 ) - CALL DCOPY( N, DWORK, 1, X, 1 ) - CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) - 10 CONTINUE -C - ELSE -C -C LDWORK >= 2*(N+P), and large problem. -C NS rows of array Y are computed before being saved. -C - NF = ( NY/NS )*NS - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - DO 40 I = 1, NF, NS -C -C Compute the current NS extended state vectors in the -C workspace: -C -C /x(i+1)\ /A\ -C | | = | | * x(i), i = 1 : ns - 1. -C \ y(i) / \C/ -C - DO 20 IC = 1, ( NS - 1 )*NP, NP - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) - 20 CONTINUE -C -C Prepare the next iteration. -C - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) -C -C Transpose the NS output vectors in the corresponding part -C of Y (column-wise). -C - DO 30 J = 1, P - CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(I,J), 1 ) - Y(I+NS-1,J) = DWORK(N+J) - 30 CONTINUE -C - 40 CONTINUE -C - NS = NY - NF -C - IF ( NS.GT.1 ) THEN -C -C Compute similarly the last NS output vectors. -C - DO 50 IC = 1, ( NS - 1 )*NP, NP - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) - 50 CONTINUE -C - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) -C - DO 60 J = 1, P - CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(NF+1,J), 1 ) - Y(NF+NS,J) = DWORK(N+J) - 60 CONTINUE -C - ELSE IF ( NS.EQ.1 ) THEN -C -C Compute similarly the last NS = 1 output vectors. -C - CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) - CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, - $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) - CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) -C - END IF -C -C Set the final state vector. -C - CALL DCOPY( N, DWORK, 1, X, 1 ) -C - END IF -C - ELSE -C -C General case. -C Workspace: need 2*N + M + P; -C prefer larger. -C - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - IF( NS.LE.1 .OR. NY*( M + P ).LE.NB*NB ) THEN - IU = N + 1 - JW = IU + M - IY = JW + N -C -C LDWORK < 2*(2*N+M+P), or small problem. -C One row of array Y is computed for each loop index value. -C - DO 70 I = 1, NY -C -C Compute -C -C /x(i+1)\ /A, B\ /x(i)\ -C | | = | | * | | . -C \ y(i) / \C, D/ \u(i)/ -C - CALL DCOPY( M, U(I,1), LDU, DWORK(IU), 1 ) - CALL DGEMV( 'NoTranspose', NP, NM, ONE, S, LDS, DWORK, 1, - $ ZERO, DWORK(JW), 1 ) - CALL DCOPY( N, DWORK(JW), 1, DWORK, 1 ) - CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) - 70 CONTINUE -C - ELSE -C -C LDWORK >= 2*(2*N+M+P), and large problem. -C NS rows of array Y are computed before being saved. -C - NF = ( NY/NS )*NS - N2M = N + NM -C - DO 110 I = 1, NF, NS - JW = 1 -C -C Compute the current NS extended state vectors in the -C workspace: -C -C /x(i+1)\ /A, B\ /x(i)\ -C | | = | | * | | , i = 1 : ns - 1. -C \ y(i) / \C, D/ \u(i)/ -C - DO 80 J = 1, M - CALL DCOPY( NS, U(I,J), 1, DWORK(N+J), IW ) - 80 CONTINUE -C - DO 90 K = 1, NS - 1 - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - JW = JW + NM - CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) - JW = JW + NP - 90 CONTINUE -C -C Prepare the next iteration. -C - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) -C -C Transpose the NS output vectors in the corresponding part -C of Y (column-wise). -C - DO 100 J = 1, P - CALL DCOPY( NS, DWORK(N2M+J), IW, Y(I,J), 1 ) - 100 CONTINUE -C - 110 CONTINUE -C - NS = NY - NF -C - IF ( NS.GT.1 ) THEN - JW = 1 -C -C Compute similarly the last NS output vectors. -C - DO 120 J = 1, M - CALL DCOPY( NS, U(NF+1,J), 1, DWORK(N+J), IW ) - 120 CONTINUE -C - DO 130 K = 1, NS - 1 - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - JW = JW + NM - CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) - JW = JW + NP - 130 CONTINUE -C - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) - CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) -C - DO 140 J = 1, P - CALL DCOPY( NS, DWORK(N2M+J), IW, Y(NF+1,J), 1 ) - 140 CONTINUE -C - ELSE IF ( NS.EQ.1 ) THEN -C -C Compute similarly the last NS = 1 output vectors. -C - CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) - CALL DCOPY( M, U(NF+1,1), LDU, DWORK(N2P+1), 1 ) - CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, - $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) - CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) -C - END IF -C - END IF -C -C Set the final state vector. -C - CALL DCOPY( N, DWORK, 1, X, 1 ) -C - END IF -C - RETURN -C *** Last line of TF01MX *** - END diff --git a/slycot/src/TF01MY.f b/slycot/src/TF01MY.f deleted file mode 100644 index 85e31c05..00000000 --- a/slycot/src/TF01MY.f +++ /dev/null @@ -1,358 +0,0 @@ - SUBROUTINE TF01MY( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, - $ U, LDU, X, Y, LDY, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C (A,B,C,D), where A is an N-by-N general matrix. -C -C The initial state vector x(1) must be supplied by the user. -C -C This routine differs from SLICOT Library routine TF01MD in the -C way the input and output trajectories are stored. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading N-by-N part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct link matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,M) -C The leading NY-by-M part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th row of U must contain u(k)'. -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,NY). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY+1. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,P) -C The leading NY-by-P part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C row of Y contains y(k)' (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,NY). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. LDWORK >= N. -C For better performance, LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (N + M) x (N + P) x NY -C multiplications and additions. -C -C FURTHER COMMENTS -C -C The implementation exploits data locality and uses BLAS 3 -C operations as much as possible, given the workspace length. -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Discrete-time system, multivariable system, state-space model, -C state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDWORK, LDY, M, - $ N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - INTEGER IK, IREM, IS, IYL, MAXN, NB, NS - DOUBLE PRECISION UPD -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - MAXN = MAX( 1, N ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( NY.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAXN ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAXN ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -12 - ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN - INFO = -14 - ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN - INFO = -17 - ELSE IF( LDWORK.LT.N ) THEN - INFO = -19 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01MY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( NY, P ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, - $ U, LDU, D, LDD, ZERO, Y, LDY ) - END IF - RETURN - END IF -C -C Determine the block size (taken as for LAPACK routine DGETRF). -C - NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) -C -C Find the number of state vectors that can be accommodated in -C the provided workspace and initialize. -C - NS = MIN( LDWORK/N, NB*NB/N, NY ) -C - IF ( NS.LE.1 .OR. NY*MAX( M, P ).LE.NB*NB ) THEN -C -C LDWORK < 2*N or small problem: -C only BLAS 2 calculations are used in the loop -C for computing the output corresponding to D = 0. -C One row of the array Y is computed for each loop index value. -C - DO 10 IK = 1, NY - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, - $ Y(IK,1), LDY ) -C - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, - $ DWORK, 1 ) - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(IK,1), LDU, - $ ONE, DWORK, 1 ) -C - CALL DCOPY( N, DWORK, 1, X, 1 ) - 10 CONTINUE -C - ELSE -C -C LDWORK >= 2*N and large problem: -C some BLAS 3 calculations can also be used. -C - IYL = ( NY/NS )*NS - IF ( M.EQ.0 ) THEN - UPD = ZERO - ELSE - UPD = ONE - END IF -C - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - DO 30 IK = 1, IYL, NS -C -C Compute the current NS-1 state vectors in the workspace. -C - CALL DGEMM( 'No transpose', 'Transpose', N, NS-1, M, ONE, - $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) -C - DO 20 IS = 1, NS - 1 - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) - 20 CONTINUE -C -C Initialize the current NS output vectors. -C - CALL DGEMM( 'Transpose', 'Transpose', NS, P, N, ONE, DWORK, - $ MAXN, C, LDC, ZERO, Y(IK,1), LDY ) -C -C Prepare the next iteration. -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IK+NS-1,1), LDU, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((NS-1)*N+1), 1, UPD, DWORK, 1 ) - 30 CONTINUE -C - IREM = NY - IYL -C - IF ( IREM.GT.1 ) THEN -C -C Compute the last IREM output vectors. -C First, compute the current IREM-1 state vectors. -C - IK = IYL + 1 - CALL DGEMM( 'No transpose', 'Transpose', N, IREM-1, M, ONE, - $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) -C - DO 40 IS = 1, IREM - 1 - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) - 40 CONTINUE -C -C Initialize the last IREM output vectors. -C - CALL DGEMM( 'Transpose', 'Transpose', IREM, P, N, ONE, - $ DWORK, MAXN, C, LDC, ZERO, Y(IK,1), LDY ) -C -C Prepare the final state vector. -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IK+IREM-1,1), LDU, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK((IREM-1)*N+1), 1, UPD, DWORK, 1 ) -C - ELSE IF ( IREM.EQ.1 ) THEN -C -C Compute the last 1 output vectors. -C - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, - $ ZERO, Y(IK,1), LDY ) -C -C Prepare the final state vector. -C - CALL DCOPY( N, DWORK, 1, DWORK(N+1), 1 ) - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, - $ U(IK,1), LDU, ZERO, DWORK, 1 ) - CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, - $ DWORK(N+1), 1, UPD, DWORK, 1 ) - END IF -C -C Set the final state vector. -C - CALL DCOPY( N, DWORK, 1, X, 1 ) -C - END IF -C -C Add the direct contribution of the input to the output vectors. -C - CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, U, LDU, - $ D, LDD, ONE, Y, LDY ) -C - RETURN -C *** Last line of TF01MY *** - END diff --git a/slycot/src/TF01ND.f b/slycot/src/TF01ND.f deleted file mode 100644 index 04676e7e..00000000 --- a/slycot/src/TF01ND.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, LDC, D, - $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute the output sequence of a linear time-invariant -C open-loop system given by its discrete-time state-space model -C (A,B,C,D), where A is an N-by-N upper or lower Hessenberg matrix. -C -C The initial state vector x(1) must be supplied by the user. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Indicates whether the user wishes to use an upper or lower -C Hessenberg matrix as follows: -C = 'U': Upper Hessenberg matrix; -C = 'L': Lower Hessenberg matrix. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C M (input) INTEGER -C The number of system inputs. M >= 0. -C -C P (input) INTEGER -C The number of system outputs. P >= 0. -C -C NY (input) INTEGER -C The number of output vectors y(k) to be computed. -C NY >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C If UPLO = 'U', the leading N-by-N upper Hessenberg part -C of this array must contain the state matrix A of the -C system. -C If UPLO = 'L', the leading N-by-N lower Hessenberg part -C of this array must contain the state matrix A of the -C system. -C The remainder of the leading N-by-N part is not -C referenced. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C The leading N-by-M part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,N) -C The leading P-by-N part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C D (input) DOUBLE PRECISION array, dimension (LDD,M) -C The leading P-by-M part of this array must contain the -C direct link matrix D of the system. -C -C LDD INTEGER -C The leading dimension of array D. LDD >= MAX(1,P). -C -C U (input) DOUBLE PRECISION array, dimension (LDU,NY) -C The leading M-by-NY part of this array must contain the -C input vector sequence u(k), for k = 1,2,...,NY. -C Specifically, the k-th column of U must contain u(k). -C -C LDU INTEGER -C The leading dimension of array U. LDU >= MAX(1,M). -C -C X (input/output) DOUBLE PRECISION array, dimension (N) -C On entry, this array must contain the initial state vector -C x(1) which consists of the N initial states of the system. -C On exit, this array contains the final state vector -C x(NY+1) of the N states of the system at instant NY. -C -C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) -C The leading P-by-NY part of this array contains the output -C vector sequence y(1),y(2),...,y(NY) such that the k-th -C column of Y contains y(k) (the outputs at instant k), -C for k = 1,2,...,NY. -C -C LDY INTEGER -C The leading dimension of array Y. LDY >= MAX(1,P). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (N) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Given an initial state vector x(1), the output vector sequence -C y(1), y(2),..., y(NY) is obtained via the formulae -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C where each element y(k) is a vector of length P containing the -C outputs at instant k and k = 1,2,...,NY. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately ((N+M)xP + (N/2+M)xN) x NY -C multiplications and additions. -C -C FURTHER COMMENTS -C -C The processing time required by this routine will be approximately -C half that required by the SLICOT Library routine TF01MD, which -C treats A as a general matrix. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01BD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. -C -C KEYWORDS -C -C Discrete-time system, Hessenberg form, multivariable system, -C state-space model, state-space representation, time response. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), - $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) -C .. Local Scalars .. - LOGICAL LUPLO - INTEGER I, IK -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( NY.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( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDD.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDU.LT.MAX( 1, M ) ) THEN - INFO = -15 - ELSE IF( LDY.LT.MAX( 1, P ) ) THEN - INFO = -18 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01ND', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( P, NY ).EQ.0 ) THEN - RETURN - ELSE IF ( N.EQ.0 ) THEN -C -C Non-dynamic system: compute the output vectors. -C - IF ( M.EQ.0 ) THEN - CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) - ELSE - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, - $ D, LDD, U, LDU, ZERO, Y, LDY ) - END IF - RETURN - END IF -C - CALL DCOPY( N, X, 1, DWORK, 1 ) -C - DO 30 IK = 1, NY - CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, ZERO, - $ Y(1,IK), 1 ) -C - CALL DTRMV( UPLO, 'No transpose', 'Non-unit', N, A, LDA, - $ DWORK, 1 ) -C - IF ( LUPLO ) THEN -C - DO 10 I = 2, N - DWORK(I) = DWORK(I) + A(I,I-1)*X(I-1) - 10 CONTINUE -C - ELSE -C - DO 20 I = 1, N - 1 - DWORK(I) = DWORK(I) + A(I,I+1)*X(I+1) - 20 CONTINUE -C - END IF -C - CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, - $ DWORK, 1 ) -C - CALL DCOPY( N, DWORK, 1, X, 1 ) - 30 CONTINUE -C - CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, - $ U, LDU, ONE, Y, LDY ) -C - RETURN -C *** Last line of TF01ND *** - END diff --git a/slycot/src/TF01OD.f b/slycot/src/TF01OD.f deleted file mode 100644 index 656d86c9..00000000 --- a/slycot/src/TF01OD.f +++ /dev/null @@ -1,179 +0,0 @@ - SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the block Hankel expansion T of a multivariable -C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) -C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NH1 (input) INTEGER -C The number of rows in each parameter M(k). NH1 >= 0. -C -C NH2 (input) INTEGER -C The number of columns in each parameter M(k). NH2 >= 0. -C -C NR (input) INTEGER -C The number of parameters required in each column of the -C block Hankel expansion matrix T. NR >= 0. -C -C NC (input) INTEGER -C The number of parameters required in each row of the -C block Hankel expansion matrix T. NC >= 0. -C -C H (input) DOUBLE PRECISION array, dimension -C (LDH,(NR+NC-1)*NH2) -C The leading NH1-by-(NR+NC-1)*NH2 part of this array must -C contain the multivariable sequence M(k), where k = 1,2, -C ...,(NR+NC-1). Specifically, each parameter M(k) is an -C NH1-by-NH2 matrix whose (i,j)-th element must be stored in -C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NH1). -C -C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) -C The leading NH1*NR-by-NH2*NC part of this array contains -C the block Hankel expansion of the multivariable sequence -C M(k). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,NH1*NR). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The NH1-by-NH2 dimensional parameters M(k) of a multivariable -C sequence are arranged into a matrix T in Hankel form such that -C -C -C | M(1) M(2) M(3) . . . M(NC) | -C | | -C | M(2) M(3) M(4) . . . M(NC+1) | -C T = | . . . . |. -C | . . . . | -C | . . . . | -C | | -C | M(NR) M(NR+1) M(NR+2) . . . M(NR+NC-1)| -C -C REFERENCES -C -C [1] Johvidov, J.S. -C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, -C (translated by G.P.A. Thijsse, I. Gohberg, ed.). -C Birkhaeuser, Boston, 1982. -C -C NUMERICAL ASPECTS -C -C The time taken is approximately proportional to -C NH1 x NH2 x NR x NC. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Hankel matrix, multivariable system. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR -C .. Array Arguments .. - DOUBLE PRECISION H(LDH,*), T(LDT,*) -C .. Local Scalars .. - INTEGER IH, IT, JT, NROW -C .. External Subroutines .. - EXTERNAL DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NH1.LT.0 ) THEN - INFO = -1 - ELSE IF( NH2.LT.0 ) THEN - INFO = -2 - ELSE IF( NR.LT.0 ) THEN - INFO = -3 - ELSE IF( NC.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN - INFO = -6 - ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01OD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) - $ RETURN -C -C Construct the first block column of T. -C - IH = 1 - NROW = (NR-1)*NH1 -C - DO 10 IT = 1, NROW+NH1, NH1 - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT ) - IH = IH + NH2 - 10 CONTINUE -C -C Construct the remaining block columns of T. -C - DO 20 JT = NH2+1, NC*NH2, NH2 - CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT), - $ LDT ) - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), - $ LDT ) - IH = IH + NH2 - 20 CONTINUE -C - RETURN -C *** Last line of TF01OD *** - END diff --git a/slycot/src/TF01PD.f b/slycot/src/TF01PD.f deleted file mode 100644 index e45f078b..00000000 --- a/slycot/src/TF01PD.f +++ /dev/null @@ -1,178 +0,0 @@ - SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To construct the block Toeplitz expansion T of a multivariable -C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) -C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NH1 (input) INTEGER -C The number of rows in each parameter M(k). NH1 >= 0. -C -C NH2 (input) INTEGER -C The number of columns in each parameter M(k). NH2 >= 0. -C -C NR (input) INTEGER -C The number of parameters required in each column of the -C block Toeplitz expansion matrix T. NR >= 0. -C -C NC (input) INTEGER -C The number of parameters required in each row of the -C block Toeplitz expansion matrix T. NC >= 0. -C -C H (input) DOUBLE PRECISION array, dimension -C (LDH,(NR+NC-1)*NH2) -C The leading NH1-by-(NR+NC-1)*NH2 part of this array must -C contain the multivariable sequence M(k), where k = 1,2, -C ...,(NR+NC-1). Specifically, each parameter M(k) is an -C NH1-by-NH2 matrix whose (i,j)-th element must be stored in -C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NH1). -C -C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) -C The leading NH1*NR-by-NH2*NC part of this array contains -C the block Toeplitz expansion of the multivariable sequence -C M(k). -C -C LDT INTEGER -C The leading dimension of array T. LDT >= MAX(1,NH1*NR). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The NH1-by-NH2 dimensional parameters M(k) of a multivariable -C sequence are arranged into a matrix T in Toeplitz form such that -C -C | M(NC) M(NC-1) M(NC-2) . . . M(1) | -C | | -C | M(NC+1) M(NC) M(NC-1) . . . M(2) | -C T = | . . . . |. -C | . . . . | -C | . . . . | -C | | -C | M(NR+NC-1) M(NR+NC-2) M(NR+NC-3) . . . M(NR) | -C -C REFERENCES -C -C [1] Johvidov, J.S. -C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, -C (translated by G.P.A. Thijsse, I. Gohberg, ed.). -C Birkhaeuser, Boston, 1982. -C -C NUMERICAL ASPECTS -C -C The time taken is approximately proportional to -C NH1 x NH2 x NR x NC. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01DD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Multivariable system, Toeplitz matrix. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR -C .. Array Arguments .. - DOUBLE PRECISION H(LDH,*), T(LDT,*) -C .. Local Scalars .. - INTEGER IH, IT, JT, NCOL, NROW -C .. External Subroutines .. - EXTERNAL DLACPY, XERBLA -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NH1.LT.0 ) THEN - INFO = -1 - ELSE IF( NH2.LT.0 ) THEN - INFO = -2 - ELSE IF( NR.LT.0 ) THEN - INFO = -3 - ELSE IF( NC.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN - INFO = -6 - ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01PD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) - $ RETURN -C -C Construct the last block column of T. -C - IH = 1 - NROW = (NR-1)*NH1 - NCOL = (NC-1)*NH2 + 1 -C - DO 10 IT = 1, NROW+NH1, NH1 - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,NCOL), - $ LDT ) - IH = IH + NH2 - 10 CONTINUE -C -C Construct the remaining block columns of T in backward order. -C - DO 20 JT = NCOL-NH2, 1, -NH2 - CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT+NH2), LDT, T(1,JT), - $ LDT ) - CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), - $ LDT ) - IH = IH + NH2 - 20 CONTINUE -C - RETURN -C *** Last line of TF01PD *** - END diff --git a/slycot/src/TF01QD.f b/slycot/src/TF01QD.f deleted file mode 100644 index a2d3696c..00000000 --- a/slycot/src/TF01QD.f +++ /dev/null @@ -1,234 +0,0 @@ - SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute N Markov parameters M(1), M(2),..., M(N) from a -C multivariable system whose transfer function matrix G(z) is given. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NC (input) INTEGER -C The number of system outputs, i.e. the number of rows in -C the transfer function matrix G(z). NC >= 0. -C -C NB (input) INTEGER -C The number of system inputs, i.e. the number of columns in -C the transfer function matrix G(z). NB >= 0. -C -C N (input) INTEGER -C The number of Markov parameters M(k) to be computed. -C N >= 0. -C -C IORD (input) INTEGER array, dimension (NC*NB) -C This array must contain the order r of the elements of the -C transfer function matrix G(z), stored row by row. -C For example, the order of the (i,j)-th element of G(z) is -C given by IORD((i-1)xNB+j). -C -C AR (input) DOUBLE PRECISION array, dimension (NA), where -C NA = IORD(1) + IORD(2) + ... + IORD(NC*NB). -C The leading NA elements of this array must contain the -C denominator coefficients AR(1),...,AR(r) in equation (1) -C of the (i,j)-th element of the transfer function matrix -C G(z), stored row by row, i.e. in the order -C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., -C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given -C in decreasing order of powers of z; the coefficient of the -C highest order term is assumed to be equal to 1. -C -C MA (input) DOUBLE PRECISION array, dimension (NA) -C The leading NA elements of this array must contain the -C numerator coefficients MA(1),...,MA(r) in equation (1) -C of the (i,j)-th element of the transfer function matrix -C G(z), stored row by row, i.e. in the order -C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., -C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given -C in decreasing order of powers of z. -C -C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) -C The leading NC-by-N*NB part of this array contains the -C multivariable Markov parameter sequence M(k), where each -C parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N. -C The Markov parameters are stored such that H(i,(k-1)xNB+j) -C contains the (i,j)-th element of M(k) for i = 1,2,...,NC -C and j = 1,2,...,NB. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NC). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The (i,j)-th element of G(z), defining the particular I/O transfer -C between output i and input j, has the following form: -C -C -1 -2 -r -C MA(1)z + MA(2)z + ... + MA(r)z -C G (z) = ----------------------------------------. (1) -C ij -1 -2 -r -C 1 + AR(1)z + AR(2)z + ... + AR(r)z -C -C The (i,j)-th element of G(z) is defined by its order r, its r -C moving average coefficients (= numerator) MA(1),...,MA(r) and its -C r autoregressive coefficients (= denominator) AR(1),...,AR(r). The -C coefficient of the constant term in the denominator is assumed to -C be equal to 1. -C -C The relationship between the (i,j)-th element of the Markov -C parameters M(1),M(2),...,M(N) and the corresponding element of the -C transfer function matrix G(z) is given by: -C -C -1 -2 -k -C G (z) = M (0) + M (1)z + M (2)z + ... + M (k)z + ...(2) -C ij ij ij ij ij -C -C Equating (1) and (2), we find that the relationship between the -C (i,j)-th element of the Markov parameters M(k) and the ARMA -C parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th -C element of the transfer function matrix G(z) is as follows: -C -C M (1) = MA(1), -C ij -C k-1 -C M (k) = MA(k) - SUM AR(p) x M (k-p) for 1 < k <= r and -C ij p=1 ij -C r -C M (k+r) = - SUM AR(p) x M (k+r-p) for k > 0. -C ij p=1 ij -C -C From these expressions the Markov parameters M(k) are computed -C element by element. -C -C REFERENCES -C -C [1] Luenberger, D.G. -C Introduction to Dynamic Systems: Theory, Models and -C Applications. -C John Wiley & Sons, New York, 1979. -C -C NUMERICAL ASPECTS -C -C The computation of the (i,j)-th element of M(k) requires: -C (k-1) multiplications and k additions if k <= r; -C r multiplications and r additions if k > r. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Markov parameters, multivariable system, transfer function, -C transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDH, N, NB, NC -C .. Array Arguments .. - INTEGER IORD(*) - DOUBLE PRECISION AR(*), H(LDH,*), MA(*) -C .. Local Scalars .. - INTEGER I, J, JJ, JK, K, KI, LDHNB, NL, NORD -C .. External Functions .. - DOUBLE PRECISION DDOT - EXTERNAL DDOT -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NC.LT.0 ) THEN - INFO = -1 - ELSE IF( NB.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01QD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MAX( NC, NB, N ).EQ.0 ) - $ RETURN -C - LDHNB = LDH*NB - NL = 1 - K = 1 -C - DO 60 I = 1, NC -C - DO 50 J = 1, NB - NORD = IORD(K) - H(I,J) = MA(NL) - JK = J -C - DO 20 KI = 1, NORD - 1 - JK = JK + NB - H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J), - $ -LDHNB ) - 20 CONTINUE -C - DO 40 JJ = J, J + (N - NORD - 1)*NB, NB - JK = JK + NB - H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB ) - 40 CONTINUE -C - NL = NL + NORD - K = K + 1 - 50 CONTINUE -C - 60 CONTINUE -C - RETURN -C *** Last line of TF01QD *** - END diff --git a/slycot/src/TF01RD.f b/slycot/src/TF01RD.f deleted file mode 100644 index d28a6ed9..00000000 --- a/slycot/src/TF01RD.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute N Markov parameters M(1), M(2),..., M(N) from the -C parameters (A,B,C) of a linear time-invariant system, where each -C M(k) is an NC-by-NB matrix and k = 1,2,...,N. -C -C All matrices are treated as dense, and hence TF01RD is not -C intended for large sparse problems. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C NA (input) INTEGER -C The order of the matrix A. NA >= 0. -C -C NB (input) INTEGER -C The number of system inputs. NB >= 0. -C -C NC (input) INTEGER -C The number of system outputs. NC >= 0. -C -C N (input) INTEGER -C The number of Markov parameters M(k) to be computed. -C N >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,NA) -C The leading NA-by-NA part of this array must contain the -C state matrix A of the system. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,NA). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,NB) -C The leading NA-by-NB part of this array must contain the -C input matrix B of the system. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,NA). -C -C C (input) DOUBLE PRECISION array, dimension (LDC,NA) -C The leading NC-by-NA part of this array must contain the -C output matrix C of the system. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,NC). -C -C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) -C The leading NC-by-N*NB part of this array contains the -C multivariable parameters M(k), where each parameter M(k) -C is an NC-by-NB matrix and k = 1,2,...,N. The Markov -C parameters are stored such that H(i,(k-1)xNB+j) contains -C the (i,j)-th element of M(k) for i = 1,2,...,NC and -C j = 1,2,...,NB. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,NC). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, 2*NA*NC). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C For the linear time-invariant discrete-time system -C -C x(k+1) = A x(k) + B u(k) -C y(k) = C x(k) + D u(k), -C -C the transfer function matrix G(z) is given by -C -1 -C G(z) = C(zI-A) B + D -C -1 -2 2 -3 -C = D + CB z + CAB z + CA B z + ... (1) -C -C Using Markov parameters, G(z) can also be written as -C -1 -2 -3 -C G(z) = M(0) + M(1)z + M(2)z + M(3)z + ... (2) -C -C k-1 -C Equating (1) and (2), we find that M(0) = D and M(k) = C A B -C for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are -C computed. -C -C REFERENCES -C -C [1] Chen, C.T. -C Introduction to Linear System Theory. -C H.R.W. Series in Electrical Engineering, Electronics and -C Systems, Holt, Rinehart and Winston Inc., London, 1970. -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately (NA + NB) x NA x NC x N -C multiplications and additions. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. -C Supersedes Release 2.0 routine TF01FD by S. Van Huffel, Katholieke -C Univ. Leuven, Belgium. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Markov parameters, multivariable system, time-invariant system, -C transfer function, transfer matrix. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDH, LDWORK, N, NA, NB, NC -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), H(LDH,*) -C .. Local Scalars .. - INTEGER I, JWORK, K, LDW -C .. External Subroutines .. - EXTERNAL DGEMM, DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( NA.LT.0 ) THEN - INFO = -1 - ELSE IF( NB.LT.0 ) THEN - INFO = -2 - ELSE IF( NC.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, NA ) ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( 1, NA ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, NC ) ) THEN - INFO = -10 - ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.MAX( 1, 2*NA*NC ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TF01RD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( MIN( NA, NB, NC, N ).EQ.0 ) - $ RETURN -C - JWORK = 1 + NC*NA - LDW = MAX( 1, NC ) - I = 1 -C -C Copy C in the workspace beginning from the position JWORK. -C This workspace will contain the product C*A**(K-1), K = 1,2,...,N. -C - CALL DLACPY( 'Full', NC, NA, C, LDC, DWORK(JWORK), LDW ) -C -C Form M(1), M(2), ..., M(N). -C - DO 10 K = 1, N - CALL DLACPY( 'Full', NC, NA, DWORK(JWORK), LDW, DWORK, LDW ) -C -C Form (C * A**(K-1)) * B = M(K). -C - CALL DGEMM( 'No transpose', 'No transpose', NC, NB, NA, ONE, - $ DWORK, LDW, B, LDB, ZERO, H(1,I), LDH ) -C - IF ( K.NE.N ) THEN -C -C Form C * A**K. -C - CALL DGEMM( 'No transpose', 'No transpose', NC, NA, NA, ONE, - $ DWORK, LDW, A, LDA, ZERO, DWORK(JWORK), LDW ) -C - I = I + NB - END IF - 10 CONTINUE -C - RETURN -C *** Last line of TF01RD *** - END diff --git a/slycot/src/TG01AD.f b/slycot/src/TG01AD.f deleted file mode 100644 index 5bae2d7b..00000000 --- a/slycot/src/TG01AD.f +++ /dev/null @@ -1,513 +0,0 @@ - SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, - $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance the matrices of the system pencil -C -C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, -C ( C 0 ) ( 0 0 ) -C -C corresponding to the descriptor triple (A-lambda E,B,C), -C by balancing. This involves diagonal similarity transformations -C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system -C (A-lambda E,B,C) to make the rows and columns of system pencil -C matrices -C -C diag(Dl,I) * S * diag(Dr,I) -C -C as close in norm as possible. Balancing may reduce the 1-norms -C of the matrices of the system pencil S. -C -C The balancing can be performed optionally on the following -C particular system pencils -C -C S = A-lambda E, -C -C S = ( A-lambda E B ), or -C -C S = ( A-lambda E ). -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B, A and E matrices are involved in balancing; -C = 'C': C, A and E matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C THRESH (input) DOUBLE PRECISION -C Threshold value for magnitude of elements: -C elements with magnitude less than or equal to -C THRESH are ignored for balancing. THRESH >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*A*Dr. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*E*Dr. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, if M > 0, the leading L-by-M part of this array -C contains the balanced matrix Dl*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*Dr. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C LSCALE (output) DOUBLE PRECISION array, dimension (L) -C The scaling factors applied to S from left. If Dl(j) is -C the scaling factor applied to row j, then -C SCALE(j) = Dl(j), for j = 1,...,L. -C -C RSCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S from right. If Dr(j) is -C the scaling factor applied to column j, then -C SCALE(j) = Dr(j), for j = 1,...,N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(Dl,I) * S * diag(Dr,I) -C -C to make the 1-norms of each row of the first L rows of S and its -C corresponding N columns nearly equal. -C -C Information about the diagonal matrices Dl and Dr are returned in -C the vectors LSCALE and RSCALE, respectively. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C [2] R.C. Ward, R. C. -C Balancing the generalized eigenvalue problem. -C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the LAPACK routine DGGBAL. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003, March 2004, Jan. 2009. -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION HALF, ONE, ZERO - PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) - DOUBLE PRECISION SCLFAC, THREE - PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P - DOUBLE PRECISION THRESH -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), LSCALE( * ), - $ RSCALE( * ) -C .. Local Scalars .. - LOGICAL WITHB, WITHC - INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, - $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, - $ NRP2 - DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, - $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, - $ SFMIN, SUM, T, TA, TB, TC, TE -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( THRESH.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01AD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DUM( 1 ) = ONE - IF( L.GT.0 ) THEN - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - ELSE IF( N.GT.0 ) THEN - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - END IF - RETURN - END IF -C -C Initialize balancing and allocate work storage. -C - KW1 = N - KW2 = KW1 + L - KW3 = KW2 + L - KW4 = KW3 + N - KW5 = KW4 + L - DUM( 1 ) = ZERO - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) -C -C Compute right side vector in resulting linear equations. -C - BASL = LOG10( SCLFAC ) - DO 20 I = 1, L - DO 10 J = 1, N - TE = ABS( E( I, J ) ) - TA = ABS( A( I, J ) ) - IF( TA.GT.THRESH ) THEN - TA = LOG10( TA ) / BASL - ELSE - TA = ZERO - END IF - IF( TE.GT.THRESH ) THEN - TE = LOG10( TE ) / BASL - ELSE - TE = ZERO - END IF - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE - 10 CONTINUE - 20 CONTINUE -C - IF( M.EQ.0 ) THEN - WITHB = .FALSE. - TB = ZERO - END IF - IF( P.EQ.0 ) THEN - WITHC = .FALSE. - TC = ZERO - END IF -C - IF( WITHB ) THEN - DO 30 I = 1, L - J = IDAMAX( M, B( I, 1 ), LDB ) - TB = ABS( B( I, J ) ) - IF( TB.GT.THRESH ) THEN - TB = LOG10( TB ) / BASL - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB - END IF - 30 CONTINUE - END IF -C - IF( WITHC ) THEN - DO 40 J = 1, N - I = IDAMAX( P, C( 1, J ), 1 ) - TC = ABS( C( I, J ) ) - IF( TC.GT.THRESH ) THEN - TC = LOG10( TC ) / BASL - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC - END IF - 40 CONTINUE - END IF -C - COEF = ONE / DBLE( L+N ) - COEF2 = COEF*COEF - COEF5 = HALF*COEF2 - NRP2 = MAX( L, N ) + 2 - BETA = ZERO - IT = 1 -C -C Start generalized conjugate gradient iteration. -C - 50 CONTINUE -C - GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + - $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) -C - EW = ZERO - DO 60 I = 1, L - EW = EW + DWORK( I+KW4 ) - 60 CONTINUE -C - EWC = ZERO - DO 70 I = 1, N - EWC = EWC + DWORK( I+KW5 ) - 70 CONTINUE -C - GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - - $ COEF5*( EW - EWC )**2 - IF( GAMMA.EQ.ZERO ) - $ GO TO 160 - IF( IT.NE.1 ) - $ BETA = GAMMA / PGAMMA - T = COEF5*( EWC - THREE*EW ) - TC = COEF5*( EW - THREE*EWC ) -C - CALL DSCAL( N+L, BETA, DWORK, 1 ) -C - CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) - CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) -C - DO 80 J = 1, N - DWORK( J ) = DWORK( J ) + TC - 80 CONTINUE -C - DO 90 I = 1, L - DWORK( I+KW1 ) = DWORK( I+KW1 ) + T - 90 CONTINUE -C -C Apply matrix to vector. -C - DO 110 I = 1, L - KOUNT = 0 - SUM = ZERO - DO 100 J = 1, N - IF( ABS( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - IF( ABS( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - 100 CONTINUE - IF( WITHB ) THEN - J = IDAMAX( M, B( I, 1 ), LDB ) - IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM - 110 CONTINUE -C - DO 130 J = 1, N - KOUNT = 0 - SUM = ZERO - DO 120 I = 1, L - IF( ABS( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - IF( ABS( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - 120 CONTINUE - IF( WITHC ) THEN - I = IDAMAX( P, C( 1, J ), 1 ) - IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM - 130 CONTINUE -C - SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + - $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) - ALPHA = GAMMA / SUM -C -C Determine correction to current iteration. -C - CMAX = ZERO - DO 140 I = 1, L - COR = ALPHA*DWORK( I+KW1 ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - LSCALE( I ) = LSCALE( I ) + COR - 140 CONTINUE -C - DO 150 J = 1, N - COR = ALPHA*DWORK( J ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - RSCALE( J ) = RSCALE( J ) + COR - 150 CONTINUE - IF( CMAX.LT.HALF ) - $ GO TO 160 -C - CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) - CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) -C - PGAMMA = GAMMA - IT = IT + 1 - IF( IT.LE.NRP2 ) - $ GO TO 50 -C -C End generalized conjugate gradient iteration. -C - 160 CONTINUE - SFMIN = DLAMCH( 'Safe minimum' ) - SFMAX = ONE / SFMIN - LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) - LSFMAX = INT( LOG10( SFMAX ) / BASL ) -C -C Compute left diagonal scaling matrix. -C - DO 170 I = 1, L - IRAB = IDAMAX( N, A( I, 1 ), LDA ) - RAB = ABS( A( I, IRAB ) ) - IRAB = IDAMAX( N, E( I, 1 ), LDE ) - RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) - IF( WITHB ) THEN - IRAB = IDAMAX( M, B( I, 1 ), LDB ) - RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) - END IF - 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 - 170 CONTINUE -C -C Compute right diagonal scaling matrix. -C - DO 180 J = 1, N - ICAB = IDAMAX( L, A( 1, J ), 1 ) - CAB = ABS( A( ICAB, J ) ) - ICAB = IDAMAX( L, E( 1, J ), 1 ) - CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) - IF( WITHC ) THEN - ICAB = IDAMAX( P, C( 1, J ), 1 ) - CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) - END IF - LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) - JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) - JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) - RSCALE( J ) = SCLFAC**JC - 180 CONTINUE -C -C Row scaling of matrices A, E and B. -C - DO 190 I = 1, L - CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) - CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) - IF( WITHB ) - $ CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) - 190 CONTINUE -C -C Column scaling of matrices A, E and C. -C - DO 200 J = 1, N - CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 ) - CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 ) - IF( WITHC ) - $ CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 ) - 200 CONTINUE -C - RETURN -C *** Last line of TG01AD *** - END diff --git a/slycot/src/TG01AZ.f b/slycot/src/TG01AZ.f deleted file mode 100644 index 2c0bb3bc..00000000 --- a/slycot/src/TG01AZ.f +++ /dev/null @@ -1,523 +0,0 @@ - SUBROUTINE TG01AZ( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, - $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To balance the matrices of the system pencil -C -C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, -C ( C 0 ) ( 0 0 ) -C -C corresponding to the descriptor triple (A-lambda E,B,C), -C by balancing. This involves diagonal similarity transformations -C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system -C (A-lambda E,B,C) to make the rows and columns of system pencil -C matrices -C -C diag(Dl,I) * S * diag(Dr,I) -C -C as close in norm as possible. Balancing may reduce the 1-norms -C of the matrices of the system pencil S. -C -C The balancing can be performed optionally on the following -C particular system pencils -C -C S = A-lambda E, -C -C S = ( A-lambda E B ), or -C -C S = ( A-lambda E ). -C ( C ) -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates which matrices are involved in balancing, as -C follows: -C = 'A': All matrices are involved in balancing; -C = 'B': B, A and E matrices are involved in balancing; -C = 'C': C, A and E matrices are involved in balancing; -C = 'N': B and C matrices are not involved in balancing. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C THRESH (input) DOUBLE PRECISION -C Threshold value for magnitude of elements: -C elements with magnitude less than or equal to -C THRESH are ignored for balancing. THRESH >= 0. -C The magnitude is computed as the sum of the absolute -C values of the real and imaginary parts. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*A*Dr. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the balanced matrix Dl*E*Dr. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, if M > 0, the leading L-by-M part of this array -C contains the balanced matrix Dl*B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the balanced matrix C*Dr. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C LSCALE (output) DOUBLE PRECISION array, dimension (L) -C The scaling factors applied to S from left. If Dl(j) is -C the scaling factor applied to row j, then -C SCALE(j) = Dl(j), for j = 1,...,L. -C -C RSCALE (output) DOUBLE PRECISION array, dimension (N) -C The scaling factors applied to S from right. If Dr(j) is -C the scaling factor applied to column j, then -C SCALE(j) = Dr(j), for j = 1,...,N. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C Balancing consists of applying a diagonal similarity -C transformation -C -1 -C diag(Dl,I) * S * diag(Dr,I) -C -C to make the 1-norms of each row of the first L rows of S and its -C corresponding N columns nearly equal. -C -C Information about the diagonal matrices Dl and Dr are returned in -C the vectors LSCALE and RSCALE, respectively. -C -C REFERENCES -C -C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C [2] R.C. Ward, R. C. -C Balancing the generalized eigenvalue problem. -C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Balancing, eigenvalue, matrix algebra, matrix operations, -C similarity transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION HALF, ONE, ZERO - PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) - DOUBLE PRECISION SCLFAC, THREE - PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) -C .. Scalar Arguments .. - CHARACTER JOB - INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P - DOUBLE PRECISION THRESH -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ E( LDE, * ) - DOUBLE PRECISION DWORK( * ), LSCALE( * ), RSCALE( * ) -C .. Local Scalars .. - LOGICAL WITHB, WITHC - INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, - $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, - $ NRP2 - DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, - $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, - $ SFMIN, SUM, T, TA, TB, TC, TE - COMPLEX*16 CDUM -C .. Local Arrays .. - DOUBLE PRECISION DUM( 1 ) -C .. External Functions .. - LOGICAL LSAME - INTEGER IZAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL DDOT, DLAMCH, IZAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA, ZDSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN -C .. -C .. Statement Functions .. - DOUBLE PRECISION CABS1 -C .. -C .. Statement Function definitions .. - CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) -C -C .. Executable Statements .. -C -C Test the input parameters. -C - INFO = 0 - WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) - WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) -C - IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) - $ THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( THRESH.LT.ZERO ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01AZ', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DUM( 1 ) = ONE - IF( L.GT.0 ) THEN - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - ELSE IF( N.GT.0 ) THEN - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - END IF - RETURN - END IF -C -C Initialize balancing and allocate work storage. -C - KW1 = N - KW2 = KW1 + L - KW3 = KW2 + L - KW4 = KW3 + N - KW5 = KW4 + L - DUM( 1 ) = ZERO - CALL DCOPY( L, DUM, 0, LSCALE, 1 ) - CALL DCOPY( N, DUM, 0, RSCALE, 1 ) - CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) -C -C Compute right side vector in resulting linear equations. -C - BASL = LOG10( SCLFAC ) - DO 20 I = 1, L - DO 10 J = 1, N - TE = CABS1( E( I, J ) ) - TA = CABS1( A( I, J ) ) - IF( TA.GT.THRESH ) THEN - TA = LOG10( TA ) / BASL - ELSE - TA = ZERO - END IF - IF( TE.GT.THRESH ) THEN - TE = LOG10( TE ) / BASL - ELSE - TE = ZERO - END IF - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE - 10 CONTINUE - 20 CONTINUE -C - IF( M.EQ.0 ) THEN - WITHB = .FALSE. - TB = ZERO - END IF - IF( P.EQ.0 ) THEN - WITHC = .FALSE. - TC = ZERO - END IF -C - IF( WITHB ) THEN - DO 30 I = 1, L - J = IZAMAX( M, B( I, 1 ), LDB ) - TB = CABS1( B( I, J ) ) - IF( TB.GT.THRESH ) THEN - TB = LOG10( TB ) / BASL - DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB - END IF - 30 CONTINUE - END IF -C - IF( WITHC ) THEN - DO 40 J = 1, N - I = IZAMAX( P, C( 1, J ), 1 ) - TC = CABS1( C( I, J ) ) - IF( TC.GT.THRESH ) THEN - TC = LOG10( TC ) / BASL - DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC - END IF - 40 CONTINUE - END IF -C - COEF = ONE / DBLE( L+N ) - COEF2 = COEF*COEF - COEF5 = HALF*COEF2 - NRP2 = MAX( L, N ) + 2 - BETA = ZERO - IT = 1 -C -C Start generalized conjugate gradient iteration. -C - 50 CONTINUE -C - GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + - $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) -C - EW = ZERO - DO 60 I = 1, L - EW = EW + DWORK( I+KW4 ) - 60 CONTINUE -C - EWC = ZERO - DO 70 I = 1, N - EWC = EWC + DWORK( I+KW5 ) - 70 CONTINUE -C - GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - - $ COEF5*( EW - EWC )**2 - IF( GAMMA.EQ.ZERO ) - $ GO TO 160 - IF( IT.NE.1 ) - $ BETA = GAMMA / PGAMMA - T = COEF5*( EWC - THREE*EW ) - TC = COEF5*( EW - THREE*EWC ) -C - CALL DSCAL( N+L, BETA, DWORK, 1 ) -C - CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) - CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) -C - DO 80 J = 1, N - DWORK( J ) = DWORK( J ) + TC - 80 CONTINUE -C - DO 90 I = 1, L - DWORK( I+KW1 ) = DWORK( I+KW1 ) + T - 90 CONTINUE -C -C Apply matrix to vector. -C - DO 110 I = 1, L - KOUNT = 0 - SUM = ZERO - DO 100 J = 1, N - IF( CABS1( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - IF( CABS1( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( J ) - END IF - 100 CONTINUE - IF( WITHB ) THEN - J = IZAMAX( M, B( I, 1 ), LDB ) - IF( CABS1( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM - 110 CONTINUE -C - DO 130 J = 1, N - KOUNT = 0 - SUM = ZERO - DO 120 I = 1, L - IF( CABS1( A( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - IF( CABS1( E( I, J ) ).GT.THRESH ) THEN - KOUNT = KOUNT + 1 - SUM = SUM + DWORK( I+KW1 ) - END IF - 120 CONTINUE - IF( WITHC ) THEN - I = IZAMAX( P, C( 1, J ), 1 ) - IF( CABS1( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 - END IF - DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM - 130 CONTINUE -C - SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + - $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) - ALPHA = GAMMA / SUM -C -C Determine correction to current iteration. -C - CMAX = ZERO - DO 140 I = 1, L - COR = ALPHA*DWORK( I+KW1 ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - LSCALE( I ) = LSCALE( I ) + COR - 140 CONTINUE -C - DO 150 J = 1, N - COR = ALPHA*DWORK( J ) - IF( ABS( COR ).GT.CMAX ) - $ CMAX = ABS( COR ) - RSCALE( J ) = RSCALE( J ) + COR - 150 CONTINUE - IF( CMAX.LT.HALF ) - $ GO TO 160 -C - CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) - CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) -C - PGAMMA = GAMMA - IT = IT + 1 - IF( IT.LE.NRP2 ) - $ GO TO 50 -C -C End generalized conjugate gradient iteration. -C - 160 CONTINUE - SFMIN = DLAMCH( 'Safe minimum' ) - SFMAX = ONE / SFMIN - LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) - LSFMAX = INT( LOG10( SFMAX ) / BASL ) -C -C Compute left diagonal scaling matrix. -C - DO 170 I = 1, L - IRAB = IZAMAX( N, A( I, 1 ), LDA ) - RAB = ABS( A( I, IRAB ) ) - IRAB = IZAMAX( N, E( I, 1 ), LDE ) - RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) - IF( WITHB ) THEN - IRAB = IZAMAX( M, B( I, 1 ), LDB ) - RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) - END IF - 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 - 170 CONTINUE -C -C Compute right diagonal scaling matrix. -C - DO 180 J = 1, N - ICAB = IZAMAX( L, A( 1, J ), 1 ) - CAB = ABS( A( ICAB, J ) ) - ICAB = IZAMAX( L, E( 1, J ), 1 ) - CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) - IF( WITHC ) THEN - ICAB = IZAMAX( P, C( 1, J ), 1 ) - CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) - END IF - LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) - JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) - JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) - RSCALE( J ) = SCLFAC**JC - 180 CONTINUE -C -C Row scaling of matrices A, E and B. -C - DO 190 I = 1, L - CALL ZDSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) - CALL ZDSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) - IF( WITHB ) - $ CALL ZDSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) - 190 CONTINUE -C -C Column scaling of matrices A, E and C. -C - DO 200 J = 1, N - CALL ZDSCAL( L, RSCALE( J ), A( 1, J ), 1 ) - CALL ZDSCAL( L, RSCALE( J ), E( 1, J ), 1 ) - IF( WITHC ) - $ CALL ZDSCAL( P, RSCALE( J ), C( 1, J ), 1 ) - 200 CONTINUE -C - RETURN -C *** Last line of TG01AZ *** - END diff --git a/slycot/src/TG01BD.f b/slycot/src/TG01BD.f deleted file mode 100644 index 3a0681e5..00000000 --- a/slycot/src/TG01BD.f +++ /dev/null @@ -1,434 +0,0 @@ - SUBROUTINE TG01BD( JOBE, COMPQ, COMPZ, N, M, P, ILO, IHI, A, LDA, - $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the matrices A and E of the system pencil -C -C S = ( A B ) - lambda ( E 0 ) , -C ( C 0 ) ( 0 0 ) -C -C corresponding to the descriptor triple (A-lambda E,B,C), -C to generalized upper Hessenberg form using orthogonal -C transformations, -C -C Q' * A * Z = H, Q' * E * Z = T, -C -C where H is upper Hessenberg, T is upper triangular, Q and Z -C are orthogonal, and ' means transpose. The corresponding -C transformations, written compactly as diag(Q',I) * S * diag(Z,I), -C are also applied to B and C, getting Q' * B and C * Z. -C -C The orthogonal matrices Q and Z are determined as products of -C Givens rotations. They may either be formed explicitly, or they -C may be postmultiplied into input matrices Q1 and Z1, so that -C -C Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' -C Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBE CHARACTER*1 -C Specifies whether E is a general square or an upper -C triangular matrix, as follows: -C = 'G': E is a general square matrix; -C = 'U': E is an upper triangular matrix. -C -C COMPQ CHARACTER*1 -C Indicates what should be done with matrix Q, as follows: -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'V': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C Indicates what should be done with matrix Z, as follows: -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'V': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrices A, E, and the number of rows of -C the matrix B. N >= 0. -C -C M (input) INTEGER -C The number of columns of the matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of the matrix C. P >= 0. -C -C ILO (input) INTEGER -C IHI (input) INTEGER -C It is assumed that A and E are already upper triangular in -C rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI could -C normally be set by a previous call to LAPACK Library -C routine DGGBAL; otherwise they should be set to 1 and N, -C respectively. -C 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. -C If JOBE = 'U', the matrix E is assumed upper triangular. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the upper Hessenberg matrix H = Q' * A * Z. The elements -C below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the descriptor matrix E. If JOBE = 'U', this -C matrix is assumed upper triangular. -C On exit, the leading N-by-N part of this array contains -C the upper triangular matrix T = Q' * E * Z. The elements -C below the diagonal are set to zero. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input/state matrix B. -C On exit, if M > 0, the leading N-by-M part of this array -C contains the transformed matrix Q' * B. -C The array B is not referenced if M = 0. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if M > 0; LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, if P > 0, the leading P-by-N part of this array -C contains the transformed matrix C * Z. -C The array C is not referenced if P = 0. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C If COMPQ = 'N': Q is not referenced; -C If COMPQ = 'I': on entry, Q need not be set, and on exit -C it contains the orthogonal matrix Q, -C where Q' is the product of the Givens -C transformations which are applied to A, -C E, and B on the left; -C If COMPQ = 'V': on entry, Q must contain an orthogonal -C matrix Q1, and on exit this is -C overwritten by Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced; -C If COMPZ = 'I': on entry, Z need not be set, and on exit -C it contains the orthogonal matrix Z, -C which is the product of the Givens -C transformations applied to A, E, and C -C on the right; -C If COMPZ = 'V': on entry, Z must contain an orthogonal -C matrix Z1, and on exit this is -C overwritten by Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) contains the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of the array DWORK. -C LDWORK >= 1, if JOBE = 'U'; -C LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where -C NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise. -C For good performance, if JOBE = 'G', LDWORK must generally -C be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where -C NB is the optimal block size. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit. -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C First, this routine computes the QR factorization of E and applies -C the transformations to A, B, and possibly Q. Then, the routine -C reduces A to upper Hessenberg form, preserving E triangular, by -C an unblocked reduction [1], using two sequences of plane rotations -C applied alternately from the left and from the right. The -C corresponding transformations may be accumulated and/or applied -C to the matrices B and C. If JOBE = 'U', the initial reduction of E -C to upper triangular form is skipped. -C -C This routine is a modification and extension of the LAPACK Library -C routine DGGHRD [2]. -C -C REFERENCES -C -C [1] Golub, G.H. and van Loan, C.F. -C Matrix Computations. Third Edition. -C M. D. Johns Hopkins University Press, Baltimore, 1996. -C -C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., -C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., -C Ostrouchov, S., and Sorensen, D. -C LAPACK Users' Guide: Second Edition. -C SIAM, Philadelphia, 1995. -C -C CONTRIBUTOR -C -C D. Sima, University of Bucharest, May 2001. -C V. Sima, Research Institute for Informatics, Bucharest, May 2001. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Eigenvalue, matrix algebra, matrix operations, similarity -C transformation. -C -C ********************************************************************* -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBE - INTEGER IHI, ILO, INFO, LDA, LDB, LDC, LDE, LDQ, - $ LDWORK, LDZ, M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, INQ, INZ, UPPER, WITHB, WITHC - INTEGER IERR, ITAU, IWRK, JCOL, JROW, MAXWRK, MINWRK - DOUBLE PRECISION CS, S, TEMP -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEQRF, DLARTG, DLASET, DORMQR, DROT, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX -C -C .. Executable Statements .. -C -C Test the input scalar parameters. -C - UPPER = LSAME( JOBE, 'U' ) - INQ = LSAME( COMPQ, 'I' ) - ILQ = LSAME( COMPQ, 'V' ) .OR. INQ - INZ = LSAME( COMPZ, 'I' ) - ILZ = LSAME( COMPZ, 'V' ) .OR. INZ - WITHB = M.GT.0 - WITHC = P.GT.0 -C - INFO = 0 - IF( .NOT.( UPPER .OR. LSAME( JOBE, 'G' ) ) ) THEN - INFO = -1 - ELSE IF( .NOT.( ILQ .OR. LSAME( COMPQ, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( .NOT.( ILZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( ILO.LT.1 ) THEN - INFO = -7 - ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( WITHB .AND. LDB.LT.N ) .OR. LDB.LT.1 ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -18 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -20 - ELSE - JROW = IHI + 1 - ILO - JCOL = N + 1 - ILO - IF( UPPER ) THEN - MINWRK = 1 - MAXWRK = 1 - ELSE - IF( ILQ ) THEN - MINWRK = N - ELSE - MINWRK = JCOL - END IF - MINWRK = MAX( 1, JROW + MAX( MINWRK, M ) ) - END IF - IF( LDWORK.LT.MINWRK ) - $ INFO = -22 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01BD', -INFO ) - RETURN - END IF -C -C Initialize Q and Z if desired. -C - IF( INQ ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) - IF( INZ ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( N.LE.1 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C - IF( .NOT.UPPER ) THEN -C -C Reduce E to triangular form (QR decomposition of E). -C -C (Note: Comments in the code beginning "Workspace:" describe the -C minimal amount of real workspace needed at that point in the -C code, as well as the preferred amount for good performance. -C NB refers to the optimal block size for the immediately -C following subroutine, as returned by ILAENV.) -C -C Workspace: need IHI+1-ILO+N+1-ILO; -C prefer IHI+1-ILO+(N+1-ILO)*NB. -C - ITAU = 1 - IWRK = ITAU + JROW - CALL DGEQRF( JROW, JCOL, E( ILO, ILO ), LDE, DWORK( ITAU ), - $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MINWRK ) -C -C Apply the orthogonal transformation to matrices A, B, and Q. -C Workspace: need IHI+1-ILO+N+1-ILO; -C prefer IHI+1-ILO+(N+1-ILO)*NB. -C - CALL DORMQR( 'Left', 'Transpose', JROW, JCOL, JROW, - $ E( ILO, ILO ), LDE, DWORK( ITAU ), A( ILO, ILO ), - $ LDA, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) -C - IF ( WITHB ) THEN -C -C Workspace: need IHI+1-ILO+M; -C prefer IHI+1-ILO+M*NB. -C - CALL DORMQR( 'Left', 'Transpose', JROW, M, JROW, - $ E( ILO, ILO ), LDE, DWORK( ITAU ), B( ILO, 1 ), - $ LDB, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - END IF -C - IF( ILQ ) THEN -C -C Workspace: need IHI+1-ILO+N; -C prefer IHI+1-ILO+N*NB. -C - CALL DORMQR( 'Right', 'No Transpose', N, JROW, JROW, - $ E( ILO, ILO ), LDE, DWORK( ITAU ), Q( 1, ILO ), - $ LDQ, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) - MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) - END IF - END IF -C -C Zero out lower triangle of E. -C - IF( JROW.GT.1 ) - $ CALL DLASET( 'Lower', JROW-1, JROW-1, ZERO, ZERO, - $ E( ILO+1, ILO ), LDE ) -C -C Reduce A and E and apply the transformations to B, C, Q and Z. -C - DO 20 JCOL = ILO, IHI - 2 -C - DO 10 JROW = IHI, JCOL + 2, -1 -C -C Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL). -C - TEMP = A( JROW-1, JCOL ) - CALL DLARTG( TEMP, A( JROW, JCOL ), CS, S, - $ A( JROW-1, JCOL ) ) - A( JROW, JCOL ) = ZERO - CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, - $ A( JROW, JCOL+1 ), LDA, CS, S ) - CALL DROT( N+2-JROW, E( JROW-1, JROW-1 ), LDE, - $ E( JROW, JROW-1 ), LDE, CS, S ) - IF( WITHB ) - $ CALL DROT( M, B( JROW-1, 1 ), LDB, B( JROW, 1 ), LDB, - $ CS, S ) - IF( ILQ ) - $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, CS, S ) -C -C Step 2: rotate columns JROW, JROW-1 to kill E(JROW,JROW-1). -C - TEMP = E( JROW, JROW ) - CALL DLARTG( TEMP, E( JROW, JROW-1 ), CS, S, - $ E( JROW, JROW ) ) - E( JROW, JROW-1 ) = ZERO - CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, CS, S ) - CALL DROT( JROW-1, E( 1, JROW ), 1, E( 1, JROW-1 ), 1, CS, - $ S ) - IF( WITHC ) - $ CALL DROT( P, C( 1, JROW ), 1, C( 1, JROW-1 ), 1, CS, S ) - IF( ILZ ) - $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, CS, S ) - 10 CONTINUE -C - 20 CONTINUE -C - DWORK( 1 ) = MAXWRK - RETURN -C *** Last line of TG01BD *** - END diff --git a/slycot/src/TG01CD.f b/slycot/src/TG01CD.f deleted file mode 100644 index 1ce07b1e..00000000 --- a/slycot/src/TG01CD.f +++ /dev/null @@ -1,292 +0,0 @@ - SUBROUTINE TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, Q, LDQ, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the descriptor system pair (A-lambda E,B) to the -C QR-coordinate form by computing an orthogonal transformation -C matrix Q such that the transformed descriptor system pair -C (Q'*A-lambda Q'*E, Q'*B) has the descriptor matrix Q'*E -C in an upper trapezoidal form. -C The left orthogonal transformations performed to reduce E -C can be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A and E. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E in upper trapezoidal form, -C i.e. -C -C ( E11 ) -C Q'*E = ( ) , if L >= N , -C ( 0 ) -C or -C -C Q'*E = ( E11 E12 ), if L < N , -C -C where E11 is an MIN(L,N)-by-MIN(L,N) upper triangular -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of Householder -C transformations which are applied to A, -C E, and B on the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain an orthogonal matrix -C Q1; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix -C Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)). -C For optimum performance -C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)*NB), -C where NB is the optimal blocksize. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes the QR factorization of E to reduce it -C to the upper trapezoidal form. -C -C The transformations are also applied to the rest of system -C matrices -C -C A <- Q' * A , B <- Q' * B. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSQR. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ - INTEGER INFO, L, LDA, LDB, LDE, LDQ, LDWORK, M, N -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), - $ E( LDE, * ), Q( LDQ, * ) -C .. Local Scalars .. - LOGICAL ILQ - INTEGER ICOMPQ, LN, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEQRF, DLASET, DORMQR, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Test the input parameters. -C - INFO = 0 - WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, M ) ) - IF( ICOMPQ.EQ.0 ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -6 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -10 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.WRKOPT ) THEN - INFO = -14 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01CD', -INFO ) - RETURN - END IF -C -C Initialize Q if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C - LN = MIN( L, N ) -C -C Compute the QR decomposition of E. -C -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DGEQRF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C Apply transformation on the rest of matrices. -C -C A <-- Q' * A. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK, - $ A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C B <-- Q' * B. -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( M.GT.0 ) THEN - CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE, DWORK, - $ B, LDB, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) - END IF -C -C Q <-- Q1 * Q. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) THEN - CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, DWORK, - $ Q, LDQ, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.GE.2 ) - $ CALL DLASET( 'Lower', L-1, LN, ZERO, ZERO, E( 2, 1 ), LDE ) -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01CD *** - END diff --git a/slycot/src/TG01DD.f b/slycot/src/TG01DD.f deleted file mode 100644 index cac8704d..00000000 --- a/slycot/src/TG01DD.f +++ /dev/null @@ -1,295 +0,0 @@ - SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the descriptor system pair (C,A-lambda E) to the -C RQ-coordinate form by computing an orthogonal transformation -C matrix Z such that the transformed descriptor system pair -C (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper -C trapezoidal form. -C The right orthogonal transformations performed to reduce E can -C be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix A*Z. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix E*Z in upper trapezoidal form, -C i.e. -C -C ( E11 ) -C E*Z = ( ) , if L >= N , -C ( R ) -C or -C -C E*Z = ( 0 R ), if L < N , -C -C where R is an MIN(L,N)-by-MIN(L,N) upper triangular -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of Householder -C transformations applied to A, E, and C -C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Z1; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)). -C For optimum performance -C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB), -C where NB is the optimal blocksize. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes the RQ factorization of E to reduce it -C the upper trapezoidal form. -C -C The transformations are also applied to the rest of system -C matrices -C -C A <- A * Z, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*N*N ) floating point operations. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSRQ. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPZ - INTEGER INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), - $ E( LDE, * ), Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILZ - INTEGER ICOMPZ, LN, WRKOPT -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGERQF, DLASET, DORMRQ, XERBLA -C .. Intrinsic Functions .. - INTRINSIC INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input parameters. -C - INFO = 0 - WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) ) - IF( ICOMPZ.EQ.0 ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( P.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -6 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -10 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -12 - ELSE IF( LDWORK.LT.WRKOPT ) THEN - INFO = -14 - END IF - IF( INFO .NE. 0 ) THEN - CALL XERBLA( 'TG01DD', -INFO ) - RETURN - END IF -C -C Initialize Q if necessary. -C - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DWORK( 1 ) = ONE - RETURN - END IF -C - LN = MIN( L, N ) -C -C Compute the RQ decomposition of E, E = R*Z. -C -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C Apply transformation on the rest of matrices. -C -C A <-- A * Z'. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE, - $ DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C C <-- C * Z'. -C Workspace: need MIN(L,N) + P; -C prefer MIN(L,N) + P*NB. -C - CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE, - $ DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) -C -C Z <-- Z1 * Z'. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - IF( ILZ ) THEN - CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ), - $ LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.LT.N ) THEN - CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE ) - IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, - $ E( 2, N-L+1 ), LDE ) - ELSE - IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO, - $ E( L-N+2, 1 ), LDE ) - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01DD *** - END diff --git a/slycot/src/TG01ED.f b/slycot/src/TG01ED.f deleted file mode 100644 index 1fe8e8bb..00000000 --- a/slycot/src/TG01ED.f +++ /dev/null @@ -1,793 +0,0 @@ - SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, - $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL, - $ DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for the descriptor system (A-lambda E,B,C) -C the orthogonal transformation matrices Q and Z such that the -C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an -C SVD (singular value decomposition) coordinate form with -C the system matrices Q'*A*Z and Q'*E*Z in the form -C -C ( A11 A12 ) ( Er 0 ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , -C ( A21 A22 ) ( 0 0 ) -C -C where Er is an invertible diagonal matrix having on the diagonal -C the decreasingly ordered nonzero singular values of E. -C Optionally, the A22 matrix can be further reduced to the -C SVD form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C where Ar is an invertible diagonal matrix having on the diagonal -C the decreasingly ordered nonzero singular values of A22. -C The left and/or right orthogonal transformations performed -C to reduce E and A22 are accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBA CHARACTER*1 -C = 'N': do not reduce A22; -C = 'R': reduce A22 to an SVD form. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix -C is in the form -C -C ( A11 * * ) -C Q'*A*Z = ( * Ar 0 ) , -C ( * 0 0 ) -C -C where A11 is a RANKE-by-RANKE matrix and Ar is a -C RNKA22-by-RNKA22 invertible diagonal matrix, with -C decresingly ordered positive diagonal elements. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E*Z. -C -C ( Er 0 ) -C Q'*E*Z = ( ) , -C ( 0 0 ) -C -C where Er is a RANKE-by-RANKE invertible diagonal matrix -C having on the diagonal the decreasingly ordered positive -C singular values of E. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,L) -C The leading L-by-L part of this array contains the -C orthogonal matrix Q, which is the accumulated product of -C transformations applied to A, E, and B on the left. -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= MAX(1,L). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the -C orthogonal matrix Z, which is the accumulated product of -C transformations applied to A, E, and C on the right. -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= MAX(1,N). -C -C RANKE (output) INTEGER -C The effective rank of matrix E, and thus also the order -C of the invertible diagonal submatrix Er. -C RANKE is computed as the number of singular values of E -C greater than TOL*SVEMAX, where SVEMAX is the maximum -C singular value of E. -C -C RNKA22 (output) INTEGER -C If JOBA = 'R', then RNKA22 is the effective rank of -C matrix A22, and thus also the order of the invertible -C diagonal submatrix Ar. RNKA22 is computed as the number -C of singular values of A22 greater than TOL*SVAMAX, -C where SVAMAX is an estimate of the maximum singular value -C of A. -C If JOBA = 'N', then RNKA22 is not referenced. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the rank of E -C and of A22. If TOL > 0, then singular values less than -C TOL*SVMAX are treated as zero, where SVMAX is the maximum -C singular value of E or an estimate of it for A and E. -C If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is -C used instead, where EPS is the machine precision -C (see LAPACK Library routine DLAMCH). TOL < 1. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(1,MIN(L,N) + -C MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: the QR algorithm has failed to converge when computing -C singular value decomposition. In this case INFO -C specifies how many superdiagonals did not converge. -C This failure is not likely to occur. -C -C METHOD -C -C The routine computes the singular value decomposition (SVD) of E, -C in the form -C -C ( Er 0 ) -C E = Q * ( ) * Z' -C ( 0 0 ) -C -C and finds the largest RANKE-by-RANKE leading diagonal submatrix -C Er whose condition number is less than 1/TOL. RANKE defines thus -C the effective rank of matrix E. -C If JOBA = 'R' the same reduction is performed on A22 in the -C partitioned matrix -C -C ( A11 A12 ) -C Q'*A*Z = ( ) , -C ( A21 A22 ) -C -C to obtain it in the form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an invertible diagonal matrix. -C -C The accumulated transformations are also applied to the rest of -C matrices -C -C B <- Q' * B, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSSV. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C Feb. 2000, Oct. 2001, May 2003. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER JOBA - INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, - $ LDZ, M, N, P, RNKA22, RANKE - DOUBLE PRECISION TOL -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL REDA - INTEGER I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT - DOUBLE PRECISION EPSM, SVEMAX, SVLMAX, TOLDEF -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD, - $ DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD, - $ MB03UD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C - REDA = LSAME( JOBA, 'R' ) -C -C Test the input parameters. -C - INFO = 0 - WRKOPT = MIN( L, N ) + - $ MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) ) - IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN - INFO = -1 - ELSE IF( L.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( P.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -7 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN - INFO = -11 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -13 - ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN - INFO = -15 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -17 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -20 - ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN - INFO = -22 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01ED', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - IF( L.GT.0 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( N.GT.0 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) - DWORK(1) = ONE - RANKE = 0 - IF( REDA ) RNKA22 = 0 - RETURN - END IF -C - LN = MIN( L, N ) - EPSM = DLAMCH( 'EPSILON' ) -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance for rank determination. -C - TOLDEF = EPSM * DBLE( L*N ) - END IF -C -C Set the estimate of the maximum singular value of E to -C max(||E||,||A||) to detect negligible A or E matrices. -C - SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ) , - $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) -C -C Compute the SVD of E -C -C ( Er 0 ) -C E = Qr * ( ) * Zr' -C ( 0 0 ) -C -C Workspace: needed MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N)); -C prefer larger. -C - LWR = LDWORK - LN - KW = LN + 1 -C - CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ, - $ DWORK(KW), LWR, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Determine the rank of E. -C - RANKE = 0 - IF( DWORK(1).GT.SVLMAX*EPSM ) THEN - RANKE = 1 - SVEMAX = DWORK(1) - DO 10 I = 2, LN - IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20 - RANKE = RANKE + 1 - 10 CONTINUE -C - 20 CONTINUE - END IF -C -C Apply transformation on the rest of matrices. -C - IF( RANKE.GT.0 ) THEN -C -C A <-- Qr' * A * Zr. -C - CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE, - $ Q, LDQ, A, LDA, ZERO, E, LDE ) - CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE, - $ E, LDE, Z, LDZ, ZERO, A, LDA ) -C -C B <-- Qr' * B. -C Workspace: need L; -C prefer L*M. -C - IF( LWR.GT.L*M .AND. M.GT.0 ) THEN -C - CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE, - $ Q, LDQ, B, LDB, ZERO, DWORK(KW), L ) - CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB ) - ELSE - DO 30 J = 1, M - CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 ) - 30 CONTINUE - END IF -C -C C <-- C * Zr. -C Workspace: need N; -C prefer P*N. -C - IF( LWR.GT.P*N ) THEN -C - CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE, - $ C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) ) - CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC ) - ELSE - DO 40 I = 1, P - CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ, - $ C(I,1), LDC, ZERO, DWORK(KW), 1 ) - CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC ) - 40 CONTINUE - END IF - WRKOPT = MAX( WRKOPT, L*M, P*N ) - END IF -C -C Reduce A22 if necessary. -C - IF( REDA ) THEN - LA22 = L - RANKE - NA22 = N - RANKE - LN2 = MIN( LA22, NA22 ) - IF( LN2.EQ.0 ) THEN - IR1 = 1 - RNKA22 = 0 - ELSE -C -C Compute the SVD of A22 using a storage saving approach. -C - IR1 = RANKE + 1 - IF( LA22.GE.NA22 ) THEN -C -C Compute the QR decomposition of A22 in the form -C -C A22 = Q2 * ( R2 ) , -C ( 0 ) -C -C where R2 is upper triangular. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Apply transformation Q2 to A, B, and Q. -C -C A <--diag(I, Q2') * A -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C B <-- diag(I, Q2') * B -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( M.GT.0 ) THEN - CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1), - $ LDB, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Q <-- Q * diag(I, Q2) -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Compute the SVD of the upper triangular submatrix R2 as -C -C ( Ar 0 ) -C R2 = Q2r * ( ) * Z2r' , -C ( 0 0 ) -C -C where Q2r is stored in E and Z2r' is stored in A22. -C Workspace: need MAX(1,5*MIN(L,N)); -C prefer larger. -C - CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA, - $ E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR, - $ INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Determine the rank of A22. -C - RNKA22 = 0 - IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN - RNKA22 = 1 - DO 50 I = IR1+1, LN - IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60 - RNKA22 = RNKA22 + 1 - 50 CONTINUE -C - 60 CONTINUE - END IF -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I,Q2r') * A * diag(I,Zr2) -C - CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE, - $ LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA, - $ ZERO, E(IR1,1), LDE ) - CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, - $ A(IR1,1), LDA ) - CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2, - $ LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA, - $ ZERO, E(1,IR1), LDE ) - CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, - $ A(1,IR1), LDA ) -C -C B <-- diag(I,Q2r') * B -C - IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN -C - CALL DGEMM( 'Transpose', 'No transpose', LN2, M, - $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), - $ LDB, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, - $ B(IR1,1), LDB ) - ELSE - DO 70 J = 1, M - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, B( IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) - 70 CONTINUE - END IF -C -C C <-- C * diag(I,Zr2) -C - IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN -C - CALL DGEMM( 'No transpose', 'Transpose', P, LN2, - $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), - $ LDA, ZERO, DWORK(KW), P ) - CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, - $ C(1,IR1), LDC ) - ELSE - DO 80 I = 1, P - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, C(I,IR1), LDC, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) - 80 CONTINUE - END IF -C -C Q <-- Q * diag(I, Qr2) -C - IF( LWR.GT.L*LN2 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', L, LN2, - $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), - $ LDE, ZERO, DWORK(KW), L ) - CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, - $ Q(1,IR1), LDQ ) - ELSE - DO 90 I = 1, L - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) - 90 CONTINUE - END IF -C -C Z' <-- diag(I, Zr2') * Z' -C - IF( LWR.GT.N*LN2 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', LN2, N, - $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), - $ LDZ, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, - $ Z(IR1,1), LDZ ) - ELSE - DO 100 J = 1, N - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, Z(IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) - 100 CONTINUE - END IF - END IF - ELSE -C -C Compute the LQ decomposition of A22 in the form -C -C A22 = ( L2 0 )* Z2 -C -C where L2 is lower triangular. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Apply transformation Z2 to A, C, and Z. -C -C A <-- A * diag(I, Z2') -C Workspace: need 2*MIN(L,N); -C prefer MIN(L,N) + MIN(L,N)*NB. -C - CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C C <-- C * diag(I, Z2') -C Workspace: need MIN(L,N) + P; -C prefer MIN(L,N) + P*NB. -C - IF ( P.GT.0 ) THEN - CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1), - $ LDC, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Z' <- diag(I, Z2) * Z' -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2, - $ A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ, - $ DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Compute the SVD of the lower triangular submatrix L2 as -C -C ( Ar 0 ) -C L2' = Z2r * ( ) * Q2r' -C ( 0 0 ) -C -C where Q2r' is stored in E and Z2r is stored in A22. -C Workspace: need MAX(1,5*MIN(L,N)); -C prefer larger. -C - CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA, - $ E(IR1,IR1), LDE ) - CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE, - $ A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW), - $ LWR, INFO ) - IF( INFO.GT.0 ) - $ RETURN - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C Determine the rank of A22. -C - RNKA22 = 0 - IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN - RNKA22 = 1 - DO 110 I = IR1+1, LN - IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120 - RNKA22 = RNKA22 + 1 - 110 CONTINUE -C - 120 CONTINUE - END IF -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I,Q2r') * A * diag(I,Zr2) -C - CALL DGEMM( 'No transpose', 'No transpose', LN2, - $ RANKE, LN2, ONE, E(IR1,IR1), LDE, - $ A(IR1,1), LDA, ZERO, E(IR1,1), LDE ) - CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, - $ A(IR1,1), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', RANKE, - $ LN2, LN2, ONE, A(1,IR1), LDA, - $ A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE ) - CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, - $ A(1,IR1), LDA ) -C -C B <-- diag(I,Q2r') * B -C - IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', LN2, M, - $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), - $ LDB, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, - $ B(IR1,1), LDB ) - ELSE - DO 130 J = 1, M - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, B( IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) - 130 CONTINUE - END IF -C -C C <-- C * diag(I,Zr2) -C - IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN -C - CALL DGEMM( 'No transpose', 'No transpose', P, LN2, - $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), - $ LDA, ZERO, DWORK(KW), P ) - CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, - $ C(1,IR1), LDC ) - ELSE - DO 140 I = 1, P - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, C(I,IR1), LDC, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) - 140 CONTINUE - END IF -C -C Q <-- Q * diag(I, Qr2) -C - IF( LWR.GT.L*LN2 ) THEN -C - CALL DGEMM( 'No transpose', 'Transpose', L, LN2, - $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), - $ LDE, ZERO, DWORK(KW), L ) - CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, - $ Q(1,IR1), LDQ ) - ELSE - DO 150 I = 1, L - CALL DGEMV( 'No transpose', LN2, LN2, ONE, - $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) - 150 CONTINUE - END IF -C -C Z' <-- diag(I, Zr2') * Z' -C - IF( LWR.GT.N*LN2 ) THEN -C - CALL DGEMM( 'Transpose', 'No transpose', LN2, N, - $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), - $ LDZ, ZERO, DWORK(KW), LN2 ) - CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, - $ Z(IR1,1), LDZ ) - ELSE - DO 160 J = 1, N - CALL DGEMV( 'Transpose', LN2, LN2, ONE, - $ A(IR1,IR1), LDA, Z(IR1,J), 1, - $ ZERO, DWORK(KW), 1 ) - CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) - 160 CONTINUE - END IF - END IF - END IF - END IF - END IF -C -C Set E. -C - CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) - CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 ) -C - IF( REDA ) THEN -C -C Set A22. -C - CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA ) - CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 ) - END IF -C -C Transpose Z. -C - DO 170 I = 2, N - CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) - 170 CONTINUE -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01ED *** - END diff --git a/slycot/src/TG01FD.f b/slycot/src/TG01FD.f deleted file mode 100644 index c50d5fc9..00000000 --- a/slycot/src/TG01FD.f +++ /dev/null @@ -1,725 +0,0 @@ - SUBROUTINE TG01FD( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, - $ TOL, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for the descriptor system (A-lambda E,B,C) -C the orthogonal transformation matrices Q and Z such that the -C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is -C in a SVD-like coordinate form with -C -C ( A11 A12 ) ( Er 0 ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , -C ( A21 A22 ) ( 0 0 ) -C -C where Er is an upper triangular invertible matrix. -C Optionally, the A22 matrix can be further reduced to the form -C -C ( Ar X ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix, and X either a full -C or a zero matrix. -C The left and/or right orthogonal transformations performed -C to reduce E and A22 can be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C JOBA CHARACTER*1 -C = 'N': do not reduce A22; -C = 'R': reduce A22 to a SVD-like upper triangular form. -C = 'T': reduce A22 to an upper trapezoidal form. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix -C is in the form -C -C ( A11 * * ) -C Q'*A*Z = ( * Ar X ) , -C ( * 0 0 ) -C -C where A11 is a RANKE-by-RANKE matrix and Ar is a -C RNKA22-by-RNKA22 invertible upper triangular matrix. -C If JOBA = 'R' then A has the above form with X = 0. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E*Z. -C -C ( Er 0 ) -C Q'*E*Z = ( ) , -C ( 0 0 ) -C -C where Er is a RANKE-by-RANKE upper triangular invertible -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of Householder -C transformations which are applied to A, -C E, and B on the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain an orthogonal matrix -C Q1; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix -C Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of Householder -C transformations applied to A, E, and C -C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Z1; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C RANKE (output) INTEGER -C The estimated rank of matrix E, and thus also the order -C of the invertible upper triangular submatrix Er. -C -C RNKA22 (output) INTEGER -C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of -C matrix A22, and thus also the order of the invertible -C upper triangular submatrix Ar. -C If JOBA = 'N', then RNKA22 is not referenced. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the rank of E -C and of A22. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the -C reciprocal condition numbers of leading submatrices -C of R or R22 in the QR decompositions E * P = Q * R of E -C or A22 * P22 = Q22 * R22 of A22. -C A submatrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = L*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). -C For optimal performance, LDWORK should be larger. -C -C If LDWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C DWORK array, returns this value as the first entry of -C the DWORK array, and no error message related to LDWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of E, in the form -C -C ( E11 E12 ) -C E * P = Q * ( ) -C ( 0 E22 ) -C -C and finds the largest RANKE-by-RANKE leading submatrix E11 whose -C estimated condition number is less than 1/TOL. RANKE defines thus -C the rank of matrix E. Further E22, being negligible, is set to -C zero, and an orthogonal matrix Y is determined such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C The overal transformation matrix Z results as Z = P * Y' and the -C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form -C -C ( Er 0 ) ( A11 A12 ) -C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , -C ( 0 0 ) ( A21 A22 ) -C -C where Er is an upper triangular invertible matrix. -C If JOBA = 'R' the same reduction is performed on A22 to obtain it -C in the form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C If JOBA = 'T' then A22 is row compressed using the QR -C factorization with column pivoting to the form -C -C ( Ar X ) -C A22 = ( ) -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C -C The transformations are also applied to the rest of system -C matrices -C -C B <- Q' * B, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSSV. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003, Jan. 2009. -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBA - INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, - $ LDZ, M, N, P, RANKE, RNKA22 - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC - INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, - $ LH, LN, LWR, NA22, NB, WRKOPT - DOUBLE PRECISION SVLMAX, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME -C .. External Subroutines .. - EXTERNAL DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, MB03OY, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF - REDA = LSAME( JOBA, 'R' ) - REDTR = LSAME( JOBA, 'T' ) - WITHB = M.GT.0 - WITHC = P.GT.0 - LQUERY = ( LDWORK.EQ.-1 ) -C -C Test the input parameters. -C - LN = MIN( L, N ) - INFO = 0 - WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. - $ .NOT.REDTR ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -17 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -19 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -22 - ELSE - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, N, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - IF( WITHB ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, M, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + M*NB ) - END IF - IF( ILQ ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMQR', 'RN', L, L, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + L*NB ) - END IF - NB = ILAENV( 1, 'DGERQF', ' ', L, N, -1, -1 ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', L, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) - IF( WITHC ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', P, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) - END IF - IF( ILZ ) THEN - NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', N, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) - END IF - ELSE IF( LDWORK.LT.WRKOPT ) THEN - INFO = -25 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01FD', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - DWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize Q and Z if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - DWORK(1) = ONE - RANKE = 0 - IF( REDA .OR. REDTR ) RNKA22 = 0 - RETURN - END IF -C - TOLDEF = TOL - IF( TOLDEF.LE.ZERO ) THEN -C -C Use the default tolerance for rank determination. -C - TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) - END IF -C -C Set the estimate of maximum singular value of E to -C max(||E||,||A||) to detect negligible A or E matrices. -C - SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ), - $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) -C -C Compute the rank-revealing QR decomposition of E, -C -C ( E11 E12 ) -C E * P = Qr * ( ) , -C ( 0 E22 ) -C -C and determine the rank of E using incremental condition -C estimation. -C Workspace: MIN(L,N) + 3*N - 1. -C - LWR = LDWORK - LN - KW = LN + 1 -C - CALL MB03OY( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, - $ DWORK, DWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RANKE.GT.0 ) THEN -C -C A <-- Qr' * A. -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', L, N, RANKE, E, LDE, DWORK, - $ A, LDA, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) -C -C B <-- Qr' * B. -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF( WITHB ) THEN - CALL DORMQR( 'Left', 'Transpose', L, M, RANKE, E, LDE, - $ DWORK, B, LDB, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Q <-- Q * Qr. -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) THEN - CALL DORMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, - $ DWORK, Q, LDQ, DWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.GE.2 ) - $ CALL DLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) -C -C Compute A*P, C*P and Z*P by forward permuting the columns of -C A, C and Z based on information in IWORK. -C - DO 10 J = 1, N - IWORK(J) = -IWORK(J) - 10 CONTINUE - DO 30 I = 1, N - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 20 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL DSWAP( L, A(1,J), 1, A(1,K), 1 ) - IF( WITHC ) - $ CALL DSWAP( P, C(1,J), 1, C(1,K), 1 ) - IF( ILZ ) - $ CALL DSWAP( N, Z(1,J), 1, Z(1,K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 20 - END IF - END IF - 30 CONTINUE -C -C Determine an orthogonal matrix Y such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. -C - IF( RANKE.LT.N ) THEN -C -C Workspace: need 2*N; -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL DTZRZF( RANKE, N, E, LDE, DWORK, DWORK(KW), - $ LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Workspace: need N + MAX(L,P,N); -C prefer N + MAX(L,P,N)*NB. -C - LH = N - RANKE - CALL DORMRZ( 'Right', 'Transpose', L, N, RANKE, LH, E, LDE, - $ DWORK, A, LDA, DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - IF( WITHC ) THEN - CALL DORMRZ( 'Right', 'Transpose', P, N, RANKE, LH, E, - $ LDE, DWORK, C, LDC, DWORK(KW), LDWORK-KW+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL DORMRZ( 'Right', 'Transpose', N, N, RANKE, LH, E, - $ LDE, DWORK, Z, LDZ, DWORK(KW), LDWORK-KW+1, - $ INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF -C -C Set E12 and E22 to zero. -C - CALL DLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) - END IF - ELSE - CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) - END IF -C -C Reduce A22 if necessary. -C - IF( REDA .OR. REDTR ) THEN - LA22 = L - RANKE - NA22 = N - RANKE - IF( MIN( LA22, NA22 ).EQ.0 ) THEN - RNKA22 = 0 - ELSE -C -C Compute the rank-revealing QR decomposition of A22, -C -C ( R11 R12 ) -C A22 * P2 = Q2 * ( ) , -C ( 0 R22 ) -C -C and determine the rank of A22 using incremental -C condition estimation. -C Workspace: MIN(L,N) + 3*N - 1. -C - IR1 = RANKE + 1 - CALL MB03OY( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, - $ SVLMAX, RNKA22, SVAL, IWORK, DWORK, - $ DWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I, Q2') * A -C Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, RNKA22, - $ A(IR1,IR1), LDA, DWORK, A(IR1,1), LDA, - $ DWORK(KW), LWR, INFO ) -C -C B <-- diag(I, Q2') * B -C Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( WITHB ) - $ CALL DORMQR( 'Left', 'Transpose', LA22, M, RNKA22, - $ A(IR1,IR1), LDA, DWORK, B(IR1,1), LDB, - $ DWORK(KW), LWR, INFO ) -C -C Q <-- Q * diag(I, Q2) -C Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) - $ CALL DORMQR( 'Right', 'No transpose', L, LA22, RNKA22, - $ A(IR1,IR1), LDA, DWORK, Q(1,IR1), LDQ, - $ DWORK(KW), LWR, INFO ) -C -C Set lower triangle of A22 to zero. -C - IF( LA22.GE.2 ) - $ CALL DLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, - $ A(IR1+1,IR1), LDA ) -C -C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) -C by forward permuting the columns of A, C and Z based -C on information in IWORK. -C - DO 40 J = 1, NA22 - IWORK(J) = -IWORK(J) - 40 CONTINUE - DO 60 I = 1, NA22 - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 50 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL DSWAP( RANKE, A(1,RANKE+J), 1, - $ A(1,RANKE+K), 1 ) - IF( WITHC ) - $ CALL DSWAP( P, C(1,RANKE+J), 1, - $ C(1,RANKE+K), 1 ) - IF( ILZ ) - $ CALL DSWAP( N, Z(1,RANKE+J), 1, - $ Z(1,RANKE+K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 50 - END IF - END IF - 60 CONTINUE -C - IF( REDA .AND. RNKA22.LT.NA22 ) THEN -C -C Determine an orthogonal matrix Y2 such that -C -C ( R11 R12 ) = ( Ar 0 ) * Y2 . -C -C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), -C Z <-- Z*diag(I, Y2'). -C Workspace: need 2*N. -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL DTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, DWORK, - $ DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) -C -C Workspace: need N + MAX(P,N); -C prefer N + MAX(P,N)*NB. -C - LH = NA22 - RNKA22 - IF( WITHC ) THEN - CALL DORMRZ( 'Right', 'Transpose', P, N, RNKA22, - $ LH, A(IR1,IR1), LDA, DWORK, C, LDC, - $ DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL DORMRZ( 'Right', 'Transpose', N, N, RNKA22, - $ LH, A(IR1,IR1), LDA, DWORK, Z, LDZ, - $ DWORK(KW), LDWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) - END IF - IRE1 = RANKE + RNKA22 + 1 -C -C Set R12 and R22 to zero. -C - CALL DLASET( 'Full', LA22, LH, ZERO, ZERO, - $ A(IR1,IRE1), LDA ) - END IF - ELSE - CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, - $ A(IR1,IR1), LDA) - END IF - END IF - END IF -C - DWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01FD *** - END diff --git a/slycot/src/TG01FZ.f b/slycot/src/TG01FZ.f deleted file mode 100644 index 5d8f5950..00000000 --- a/slycot/src/TG01FZ.f +++ /dev/null @@ -1,733 +0,0 @@ - SUBROUTINE TG01FZ( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, - $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute for the descriptor system (A-lambda E,B,C) -C the unitary transformation matrices Q and Z such that the -C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is -C in a SVD-like coordinate form with -C -C ( A11 A12 ) ( Er 0 ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , -C ( A21 A22 ) ( 0 0 ) -C -C where Er is an upper triangular invertible matrix, and ' denotes -C the conjugate transpose. Optionally, the A22 matrix can be further -C reduced to the form -C -C ( Ar X ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix, and X either a full -C or a zero matrix. -C The left and/or right unitary transformations performed -C to reduce E and A22 can be optionally accumulated. -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C unitary matrix Q is returned; -C = 'U': Q must contain a unitary matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C unitary matrix Z is returned; -C = 'U': Z must contain a unitary matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C JOBA CHARACTER*1 -C = 'N': do not reduce A22; -C = 'R': reduce A22 to a SVD-like upper triangular form. -C = 'T': reduce A22 to an upper trapezoidal form. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of rows of matrices A, B, and E. L >= 0. -C -C N (input) INTEGER -C The number of columns of matrices A, E, and C. N >= 0. -C -C M (input) INTEGER -C The number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The number of rows of matrix C. P >= 0. -C -C A (input/output) COMPLEX*16 array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the state dynamics matrix A. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix -C is in the form -C -C ( A11 * * ) -C Q'*A*Z = ( * Ar X ) , -C ( * 0 0 ) -C -C where A11 is a RANKE-by-RANKE matrix and Ar is a -C RNKA22-by-RNKA22 invertible upper triangular matrix. -C If JOBA = 'R' then A has the above form with X = 0. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) COMPLEX*16 array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the descriptor matrix E. -C On exit, the leading L-by-N part of this array contains -C the transformed matrix Q'*E*Z. -C -C ( Er 0 ) -C Q'*E*Z = ( ) , -C ( 0 0 ) -C -C where Er is a RANKE-by-RANKE upper triangular invertible -C matrix. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) COMPLEX*16 array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the input/state matrix B. -C On exit, the leading L-by-M part of this array contains -C the transformed matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) COMPLEX*16 array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) COMPLEX*16 array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the unitary matrix Q, -C where Q' is the product of Householder -C transformations which are applied to A, -C E, and B on the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain a unitary matrix Q1; -C on exit, the leading L-by-L part of this -C array contains the unitary matrix Q1*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Z (input/output) COMPLEX*16 array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the unitary matrix Z, -C which is the product of Householder -C transformations applied to A, E, and C -C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain a unitary matrix Z1; -C on exit, the leading N-by-N part of this -C array contains the unitary matrix Z1*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C RANKE (output) INTEGER -C The estimated rank of matrix E, and thus also the order -C of the invertible upper triangular submatrix Er. -C -C RNKA22 (output) INTEGER -C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of -C matrix A22, and thus also the order of the invertible -C upper triangular submatrix Ar. -C If JOBA = 'N', then RNKA22 is not referenced. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in determining the rank of E -C and of A22. If the user sets TOL > 0, then the given -C value of TOL is used as a lower bound for the -C reciprocal condition numbers of leading submatrices -C of R or R22 in the QR decompositions E * P = Q * R of E -C or A22 * P22 = Q22 * R22 of A22. -C A submatrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = L*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (N) -C -C DWORK DOUBLE PRECISION array, dimension (2*N) -C -C ZWORK DOUBLE PRECISION array, dimension (LZWORK) -C On exit, if INFO = 0, ZWORK(1) returns the optimal value -C of LZWORK. -C -C LZWORK INTEGER -C The length of the array ZWORK. -C LZWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). -C For optimal performance, LZWORK should be larger. -C -C If LZWORK = -1, then a workspace query is assumed; -C the routine only calculates the optimal size of the -C ZWORK array, returns this value as the first entry of -C the ZWORK array, and no error message related to LZWORK -C is issued by XERBLA. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine computes a truncated QR factorization with column -C pivoting of E, in the form -C -C ( E11 E12 ) -C E * P = Q * ( ) -C ( 0 E22 ) -C -C and finds the largest RANKE-by-RANKE leading submatrix E11 whose -C estimated condition number is less than 1/TOL. RANKE defines thus -C the rank of matrix E. Further E22, being negligible, is set to -C zero, and a unitary matrix Y is determined such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C The overal transformation matrix Z results as Z = P * Y' and the -C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form -C -C ( Er 0 ) ( A11 A12 ) -C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , -C ( 0 0 ) ( A21 A22 ) -C -C where Er is an upper triangular invertible matrix. -C If JOBA = 'R' the same reduction is performed on A22 to obtain it -C in the form -C -C ( Ar 0 ) -C A22 = ( ) , -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C If JOBA = 'T' then A22 is row compressed using the QR -C factorization with column pivoting to the form -C -C ( Ar X ) -C A22 = ( ) -C ( 0 0 ) -C -C with Ar an upper triangular invertible matrix. -C -C The transformations are also applied to the rest of system -C matrices -C -C B <- Q' * B, C <- C * Z. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( L*L*N ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Nov. 2008. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Descriptor system, matrix algebra, matrix operations, unitary -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) - DOUBLE PRECISION DONE, DZERO - PARAMETER ( DONE = 1.0D+0, DZERO = 0.0D+0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBA - INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDZ, LZWORK, - $ M, N, P, RANKE, RNKA22 - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ E( LDE, * ), Q( LDQ, * ), Z( LDZ, * ), - $ ZWORK( * ) - DOUBLE PRECISION DWORK( * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC - INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, - $ LH, LN, LWR, NA22, NB, WRKOPT - DOUBLE PRECISION SVLMAX, TOLDEF -C .. Local Arrays .. - DOUBLE PRECISION SVAL(3) -C .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, ZLANGE - EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE -C .. External Subroutines .. - EXTERNAL MB3OYZ, XERBLA, ZLASET, ZSWAP, ZTZRZF, ZUNMQR, - $ ZUNMRZ -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF - REDA = LSAME( JOBA, 'R' ) - REDTR = LSAME( JOBA, 'T' ) - WITHB = M.GT.0 - WITHC = P.GT.0 - LQUERY = ( LZWORK.EQ.-1 ) -C -C Test the input parameters. -C - LN = MIN( L, N ) - INFO = 0 - WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. - $ .NOT.REDTR ) THEN - INFO = -3 - ELSE IF( L.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( P.LT.0 ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -9 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN - INFO = -13 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -15 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -17 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -19 - ELSE IF( TOL.GE.DONE ) THEN - INFO = -22 - ELSE - IF( LQUERY ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, N, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - IF( WITHB ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, M, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + M*NB ) - END IF - IF( ILQ ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'RN', L, L, LN, -1 ) ) - WRKOPT = MAX( WRKOPT, LN + L*NB ) - END IF - NB = ILAENV( 1, 'ZGERQF', ' ', L, N, -1, -1 ) - WRKOPT = MAX( WRKOPT, LN + N*NB ) - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', L, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) - IF( WITHC ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', P, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) - END IF - IF( ILZ ) THEN - NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N, N, -1 ) ) - WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) - END IF - ELSE IF( LZWORK.LT.WRKOPT ) THEN - INFO = -26 - END IF - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01FZ', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - ZWORK(1) = WRKOPT - RETURN - END IF -C -C Initialize Q and Z if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL ZLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Quick return if possible. -C - IF( L.EQ.0 .OR. N.EQ.0 ) THEN - ZWORK(1) = ONE - RANKE = 0 - IF( REDA .OR. REDTR ) RNKA22 = 0 - RETURN - END IF -C - TOLDEF = TOL - IF( TOLDEF.LE.DZERO ) THEN -C -C Use the default tolerance for rank determination. -C - TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) - END IF -C -C Set the estimate of maximum singular value of E to -C max(||E||,||A||) to detect negligible A or E matrices. -C - SVLMAX = MAX( ZLANGE( 'F', L, N, E, LDE, DWORK ), - $ ZLANGE( 'F', L, N, A, LDA, DWORK ) ) -C -C Compute the rank-revealing QR decomposition of E, -C -C ( E11 E12 ) -C E * P = Qr * ( ) , -C ( 0 E22 ) -C -C and determine the rank of E using incremental condition -C estimation. -C Complex Workspace: MIN(L,N) + 3*N - 1. -C Real Workspace: 2*N. -C - LWR = LZWORK - LN - KW = LN + 1 -C - CALL MB3OYZ( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, - $ ZWORK, DWORK, ZWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RANKE.GT.0 ) THEN -C -C A <-- Qr' * A. -C Complex Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL ZUNMQR( 'Left', 'ConjTranspose', L, N, RANKE, E, LDE, - $ ZWORK, A, LDA, ZWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) -C -C B <-- Qr' * B. -C Complex Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF( WITHB ) THEN - CALL ZUNMQR( 'Left', 'ConjTranspose', L, M, RANKE, E, LDE, - $ ZWORK, B, LDB, ZWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) - END IF -C -C Q <-- Q * Qr. -C Complex Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) THEN - CALL ZUNMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, - $ ZWORK, Q, LDQ, ZWORK(KW), LWR, INFO ) - WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) - END IF -C -C Set lower triangle of E to zero. -C - IF( L.GE.2 ) - $ CALL ZLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) -C -C Compute A*P, C*P and Z*P by forward permuting the columns of -C A, C and Z based on information in IWORK. -C - DO 10 J = 1, N - IWORK(J) = -IWORK(J) - 10 CONTINUE - DO 30 I = 1, N - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 20 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL ZSWAP( L, A(1,J), 1, A(1,K), 1 ) - IF( WITHC ) - $ CALL ZSWAP( P, C(1,J), 1, C(1,K), 1 ) - IF( ILZ ) - $ CALL ZSWAP( N, Z(1,J), 1, Z(1,K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 20 - END IF - END IF - 30 CONTINUE -C -C Determine a unitary matrix Y such that -C -C ( E11 E12 ) = ( Er 0 ) * Y . -C -C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. -C - IF( RANKE.LT.N ) THEN -C -C Complex Workspace: need 2*N; -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL ZTZRZF( RANKE, N, E, LDE, ZWORK, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) -C -C Complex Workspace: need N + MAX(L,P,N); -C prefer N + MAX(L,P,N)*NB. -C - LH = N - RANKE - CALL ZUNMRZ( 'Right', 'Conjugate transpose', L, N, RANKE, - $ LH, E, LDE, ZWORK, A, LDA, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - IF( WITHC ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, RANKE, - $ LH, E, LDE, ZWORK, C, LDC, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, RANKE, - $ LH, E, LDE, ZWORK, Z, LDZ, ZWORK(KW), - $ LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF -C -C Set E12 and E22 to zero. -C - CALL ZLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) - END IF - ELSE - CALL ZLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) - END IF -C -C Reduce A22 if necessary. -C - IF( REDA .OR. REDTR ) THEN - LA22 = L - RANKE - NA22 = N - RANKE - IF( MIN( LA22, NA22 ).EQ.0 ) THEN - RNKA22 = 0 - ELSE -C -C Compute the rank-revealing QR decomposition of A22, -C -C ( R11 R12 ) -C A22 * P2 = Q2 * ( ) , -C ( 0 R22 ) -C -C and determine the rank of A22 using incremental -C condition estimation. -C Complex Workspace: MIN(L,N) + 3*N - 1. -C Real Workspace: 2*N. -C - IR1 = RANKE + 1 - CALL MB3OYZ( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, - $ SVLMAX, RNKA22, SVAL, IWORK, ZWORK, - $ DWORK, ZWORK(KW), INFO ) -C -C Apply transformation on the rest of matrices. -C - IF( RNKA22.GT.0 ) THEN -C -C A <-- diag(I, Q2') * A -C Complex Workspace: need MIN(L,N) + N; -C prefer MIN(L,N) + N*NB. -C - CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, RANKE, - $ RNKA22, A(IR1,IR1), LDA, ZWORK, A(IR1,1), - $ LDA, ZWORK(KW), LWR, INFO ) -C -C B <-- diag(I, Q2') * B -C Complex Workspace: need MIN(L,N) + M; -C prefer MIN(L,N) + M*NB. -C - IF ( WITHB ) - $ CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, M, RNKA22, - $ A(IR1,IR1), LDA, ZWORK, B(IR1,1), LDB, - $ ZWORK(KW), LWR, INFO ) -C -C Q <-- Q * diag(I, Q2) -C Complex Workspace: need MIN(L,N) + L; -C prefer MIN(L,N) + L*NB. -C - IF( ILQ ) - $ CALL ZUNMQR( 'Right', 'No transpose', L, LA22, RNKA22, - $ A(IR1,IR1), LDA, ZWORK, Q(1,IR1), LDQ, - $ ZWORK(KW), LWR, INFO ) -C -C Set lower triangle of A22 to zero. -C - IF( LA22.GE.2 ) - $ CALL ZLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, - $ A(IR1+1,IR1), LDA ) -C -C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) -C by forward permuting the columns of A, C and Z based -C on information in IWORK. -C - DO 40 J = 1, NA22 - IWORK(J) = -IWORK(J) - 40 CONTINUE - DO 60 I = 1, NA22 - IF( IWORK(I).LT.0 ) THEN - J = I - IWORK(J) = -IWORK(J) - 50 CONTINUE - K = IWORK(J) - IF( IWORK(K).LT.0 ) THEN - CALL ZSWAP( RANKE, A(1,RANKE+J), 1, - $ A(1,RANKE+K), 1 ) - IF( WITHC ) - $ CALL ZSWAP( P, C(1,RANKE+J), 1, - $ C(1,RANKE+K), 1 ) - IF( ILZ ) - $ CALL ZSWAP( N, Z(1,RANKE+J), 1, - $ Z(1,RANKE+K), 1 ) - IWORK(K) = -IWORK(K) - J = K - GO TO 50 - END IF - END IF - 60 CONTINUE -C - IF( REDA .AND. RNKA22.LT.NA22 ) THEN -C -C Determine a unitary matrix Y2 such that -C -C ( R11 R12 ) = ( Ar 0 ) * Y2 . -C -C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), -C Z <-- Z*diag(I, Y2'). -C -C Complex Workspace: need 2*N; -C prefer N + N*NB. -C - KW = RANKE + 1 - CALL ZTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, ZWORK, - $ ZWORK(KW), LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) -C -C Complex Workspace: need N + MAX(P,N); -C prefer N + MAX(P,N)*NB. -C - LH = NA22 - RNKA22 - IF( WITHC ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, - $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, C, - $ LDC, ZWORK(KW), LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF - IF( ILZ ) THEN - CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, - $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, Z, - $ LDZ, ZWORK(KW), LZWORK-KW+1, INFO ) - WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) - END IF - IRE1 = RANKE + RNKA22 + 1 -C -C Set R12 and R22 to zero. -C - CALL ZLASET( 'Full', LA22, LH, ZERO, ZERO, - $ A(IR1,IRE1), LDA ) - END IF - ELSE - CALL ZLASET( 'Full', LA22, NA22, ZERO, ZERO, - $ A(IR1,IR1), LDA) - END IF - END IF - END IF -C - ZWORK(1) = WRKOPT -C - RETURN -C *** Last line of TG01FZ *** - END diff --git a/slycot/src/TG01HD.f b/slycot/src/TG01HD.f deleted file mode 100644 index 318f1f35..00000000 --- a/slycot/src/TG01HD.f +++ /dev/null @@ -1,545 +0,0 @@ - SUBROUTINE TG01HD( JOBCON, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, NIUCON, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformation matrices Q and Z which -C reduce the N-th order descriptor system (A-lambda*E,B,C) -C to the form -C -C ( Ac * ) ( Ec * ) ( Bc ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , -C ( 0 Anc ) ( 0 Enc ) ( 0 ) -C -C C*Z = ( Cc Cnc ) , -C -C where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc) -C is a finite and/or infinite controllable. The pencil -C Anc - lambda*Enc is regular of order N-NCONT and contains the -C uncontrollable finite and/or infinite eigenvalues of the pencil -C A-lambda*E. -C -C For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full -C row rank NCONT for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( E1,0 E1,1 ... E1,k-1 E1,k ) -C ( _ _ _ ) -C ( Bc Ec ) = ( 0 E2,1 ... E2,k-1 E2,k ) , (1) -C ( ... _ _ ) -C ( 0 0 ... Ek,k-1 Ek,k ) -C -C _ _ _ -C ( A1,1 ... A1,k-1 A1,k ) -C ( _ _ ) -C Ac = ( 0 ... A2,k-1 A2,k ) , (2) -C ( ... _ ) -C ( 0 ... 0 Ak,k ) -C _ -C where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix -C _ -C (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i) -C upper triangular matrix. -C -C For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full -C row rank NCONT for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( A1,0 A1,1 ... A1,k-1 A1,k ) -C ( _ _ _ ) -C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (3) -C ( ... _ _ ) -C ( 0 0 ... Ak,k-1 Ak,k ) -C -C _ _ _ -C ( E1,1 ... E1,k-1 E1,k ) -C ( _ _ ) -C Ec = ( 0 ... E2,k-1 E2,k ) , (4) -C ( ... _ ) -C ( 0 ... 0 Ek,k ) -C _ -C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix -C _ -C (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) -C upper triangular matrix. -C -C For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil -C Anc - lambda*Enc has the form -C -C ( Ainc - lambda*Einc * ) -C Anc - lambda*Enc = ( ) , -C ( 0 Afnc - lambda*Efnc ) -C -C where: -C 1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc, -C with Ainc upper triangular and nonsingular, contains the -C uncontrollable infinite eigenvalues of A - lambda*E; -C 2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil -C Afnc - lambda*Efnc, with Efnc upper triangular and -C nonsingular, contains the uncontrollable finite -C eigenvalues of A - lambda*E. -C -C Note: The significance of the two diagonal blocks can be -C interchanged by calling the routine with the -C arguments A and E interchanged. In this case, -C Ainc - lambda*Einc contains the uncontrollable zero -C eigenvalues of A - lambda*E, while Afnc - lambda*Efnc -C contains the uncontrollable nonzero finite and infinite -C eigenvalues of A - lambda*E. -C -C For JOBCON = 'F', the pencil Anc - lambda*Enc has the form -C -C Anc - lambda*Enc = Afnc - lambda*Efnc , -C -C where the regular pencil Afnc - lambda*Efnc, with Efnc -C upper triangular and nonsingular, contains the uncontrollable -C finite eigenvalues of A - lambda*E. -C -C For JOBCON = 'I', the pencil Anc - lambda*Enc has the form -C -C Anc - lambda*Enc = Ainc - lambda*Einc , -C -C where the regular pencil Ainc - lambda*Einc, with Ainc -C upper triangular and nonsingular, contains the uncontrollable -C nonzero finite and infinite eigenvalues of A - lambda*E. -C -C The left and/or right orthogonal transformations Q and Z -C performed to reduce the system matrices can be optionally -C accumulated. -C -C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has -C the same transfer-function matrix as the original system -C (A-lambda*E,B,C). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBCON CHARACTER*1 -C = 'C': separate both finite and infinite uncontrollable -C eigenvalues; -C = 'F': separate only finite uncontrollable eigenvalues: -C = 'I': separate only nonzero finite and infinite -C uncontrollable eigenvalues. -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C order of square matrices A and E, the number of rows of -C matrix B, and the number of columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output vector; also the -C number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed state matrix Q'*A*Z, -C -C ( Ac * ) -C Q'*A*Z = ( ) , -C ( 0 Anc ) -C -C where Ac is NCONT-by-NCONT and Anc is -C (N-NCONT)-by-(N-NCONT). -C If JOBCON = 'F', the matrix ( Bc Ac ) is in the -C controllability staircase form (3). -C If JOBCON = 'C' or 'I', the submatrix Ac is upper -C triangular. -C If JOBCON = 'C', the Anc matrix has the form -C -C ( Ainc * ) -C Anc = ( ) , -C ( 0 Afnc ) -C -C where the NIUCON-by-NIUCON matrix Ainc is nonsingular and -C upper triangular. -C If JOBCON = 'I', Anc is nonsingular and upper triangular. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N descriptor matrix E. -C On exit, the leading N-by-N part of this array contains -C the transformed descriptor matrix Q'*E*Z, -C -C ( Ec * ) -C Q'*E*Z = ( ) , -C ( 0 Enc ) -C -C where Ec is NCONT-by-NCONT and Enc is -C (N-NCONT)-by-(N-NCONT). -C If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the -C controllability staircase form (1). -C If JOBCON = 'F', the submatrix Ec is upper triangular. -C If JOBCON = 'C', the Enc matrix has the form -C -C ( Einc * ) -C Enc = ( ) , -C ( 0 Efnc ) -C -C where the NIUCON-by-NIUCON matrix Einc is nilpotent -C and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc -C is nonsingular and upper triangular. -C If JOBCON = 'F', Enc is nonsingular and upper triangular. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the N-by-M input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix -C -C ( Bc ) -C Q'*B = ( ) , -C ( 0 ) -C -C where Bc is NCONT-by-M. -C For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the -C controllability staircase form (1). -C For JOBCON = 'F', the matrix ( Bc Ac ) is in the -C controllability staircase form (3). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of transformations -C which are applied to A, E, and B on -C the left. -C If COMPQ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Qc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Qc*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of transformations -C applied to A, E, and C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Zc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Zc*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C NCONT (output) INTEGER -C The order of the reduced matrices Ac and Ec, and the -C number of rows of reduced matrix Bc; also the order of -C the controllable part of the pair (A-lambda*E,B). -C -C NIUCON (output) INTEGER -C For JOBCON = 'C', the order of the reduced matrices -C Ainc and Einc; also the number of uncontrollable -C infinite eigenvalues of the pencil A - lambda*E. -C For JOBCON = 'F' or 'I', NIUCON has no significance -C and is set to zero. -C -C NRBLCK (output) INTEGER -C For JOBCON = 'C' or 'I', the number k, of full row rank -C _ -C blocks Ei,i in the staircase form of the pencil -C (Bc Ec-lambda*Ac) (see (1) and (2)). -C For JOBCON = 'F', the number k, of full row rank blocks -C _ -C Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec) -C (see (3) and (4)). -C -C RTAU (output) INTEGER array, dimension (N) -C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of -C _ _ -C the full row rank block Ei,i-1 or Ai,i-1 in the staircase -C form (1) or (3) for JOBCON = 'C' or 'I', or -C for JOBCON = 'F', respectively. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A-lambda*E, B). If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension MAX(N,2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithms of [1]. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N**3 ) floating point operations. -C -C FURTHER COMMENTS -C -C If the system matrices A, E and B are badly scaled, it is -C generally recommendable to scale them with the SLICOT routine -C TG01AD, before calling TG01HD. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSCF. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBCON - INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, - $ M, N, NCONT, NIUCON, NRBLCK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ), RTAU( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - CHARACTER JOBQ, JOBZ - LOGICAL FINCON, ILQ, ILZ, INFCON - INTEGER ICOMPQ, ICOMPZ, LBA, NR -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL TG01HX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Decode JOBCON. -C - IF( LSAME( JOBCON, 'C' ) ) THEN - FINCON = .TRUE. - INFCON = .TRUE. - ELSE IF( LSAME( JOBCON, 'F' ) ) THEN - FINCON = .TRUE. - INFCON = .FALSE. - ELSE IF( LSAME( JOBCON, 'I' ) ) THEN - FINCON = .FALSE. - INFCON = .TRUE. - ELSE - FINCON = .FALSE. - INFCON = .FALSE. - END IF -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input scalar parameters. -C - INFO = 0 - IF( .NOT.FINCON .AND. .NOT.INFCON ) THEN - INFO = -1 - ELSE IF( ICOMPQ.LE.0 ) THEN - INFO = -2 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -14 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -16 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -18 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -23 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01HD', -INFO ) - RETURN - END IF -C - JOBQ = COMPQ - JOBZ = COMPZ -C - IF( FINCON ) THEN -C -C Perform finite controllability form reduction. -C - CALL TG01HX( JOBQ, JOBZ, N, N, M, P, N, MAX( 0, N-1 ), A, LDA, - $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) - IF( NRBLCK.GT.1 ) THEN - LBA = RTAU(1) + RTAU(2) - 1 - ELSE IF( NRBLCK.EQ.1 ) THEN - LBA = RTAU(1) - 1 - ELSE - LBA = 0 - END IF - IF( ILQ ) JOBQ = 'U' - IF( ILZ ) JOBZ = 'U' - ELSE - NR = N - LBA = MAX( 0, N-1 ) - END IF -C - IF( INFCON ) THEN -C -C Perform infinite controllability form reduction. -C - CALL TG01HX( JOBQ, JOBZ, N, N, M, P, NR, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) - IF( FINCON ) THEN - NIUCON = NR - NCONT - ELSE - NIUCON = 0 - END IF - ELSE - NCONT = NR - NIUCON = 0 - END IF -C - RETURN -C -C *** Last line of TG01HD *** - END diff --git a/slycot/src/TG01HX.f b/slycot/src/TG01HX.f deleted file mode 100644 index c0717f81..00000000 --- a/slycot/src/TG01HX.f +++ /dev/null @@ -1,694 +0,0 @@ - SUBROUTINE TG01HX( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA, - $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, - $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C Given the descriptor system (A-lambda*E,B,C) with the system -C matrices A, E and B of the form -C -C ( A1 X1 ) ( E1 Y1 ) ( B1 ) -C A = ( ) , E = ( ) , B = ( ) , -C ( 0 X2 ) ( 0 Y2 ) ( 0 ) -C -C where -C - B is an L-by-M matrix, with B1 an N1-by-M submatrix -C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix -C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix -C with LBE nonzero sub-diagonals, -C this routine reduces the pair (A1-lambda*E1,B1) to the form -C -C Qc'*[A1-lambda*E1 B1]*diag(Zc,I) = -C -C ( Bc Ac-lambda*Ec * ) -C ( ) , -C ( 0 0 Anc-lambda*Enc ) -C -C where: -C 1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for -C all finite lambda and is in a staircase form with -C _ _ _ _ -C ( A1,0 A1,1 ... A1,k-1 A1,k ) -C ( _ _ _ ) -C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (1) -C ( ... _ _ ) -C ( 0 0 ... Ak,k-1 Ak,k ) -C -C _ _ _ -C ( E1,1 ... E1,k-1 E1,k ) -C ( _ _ ) -C Ec = ( 0 ... E2,k-1 E2,k ) , (2) -C ( ... _ ) -C ( 0 ... 0 Ek,k ) -C _ -C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank -C _ -C matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) -C upper triangular matrix. -C -C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc -C upper triangular; this pencil contains the uncontrollable -C finite eigenvalues of the pencil (A1-lambda*E1). -C -C The transformations are applied to the whole matrices A, E, B -C and C. The left and/or right orthogonal transformations Qc and Zc -C performed to reduce the pencil S(lambda) can be optionally -C accumulated in the matrices Q and Z, respectivelly. -C -C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no -C uncontrollable finite eigenvalues and has the same -C transfer-function matrix as the original system (A-lambda*E,B,C). -C -C ARGUMENTS -C -C Mode Parameters -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C L (input) INTEGER -C The number of descriptor state equations; also the number -C of rows of matrices A, E and B. L >= 0. -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C number of columns of matrices A, E and C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output; also the -C number of rows of matrix C. P >= 0. -C -C N1 (input) INTEGER -C The order of subsystem (A1-lambda*E1,B1,C1) to be reduced. -C MIN(L,N) >= N1 >= 0. -C -C LBE (input) INTEGER -C The number of nonzero sub-diagonals of submatrix E1. -C MAX(0,N1-1) >= LBE >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading L-by-N part of this array must -C contain the L-by-N state matrix A in the partitioned -C form -C ( A1 X1 ) -C A = ( ) , -C ( 0 X2 ) -C -C where A1 is N1-by-N1. -C On exit, the leading L-by-N part of this array contains -C the transformed state matrix, -C -C ( Ac * * ) -C Qc'*A*Zc = ( 0 Anc * ) , -C ( 0 0 * ) -C -C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). -C The matrix ( Bc Ac ) is in the controlability -C staircase form (1). -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,L). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading L-by-N part of this array must -C contain the L-by-N descriptor matrix E in the partitioned -C form -C ( E1 Y1 ) -C E = ( ) , -C ( 0 Y2 ) -C -C where E1 is N1-by-N1 matrix with LBE nonzero -C sub-diagonals. -C On exit, the leading L-by-N part of this array contains -C the transformed descriptor matrix -C -C ( Ec * * ) -C Qc'*E*Zc = ( 0 Enc * ) , -C ( 0 0 * ) -C -C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). -C Both Ec and Enc are upper triangular and Enc is -C nonsingular. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,L). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading L-by-M part of this array must -C contain the L-by-M input matrix B in the partitioned -C form -C ( B1 ) -C B = ( ) , -C ( 0 ) -C -C where B1 is N1-by-M. -C On exit, the leading L-by-M part of this array contains -C the transformed input matrix -C -C ( Bc ) -C Qc'*B = ( ) , -C ( 0 ) -C -C where Bc is NR-by-M. -C The matrix ( Bc Ac ) is in the controlability -C staircase form (1). -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,L). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix C*Zc. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of transformations -C which are applied to A, E, and B on -C the left. -C If COMPQ = 'U': on entry, the leading L-by-L part of this -C array must contain an orthogonal matrix -C Qc; -C on exit, the leading L-by-L part of this -C array contains the orthogonal matrix -C Qc*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of transformations -C applied to A, E, and C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Zc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Zc*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C NR (output) INTEGER -C The order of the reduced matrices Ac and Ec, and the -C number of rows of the reduced matrix Bc; also the order of -C the controllable part of the pair (B, A-lambda*E). -C -C NRBLCK (output) INTEGER _ -C The number k, of full row rank blocks Ai,i in the -C staircase form of the pencil (Bc Ac-lambda*Ec) (see (1) -C and (2)). -C -C RTAU (output) INTEGER array, dimension (N1) -C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of -C _ -C the full row rank block Ai,i-1 in the staircase form (1). -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A-lambda*E, B). If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = L*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (M) -C -C DWORK DOUBLE PRECISION array, dimension MAX(N,L,2*M) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithm of [1]. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N*N1**2 ) floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDS05. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, July 1999, -C May 2003, Nov. 2003. -C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. -C -C KEYWORDS -C -C Controllability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - INTEGER IMAX, IMIN - PARAMETER ( IMAX = 1, IMIN = 2 ) - DOUBLE PRECISION ONE, P05, ZERO - PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ - INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDZ, M, - $ N, N1, NR, NRBLCK, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER IWORK( * ), RTAU( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - LOGICAL ILQ, ILZ, WITHC - INTEGER I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX, - $ ISMIN, J, K, MN, NF, NR1, RANK, TAUIM1 - DOUBLE PRECISION CO, C1, C2, RCOND, SMAX, SMAXPR, SMIN, SMINPR, - $ SVLMAX, S1, S2, SI, T, TT -C .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLANGE, DLAPY2, DNRM2, IDAMAX, LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLARF, DLARFG, DLARTG, DLASET, DROT, - $ DSWAP, XERBLA -C .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -C -C .. Executable Statements .. -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input scalar parameters. -C - INFO = 0 - IF( ICOMPQ.LE.0 ) THEN - INFO = -1 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -2 - ELSE IF( L.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN - INFO = -7 - ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.MAX( 1, L ) ) THEN - INFO = -10 - ELSE IF( LDE.LT.MAX( 1, L ) ) THEN - INFO = -12 - ELSE IF( LDB.LT.MAX( 1, L ) ) THEN - INFO = -14 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -16 - ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN - INFO = -18 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -20 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -24 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01HX', -INFO ) - RETURN - END IF -C -C Initialize Q and Z if necessary. -C - IF( ICOMPQ.EQ.3 ) - $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) - IF( ICOMPZ.EQ.3 ) - $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) -C -C Initialize output variables. -C - NR = 0 - NRBLCK = 0 -C -C Quick return if possible. -C - IF( M.EQ.0 .OR. N1.EQ.0 ) THEN - RETURN - END IF -C - WITHC = P.GT.0 - SVLMAX = DLAPY2( DLANGE( 'F', L, M, B, LDB, DWORK ), - $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) - RCOND = TOL - IF ( RCOND.LE.ZERO ) THEN -C -C Use the default tolerance in controllability determination. -C - RCOND = DBLE( L*N )*DLAMCH( 'EPSILON' ) - END IF -C - IF ( SVLMAX.LT.RCOND ) - $ SVLMAX = ONE -C -C Reduce E to upper triangular form if necessary. -C - IF( LBE.GT.0 ) THEN - DO 10 I = 1, N1-1 -C -C Generate elementary reflector H(i) to annihilate -C E(i+1:i+lbe,i). -C - K = MIN( LBE, N1-I ) + 1 - CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) - T = E(I,I) - E(I,I) = ONE -C -C Apply H(i) to E(i:n1,i+1:n) from the left. -C - CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, - $ E(I,I+1), LDE, DWORK ) -C -C Apply H(i) to A(i:n1,1:n) from the left. -C - CALL DLARF( 'Left', K, N, E(I,I), 1, TT, - $ A(I,1), LDA, DWORK ) -C -C Apply H(i) to B(i:n1,1:m) from the left. -C - CALL DLARF( 'Left', K, M, E(I,I), 1, TT, - $ B(I,1), LDB, DWORK ) - IF( ILQ ) THEN -C -C Apply H(i) to Q(1:l,i:n1) from the right. -C - CALL DLARF( 'Right', L, K, E(I,I), 1, TT, - $ Q(1,I), LDQ, DWORK ) - END IF - E(I,I) = T - 10 CONTINUE - IF( N1.GT.1 ) - $ CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) - END IF -C - ISMIN = 1 - ISMAX = ISMIN + M - IC = -M - TAUIM1 = M - NF = N1 -C - 20 CONTINUE - NRBLCK = NRBLCK + 1 - RANK = 0 - IF( NF.GT.0 ) THEN -C -C IROW will point to the current pivot line in B, -C ICOL+1 will point to the first active columns of A. -C - ICOL = IC + TAUIM1 - IROW = NR - NR1 = NR + 1 - IF( NR.GT.0 ) - $ CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA, - $ B(NR1,1), LDB ) -C -C Perform QR-decomposition with column pivoting on the current B -C while keeping E upper triangular. -C The current B is at first iteration B and for subsequent -C iterations the NF-by-TAUIM1 matrix delimited by rows -C NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A. -C The rank of current B is computed in RANK. -C - IF( TAUIM1.GT.1 ) THEN -C -C Compute column norms. -C - DO 30 J = 1, TAUIM1 - DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) - DWORK(M+J) = DWORK(J) - IWORK(J) = J - 30 CONTINUE - END IF -C - MN = MIN( NF, TAUIM1 ) -C - 40 CONTINUE - IF( RANK.LT.MN ) THEN - J = RANK + 1 - IROW = IROW + 1 -C -C Pivot if necessary. -C - IF( J.NE.TAUIM1 ) THEN - K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 ) - IF( K.NE.J ) THEN - CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) - I = IWORK(K) - IWORK(K) = IWORK(J) - IWORK(J) = I - DWORK(K) = DWORK(J) - DWORK(M+K) = DWORK(M+J) - END IF - END IF -C -C Zero elements below the current diagonal element of B. -C - DO 50 I = N1-1, IROW, -1 -C -C Rotate rows I and I+1 to zero B(I+1,J). -C - T = B(I,J) - CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) - B(I+1,J) = ZERO - CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) - IF( J.LT.TAUIM1 ) - $ CALL DROT( TAUIM1-J, B(I,J+1), LDB, - $ B(I+1,J+1), LDB, CO, SI ) - CALL DROT( N-ICOL, A(I,ICOL+1), LDA, - $ A(I+1,ICOL+1), LDA, CO, SI ) - IF( ILQ ) CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) -C -C Rotate columns I, I+1 to zero E(I+1,I). -C - T = E(I+1,I+1) - CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) - E(I+1,I) = ZERO - CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) - CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) - IF( ILZ ) CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) - IF( WITHC ) - $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) - 50 CONTINUE -C - IF( RANK.EQ.0 ) THEN -C -C Initialize; exit if matrix is zero (RANK = 0). -C - SMAX = ABS( B(NR1,1) ) - IF ( SMAX.EQ.ZERO ) GO TO 80 - SMIN = SMAX - SMAXPR = SMAX - SMINPR = SMIN - C1 = ONE - C2 = ONE - ELSE -C -C One step of incremental condition estimation. -C - CALL DLAIC1( IMIN, RANK, DWORK(ISMIN), SMIN, - $ B(NR1,J), B(IROW,J), SMINPR, S1, C1 ) - CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, - $ B(NR1,J), B(IROW,J), SMAXPR, S2, C2 ) - END IF -C -C Check the rank; finish the loop if rank loss occurs. -C - IF( SVLMAX*RCOND.LE.SMAXPR ) THEN - IF( SVLMAX*RCOND.LE.SMINPR ) THEN - IF( SMAXPR*RCOND.LE.SMINPR ) THEN -C -C Finish the loop if last row. -C - IF( IROW.EQ.N1 ) THEN - RANK = RANK + 1 - GO TO 80 - END IF -C -C Update partial column norms. -C - DO 60 I = J + 1, TAUIM1 - IF( DWORK(I).NE.ZERO ) THEN - T = ONE - ( ABS( B(IROW,I) )/DWORK(I) )**2 - T = MAX( T, ZERO ) - TT = ONE + P05*T*( DWORK(I)/DWORK(M+I) )**2 - IF( TT.NE.ONE ) THEN - DWORK(I) = DWORK(I)*SQRT( T ) - ELSE - DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) - DWORK(M+I) = DWORK(I) - END IF - END IF - 60 CONTINUE -C - DO 70 I = 1, RANK - DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) - DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) - 70 CONTINUE -C - DWORK(ISMIN+RANK) = C1 - DWORK(ISMAX+RANK) = C2 - SMIN = SMINPR - SMAX = SMAXPR - RANK = RANK + 1 - GO TO 40 - END IF - END IF - END IF - IF( NR.GT.0 ) THEN - CALL DLASET( 'Full', N1-IROW+1, TAUIM1-J+1, ZERO, ZERO, - $ B(IROW,J), LDB ) - END IF - GO TO 80 - END IF - END IF -C - 80 IF( RANK.GT.0 ) THEN - RTAU(NRBLCK) = RANK -C -C Back permute interchanged columns. -C - IF( TAUIM1.GT.1 ) THEN - DO 100 J = 1, TAUIM1 - IF( IWORK(J).GT.0 ) THEN - K = IWORK(J) - IWORK(J) = -K - 90 CONTINUE - IF( K.NE.J ) THEN - CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) - IWORK(K) = -IWORK(K) - K = -IWORK(K) - GO TO 90 - END IF - END IF - 100 CONTINUE - END IF - END IF - IF( NR.GT.0 ) - $ CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB, - $ A(NR1,IC+1), LDA ) - IF( RANK.GT.0 ) THEN - NR = NR + RANK - NF = NF - RANK - IC = IC + TAUIM1 - TAUIM1 = RANK - GO TO 20 - ELSE - NRBLCK = NRBLCK - 1 - END IF -C - IF( NRBLCK.GT.0 ) RANK = RTAU(1) - IF( RANK.LT.N1 ) - $ CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB ) -C - RETURN -C *** Last line of TG01HX *** - END diff --git a/slycot/src/TG01ID.f b/slycot/src/TG01ID.f deleted file mode 100644 index dfd3888a..00000000 --- a/slycot/src/TG01ID.f +++ /dev/null @@ -1,587 +0,0 @@ - SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS, - $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To compute orthogonal transformation matrices Q and Z which -C reduce the N-th order descriptor system (A-lambda*E,B,C) -C to the form -C -C ( Ano * ) ( Eno * ) ( Bno ) -C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , -C ( 0 Ao ) ( 0 Eo ) ( Bo ) -C -C C*Z = ( 0 Co ) , -C -C where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co) -C is a finite and/or infinite observable. The pencil -C Ano - lambda*Eno is regular of order N-NOBSV and contains the -C unobservable finite and/or infinite eigenvalues of the pencil -C A-lambda*E. -C -C For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full -C ( Co ) -C column rank NOBSV for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( Ek,k Ek,k-1 ... Ek,2 Ek,1 ) -C ( _ _ _ _ ) -C ( Eo ) = ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) , (1) -C ( Co ) ( ... ... _ _ ) -C ( 0 0 ... E1,2 E1,1 ) -C ( _ ) -C ( 0 0 ... 0 E0,1 ) -C _ _ _ -C ( Ak,k ... Ak,2 Ak,1 ) -C ( ... _ _ ) -C Ao = ( 0 ... A2,2 A2,1 ) , (2) -C ( _ ) -C ( 0 ... 0 A1,1 ) -C _ -C where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix -C _ -C (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i) -C upper triangular matrix. -C -C For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full -C ( Co ) -C column rank NOBSV for all finite lambda and is in a staircase form -C with -C _ _ _ _ -C ( Ak,k Ak,k-1 ... Ak,2 Ak,1 ) -C ( _ _ _ _ ) -C ( Ao ) = ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) , (3) -C ( Co ) ( ... ... _ _ ) -C ( 0 0 ... A1,2 A1,1 ) -C ( _ ) -C ( 0 0 ... 0 A0,1 ) -C _ _ _ -C ( Ek,k ... Ek,2 Ek,1 ) -C ( ... _ _ ) -C Eo = ( 0 ... E2,2 E2,1 ) , (4) -C ( _ ) -C ( 0 ... 0 E1,1 ) -C _ -C where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix -C _ -C (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i) -C upper triangular matrix. -C -C For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil -C Ano - lambda*Eno has the form -C -C ( Afno - lambda*Efno * ) -C Ano - lambda*Eno = ( ) , -C ( 0 Aino - lambda*Eino ) -C -C where: -C 1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino, -C with Aino upper triangular and nonsingular, contains the -C unobservable infinite eigenvalues of A - lambda*E; -C 2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil -C Afno - lambda*Efno, with Efno upper triangular and -C nonsingular, contains the unobservable finite -C eigenvalues of A - lambda*E. -C -C Note: The significance of the two diagonal blocks can be -C interchanged by calling the routine with the -C arguments A and E interchanged. In this case, -C Aino - lambda*Eino contains the unobservable zero -C eigenvalues of A - lambda*E, while Afno - lambda*Efno -C contains the unobservable nonzero finite and infinite -C eigenvalues of A - lambda*E. -C -C For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form -C -C Ano - lambda*Eno = Afno - lambda*Efno , -C -C where the regular pencil Afno - lambda*Efno, with Efno -C upper triangular and nonsingular, contains the unobservable -C finite eigenvalues of A - lambda*E. -C -C For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form -C -C Ano - lambda*Eno = Aino - lambda*Eino , -C -C where the regular pencil Aino - lambda*Eino, with Aino -C upper triangular and nonsingular, contains the unobservable -C nonzero finite and infinite eigenvalues of A - lambda*E. -C -C The left and/or right orthogonal transformations Q and Z -C performed to reduce the system matrices can be optionally -C accumulated. -C -C The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has -C the same transfer-function matrix as the original system -C (A-lambda*E,B,C). -C -C ARGUMENTS -C -C Mode Parameters -C -C JOBOBS CHARACTER*1 -C = 'O': separate both finite and infinite unobservable -C eigenvalues; -C = 'F': separate only finite unobservable eigenvalues; -C = 'I': separate only nonzero finite and infinite -C unobservable eigenvalues. -C -C COMPQ CHARACTER*1 -C = 'N': do not compute Q; -C = 'I': Q is initialized to the unit matrix, and the -C orthogonal matrix Q is returned; -C = 'U': Q must contain an orthogonal matrix Q1 on entry, -C and the product Q1*Q is returned. -C -C COMPZ CHARACTER*1 -C = 'N': do not compute Z; -C = 'I': Z is initialized to the unit matrix, and the -C orthogonal matrix Z is returned; -C = 'U': Z must contain an orthogonal matrix Z1 on entry, -C and the product Z1*Z is returned. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C order of square matrices A and E, the number of rows of -C matrix B, and the number of columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output vector; also the -C number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N state matrix A. -C On exit, the leading N-by-N part of this array contains -C the transformed state matrix Q'*A*Z, -C -C ( Ano * ) -C Q'*A*Z = ( ) , -C ( 0 Ao ) -C -C where Ao is NOBSV-by-NOBSV and Ano is -C (N-NOBSV)-by-(N-NOBSV). -C If JOBOBS = 'F', the matrix ( Ao ) is in the observability -C ( Co ) -C staircase form (3). -C If JOBOBS = 'O' or 'I', the submatrix Ao is upper -C triangular. -C If JOBOBS = 'O', the submatrix Ano has the form -C -C ( Afno * ) -C Ano = ( ) , -C ( 0 Aino ) -C -C where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and -C upper triangular. -C If JOBOBS = 'I', Ano is nonsingular and upper triangular. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the N-by-N descriptor matrix E. -C On exit, the leading N-by-N part of this array contains -C the transformed state matrix Q'*E*Z, -C -C ( Eno * ) -C Q'*E*Z = ( ) , -C ( 0 Eo ) -C -C where Eo is NOBSV-by-NOBSV and Eno is -C (N-NOBSV)-by-(N-NOBSV). -C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the -C ( Co ) -C observability staircase form (1). -C If JOBOBS = 'F', the submatrix Eo is upper triangular. -C If JOBOBS = 'O', the Eno matrix has the form -C -C ( Efno * ) -C Eno = ( ) , -C ( 0 Eino ) -C -C where the NIUOBS-by-NIUOBS matrix Eino is nilpotent -C and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno -C is nonsingular and upper triangular. -C If JOBOBS = 'F', Eno is nonsingular and upper triangular. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension -C (LDB,MAX(M,P)) -C On entry, the leading N-by-M part of this array must -C contain the N-by-M input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix Q'*B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0. -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the state/output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed matrix -C -C C*Z = ( 0 Co ) , -C -C where Co is P-by-NOBSV. -C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the -C ( Co ) -C observability staircase form (1). -C If JOBOBS = 'F', the matrix ( Ao ) is in the observability -C ( Co ) -C staircase form (3). -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,M,P). -C -C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) -C If COMPQ = 'N': Q is not referenced. -C If COMPQ = 'I': on entry, Q need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Q, -C where Q' is the product of transformations -C which are applied to A, E, and B on -C the left. -C If COMPQ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Qc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Qc*Q. -C -C LDQ INTEGER -C The leading dimension of array Q. -C LDQ >= 1, if COMPQ = 'N'; -C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. -C -C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) -C If COMPZ = 'N': Z is not referenced. -C If COMPZ = 'I': on entry, Z need not be set; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix Z, -C which is the product of transformations -C applied to A, E, and C on the right. -C If COMPZ = 'U': on entry, the leading N-by-N part of this -C array must contain an orthogonal matrix -C Zc; -C on exit, the leading N-by-N part of this -C array contains the orthogonal matrix -C Zc*Z. -C -C LDZ INTEGER -C The leading dimension of array Z. -C LDZ >= 1, if COMPZ = 'N'; -C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. -C -C NOBSV (output) INTEGER -C The order of the reduced matrices Ao and Eo, and the -C number of columns of reduced matrix Co; also the order of -C observable part of the pair (C, A-lambda*E). -C -C NIUOBS (output) INTEGER -C For JOBOBS = 'O', the order of the reduced matrices -C Aino and Eino; also the number of unobservable -C infinite eigenvalues of the pencil A - lambda*E. -C For JOBOBS = 'F' or 'I', NIUOBS has no significance -C and is set to zero. -C -C NLBLCK (output) INTEGER -C For JOBOBS = 'O' or 'I', the number k, of full column rank -C _ -C blocks Ei-1,i in the staircase form of the pencil -C (Eo-lambda*Ao) (see (1) and (2)). -C ( Co ) -C For JOBOBS = 'F', the number k, of full column rank blocks -C _ -C Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo) -C ( Co ) -C (see (3) and (4)). -C -C CTAU (output) INTEGER array, dimension (N) -C CTAU(i), for i = 1, ..., NLBLCK, is the column dimension -C _ _ -C of the full column rank block Ei-1,i or Ai-1,i in the -C staircase form (1) or (3) for JOBOBS = 'O' or 'I', or -C for JOBOBS = 'F', respectively. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A'-lambda*E',C')'. If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where EPS -C is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension (P) -C -C DWORK DOUBLE PRECISION array, dimension MAX(N,2*P) -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the dual of the reduction -C algorithms of [1]. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N**3 ) floating point operations. -C -C FURTHER COMMENTS -C -C If the system matrices A, E and C are badly scaled, it is -C generally recommendable to scale them with the SLICOT routine -C TG01AD, before calling TG01ID. -C -C CONTRIBUTOR -C -C C. Oara, University "Politehnica" Bucharest. -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C March 1999. Based on the RASP routine RPDSCF. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C May 2003, March 2004, V. Sima. -C -C KEYWORDS -C -C Observability, minimal realization, orthogonal canonical form, -C orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER COMPQ, COMPZ, JOBOBS - INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, - $ M, N, NIUOBS, NLBLCK, NOBSV, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER CTAU( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), - $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), - $ Z( LDZ, * ) -C .. Local Scalars .. - CHARACTER JOBQ, JOBZ - LOGICAL FINOBS, ILQ, ILZ, INFOBS - INTEGER I, ICOMPQ, ICOMPZ, LBA, LBE, NR -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, - $ TG01HX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable Statements .. -C -C Decode JOBOBS. -C - IF( LSAME( JOBOBS, 'O') ) THEN - FINOBS = .TRUE. - INFOBS = .TRUE. - ELSE IF( LSAME( JOBOBS, 'F') ) THEN - FINOBS = .TRUE. - INFOBS = .FALSE. - ELSE IF( LSAME( JOBOBS, 'I') ) THEN - FINOBS = .FALSE. - INFOBS = .TRUE. - ELSE - FINOBS = .FALSE. - INFOBS = .FALSE. - END IF -C -C Decode COMPQ. -C - IF( LSAME( COMPQ, 'N' ) ) THEN - ILQ = .FALSE. - ICOMPQ = 1 - ELSE IF( LSAME( COMPQ, 'U' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 2 - ELSE IF( LSAME( COMPQ, 'I' ) ) THEN - ILQ = .TRUE. - ICOMPQ = 3 - ELSE - ICOMPQ = 0 - END IF -C -C Decode COMPZ. -C - IF( LSAME( COMPZ, 'N' ) ) THEN - ILZ = .FALSE. - ICOMPZ = 1 - ELSE IF( LSAME( COMPZ, 'U' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 2 - ELSE IF( LSAME( COMPZ, 'I' ) ) THEN - ILZ = .TRUE. - ICOMPZ = 3 - ELSE - ICOMPZ = 0 - END IF -C -C Test the input scalar parameters. -C - INFO = 0 - IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN - INFO = -1 - ELSE IF( ICOMPQ.LE.0 ) THEN - INFO = -2 - ELSE IF( ICOMPZ.LE.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -8 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN - INFO = -12 - ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN - INFO = -14 - ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN - INFO = -16 - ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN - INFO = -18 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -23 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'TG01ID', -INFO ) - RETURN - END IF -C - JOBQ = COMPQ - JOBZ = COMPZ -C -C Build the dual system. -C - CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, - $ INFO ) - DO 10 I = 2, N - CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 ) - 10 CONTINUE -C - IF( FINOBS ) THEN -C -C Perform finite observability form reduction. -C - CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA, - $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR, - $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) - IF( NLBLCK.GT.1 ) THEN - LBA = CTAU(1) + CTAU(2) - 1 - ELSE IF( NLBLCK.EQ.1 ) THEN - LBA = CTAU(1) - 1 - ELSE - LBA = 0 - END IF - IF( ILQ ) JOBQ = 'U' - IF( ILZ ) JOBZ = 'U' - LBE = 0 - ELSE - NR = N - LBA = MAX( 0, N-1 ) - LBE = LBA - END IF -C - IF( INFOBS ) THEN -C -C Perform infinite observability form reduction. -C - CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV, - $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) - IF( FINOBS ) THEN - NIUOBS = NR - NOBSV - ELSE - NIUOBS = 0 - END IF - IF( NLBLCK.GT.1 ) THEN - LBE = CTAU(1) + CTAU(2) - 1 - ELSE IF( NLBLCK.EQ.1 ) THEN - LBE = CTAU(1) - 1 - ELSE - LBE = 0 - END IF - LBA = 0 - ELSE - NOBSV = NR - NIUOBS = 0 - END IF -C -C Compute the pertransposed dual system exploiting matrix shapes. -C - LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 ) - IF ( P.EQ.0 .OR. NR.EQ.0 ) - $ LBE = MAX( 0, N - 1 ) - CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB, - $ C, LDC, DUM, 1, INFO ) - CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE ) - IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ ) - IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ ) - RETURN -C *** Last line of TG01ID *** - END diff --git a/slycot/src/TG01JD.f b/slycot/src/TG01JD.f deleted file mode 100644 index 93cecec4..00000000 --- a/slycot/src/TG01JD.f +++ /dev/null @@ -1,613 +0,0 @@ - SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, - $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To find a reduced (controllable, observable, or irreducible) -C descriptor representation (Ar-lambda*Er,Br,Cr) for an original -C descriptor representation (A-lambda*E,B,C). -C The pencil Ar-lambda*Er is in an upper block Hessenberg form, with -C either Ar or Er upper triangular. -C -C ARGUMENTS -C -C Mode Parameters -C -C JOB CHARACTER*1 -C Indicates whether the user wishes to remove the -C uncontrollable and/or unobservable parts as follows: -C = 'I': Remove both the uncontrollable and unobservable -C parts to get an irreducible descriptor -C representation; -C = 'C': Remove the uncontrollable part only to get a -C controllable descriptor representation; -C = 'O': Remove the unobservable part only to get an -C observable descriptor representation. -C -C SYSTYP CHARACTER*1 -C Indicates the type of descriptor system algorithm -C to be applied according to the assumed -C transfer-function matrix as follows: -C = 'R': Rational transfer-function matrix; -C = 'S': Proper (standard) transfer-function matrix; -C = 'P': Polynomial transfer-function matrix. -C -C EQUIL CHARACTER*1 -C Specifies whether the user wishes to preliminarily scale -C the system (A-lambda*E,B,C) as follows: -C = 'S': Perform scaling; -C = 'N': Do not perform scaling. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The dimension of the descriptor state vector; also the -C order of square matrices A and E, the number of rows of -C matrix B, and the number of columns of matrix C. N >= 0. -C -C M (input) INTEGER -C The dimension of descriptor system input vector; also the -C number of columns of matrix B. M >= 0. -C -C P (input) INTEGER -C The dimension of descriptor system output vector; also the -C number of rows of matrix C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state matrix A. -C On exit, the leading NR-by-NR part of this array contains -C the reduced order state matrix Ar of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'. -C If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar] -C is in a controllable staircase form (see TG01HD). -C If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar ) -C ( Cr ) -C is in an observable staircase form (see TG01HD). -C The block structure of staircase forms is contained -C in the leading INFRED(7) elements of IWORK. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the original descriptor matrix E. -C On exit, the leading NR-by-NR part of this array contains -C the reduced order descriptor matrix Er of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C The resulting Er has INFRED(6) nonzero sub-diagonals. -C If at least for one k = 1,...,4, INFRED(k) >= 0, then the -C resulting Er is structured being either upper triangular -C or block Hessenberg, in accordance to the last -C performed order reduction phase (see METHOD). -C The block structure of staircase forms is contained -C in the leading INFRED(7) elements of IWORK. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), -C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. -C On entry, the leading N-by-M part of this array must -C contain the original input matrix B; if JOB = 'I', -C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) -C part is used as internal workspace. -C On exit, the leading NR-by-M part of this array contains -C the reduced input matrix Br of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'C', only the first IWORK(1) rows of B are -C nonzero. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the original output matrix C; if JOB = 'I', -C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N -C part is used as internal workspace. -C On exit, the leading P-by-NR part of this array contains -C the transformed state/output matrix Cr of an irreducible, -C controllable, or observable realization for the original -C system, depending on the value of JOB, JOB = 'I', -C JOB = 'C', or JOB = 'O', respectively. -C If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns -C (in the first NR columns) of C are nonzero. -C -C LDC INTEGER -C The leading dimension of array C. -C LDC >= MAX(1,M,P) if N > 0. -C LDC >= 1 if N = 0. -C -C NR (output) INTEGER -C The order of the reduced descriptor representation -C (Ar-lambda*Er,Br,Cr) of an irreducible, controllable, -C or observable realization for the original system, -C depending on JOB = 'I', JOB = 'C', or JOB = 'O', -C respectively. -C -C INFRED (output) INTEGER array, dimension 7 -C This array contains information on performed reduction -C and on structure of resulting system matrices as follows: -C INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction -C (see METHOD) has been performed. In this -C case, INFRED(k) is the achieved order -C reduction in Phase k. -C INFRED(k) < 0 (k = 1, 2, 3, or 4) if Phase k was not -C performed. -C INFRED(5) - the number of nonzero sub-diagonals of A. -C INFRED(6) - the number of nonzero sub-diagonals of E. -C INFRED(7) - the number of blocks in the resulting -C staircase form at last performed reduction -C phase. The block dimensions are contained -C in the first INFRED(7) elements of IWORK. -C -C Tolerances -C -C TOL DOUBLE PRECISION -C The tolerance to be used in rank determinations when -C transforming (A-lambda*E,B,C). If the user sets TOL > 0, -C then the given value of TOL is used as a lower bound for -C reciprocal condition numbers in rank determinations; a -C (sub)matrix whose estimated condition number is less than -C 1/TOL is considered to be of full rank. If the user sets -C TOL <= 0, then an implicitly computed, default tolerance, -C defined by TOLDEF = N*N*EPS, is used instead, where -C EPS is the machine precision (see LAPACK Library routine -C DLAMCH). TOL < 1. -C -C Workspace -C -C IWORK INTEGER array, dimension N+MAX(M,P) -C On exit, if INFO = 0, the leading INFRED(7) elements of -C IWORK contain the orders of the diagonal blocks of -C Ar-lambda*Er. -C -C DWORK DOUBLE PRECISION array, dimension LDWORK -C -C LDWORK INTEGER -C The length of the array DWORK. -C LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S'; -C LDWORK >= MAX(N,2*M,2*P), if EQUIL = 'N'. -C If LDWORK >= MAX(2*N*N+N*M+N*P)+MAX(N,2*M,2*P) then more -C accurate results are to be expected by performing only -C those reductions phases (see METHOD), where effective -C order reduction occurs. This is achieved by saving the -C system matrices before each phase and restoring them if no -C order reduction took place. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The subroutine is based on the reduction algorithms of [1]. -C The order reduction is performed in 4 phases: -C Phase 1: Eliminate all finite uncontrolable eigenvalues. -C The resulting matrix ( Br Ar ) is in a controllable -C staircase form (see SLICOT Library routine TG01HD), and -C Er is upper triangular. -C This phase is performed if JOB = 'I' or 'C' and -C SYSTYP = 'R' or 'S'. -C Phase 2: Eliminate all infinite and finite nonzero uncontrollable -C eigenvalues. The resulting matrix ( Br Er ) is in a -C controllable staircase form (see TG01HD), and Ar is -C upper triangular. -C This phase is performed if JOB = 'I' or 'C' and -C SYSTYP = 'R' or 'P'. -C Phase 3: Eliminate all finite unobservable eigenvalues. -C The resulting matrix ( Ar ) is in an observable -C ( Cr ) -C staircase form (see SLICOT Library routine TG01ID), and -C Er is upper triangular. -C This phase is performed if JOB = 'I' or 'O' and -C SYSTYP = 'R' or 'S'. -C Phase 4: Eliminate all infinite and finite nonzero unobservable -C eigenvalues. The resulting matrix ( Er ) is in an -C ( Cr ) -C observable staircase form (see TG01ID), and Ar is -C upper triangular. -C This phase is performed if JOB = 'I' or 'O' and -C SYSTYP = 'R' or 'P'. -C -C REFERENCES -C -C [1] A. Varga -C Computation of Irreducible Generalized State-Space -C Realizations. -C Kybernetika, vol. 26, pp. 89-106, 1990. -C -C NUMERICAL ASPECTS -C -C The algorithm is numerically backward stable and requires -C 0( N**3 ) floating point operations. -C -C FURTHER COMMENTS -C -C If the pencil (A-lambda*E) has no zero eigenvalues, then an -C irreducible realization can be computed skipping Phases 1 and 3 -C by using the setting: JOB = 'I' and SYSTYP = 'P'. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C April 1999. Based on the RASP routine RPDSIR. -C -C REVISIONS -C -C July 1999, V. Sima, Research Institute for Informatics, Bucharest. -C May 2003, A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. -C May 2003, March 2004, V. Sima. -C -C KEYWORDS -C -C Controllability, irreducible realization, observability, -C orthogonal canonical form, orthogonal transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) -C .. Scalar Arguments .. - CHARACTER EQUIL, JOB, SYSTYP - INTEGER INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P - DOUBLE PRECISION TOL -C .. Array Arguments .. - INTEGER INFRED(*), IWORK(*) - DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), E(LDE,*) -C .. Local Scalars .. - CHARACTER JOBQ, JOBZ - LOGICAL FINCON, FINOBS, INFCON, INFOBS, LEQUIL, LJOBC, - $ LJOBIR, LJOBO, LSPACE, LSYSP, LSYSR, LSYSS - INTEGER KWA, KWB, KWC, KWE, LBA, LBE, LDM, LDP, LDQ, - $ LDZ, M1, MAXMP, N1, NBLCK, NC, P1 -C .. Local Arrays .. - DOUBLE PRECISION DUM(1) -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, MA02CD, TB01XD, TG01AD, TG01HX, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C - INFO = 0 - MAXMP = MAX( M, P ) - N1 = MAX( 1, N ) -C -C Decode JOB. -C - LJOBIR = LSAME( JOB, 'I' ) - LJOBC = LJOBIR .OR. LSAME( JOB, 'C' ) - LJOBO = LJOBIR .OR. LSAME( JOB, 'O' ) -C -C Decode SYSTYP. -C - LSYSR = LSAME( SYSTYP, 'R' ) - LSYSS = LSYSR .OR. LSAME( SYSTYP, 'S' ) - LSYSP = LSYSR .OR. LSAME( SYSTYP, 'P' ) -C - LEQUIL = LSAME( EQUIL, 'S' ) -C -C Test the input scalar arguments. -C - IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN - INFO = -1 - ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN - INFO = -2 - ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -5 - ELSE IF( P.LT.0 ) THEN - INFO = -6 - ELSE IF( LDA.LT.N1 ) THEN - INFO = -8 - ELSE IF( LDE.LT.N1 ) THEN - INFO = -10 - ELSE IF( LDB.LT.N1 ) THEN - INFO = -12 - ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN - INFO = -14 - ELSE IF( TOL.GE.ONE ) THEN - INFO = -17 - ELSE IF( ( .NOT.LEQUIL .AND. LDWORK.LT.MAX( N, 2*MAXMP ) ) .OR. - $ ( LEQUIL .AND. LDWORK.LT.MAX( 8*N, 2*MAXMP ) ) ) THEN - INFO = -20 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TG01JD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - INFRED(1) = -1 - INFRED(2) = -1 - INFRED(3) = -1 - INFRED(4) = -1 - INFRED(5) = 0 - INFRED(6) = 0 - INFRED(7) = 0 -C - IF( MAX( N, MAXMP ).EQ.0 ) THEN - NR = 0 - RETURN - END IF -C - M1 = MAX( 1, M ) - P1 = MAX( 1, P ) - LDM = MAX( LDC, M ) - LDP = MAX( LDC, P ) -C -C Set controllability/observability determination options. -C - FINCON = LJOBC .AND. LSYSS - INFCON = LJOBC .AND. LSYSP - FINOBS = LJOBO .AND. LSYSS - INFOBS = LJOBO .AND. LSYSP -C -C Set large workspace option and determine offsets. -C - LSPACE = LDWORK.GE.N*( 2*N + M + P ) + MAX( N, 2*MAXMP ) - KWA = MAX( N, 2*MAXMP ) + 1 - KWE = KWA + N*N - KWB = KWE + N*N - KWC = KWB + N*M -C -C If required, scale the system (A-lambda*E,B,C). -C Workspace: need 8*N. -C - IF( LEQUIL ) THEN - CALL TG01AD( 'All', N, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, - $ C, LDP, DWORK(1), DWORK(N+1), DWORK(2*N+1), INFO ) - END IF -C - JOBQ = 'N' - JOBZ = 'N' - LDQ = 1 - LDZ = 1 - LBA = MAX( 0, N-1 ) - LBE = LBA - NC = N - NR = N -C - IF( FINCON ) THEN -C -C Phase 1: Eliminate all finite uncontrolable eigenvalues. -C - IF( LSPACE) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) - CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) - END IF -C -C Perform finite controllability form reduction. -C Workspace: need MAX(N,2*M). -C - CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA, - $ E, LDE, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBA = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBA = IWORK(1) - 1 - ELSE - LBA = 0 - END IF - LBE = 0 - INFRED(1) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) - CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) - END IF - END IF -C - IF( INFCON ) THEN -C -C Phase 2: Eliminate all infinite and all finite nonzero -C uncontrolable eigenvalues. -C - IF( LSPACE ) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) - CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) - END IF -C -C Perform infinite controllability form reduction. -C Workspace: need MAX(N,2*M). -C - CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBE = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBE = IWORK(1) - 1 - ELSE - LBE = 0 - END IF - LBA = 0 - INFRED(2) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) - CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) - END IF - END IF -C - IF( FINOBS .OR. INFOBS) THEN -C -C Compute the pertransposed dual system exploiting matrix shapes. -C - CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, - $ B, LDB, C, LDC, DUM, 1, INFO ) - CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) - END IF -C - IF( FINOBS ) THEN -C -C Phase 3: Eliminate all finite unobservable eigenvalues. -C - IF( LSPACE ) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) - CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) - END IF -C -C Perform finite observability form reduction. -C Workspace: need MAX(N,2*P). -C - CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA, - $ E, LDE, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBA = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBA = IWORK(1) - 1 - ELSE - LBA = 0 - END IF - LBE = 0 - INFRED(3) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) - CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) - END IF - END IF -C - IF( INFOBS ) THEN -C -C Phase 4: Eliminate all infinite and all finite nonzero -C unobservable eigenvalues. -C - IF( LSPACE) THEN -C -C Save system matrices. -C - CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) - CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) - CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) - CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) - END IF -C -C Perform infinite observability form reduction. -C Workspace: need MAX(N,2*P). -C - CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE, - $ A, LDA, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, - $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) - IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN - IF( NBLCK.GT.1 ) THEN - LBE = IWORK(1) + IWORK(2) - 1 - ELSE IF( NBLCK.EQ.1 ) THEN - LBE = IWORK(1) - 1 - ELSE - LBE = 0 - END IF - LBA = 0 - INFRED(4) = NC - NR - INFRED(7) = NBLCK - NC = NR - ELSE -C -C Restore system matrices. -C - CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) - CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) - CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) - CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) - END IF - END IF -C - IF( FINOBS .OR. INFOBS ) THEN -C -C Compute the pertransposed dual system exploiting matrix shapes. -C - CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, - $ B, LDB, C, LDC, DUM, 1, INFO ) - CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) - END IF -C -C Set structural information on A and E. -C - INFRED(5) = LBA - INFRED(6) = LBE -C - RETURN -C *** Last line of TG01JD *** - END diff --git a/slycot/src/TG01WD.f b/slycot/src/TG01WD.f deleted file mode 100644 index 26d06848..00000000 --- a/slycot/src/TG01WD.f +++ /dev/null @@ -1,319 +0,0 @@ - SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, - $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, - $ LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To reduce the pair (A,E) to a real generalized Schur form -C by using an orthogonal equivalence transformation -C (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation -C to the matrices B and C: B <-- Q'*B and C <-- C*Z. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the original state-space representation, -C i.e., the order of the matrices A and E. N >= 0. -C -C M (input) INTEGER -C The number of system inputs, or of columns of B. M >= 0. -C -C P (input) INTEGER -C The number of system outputs, or of rows of C. P >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N part of this array must -C contain the original state dynamics matrix A. -C On exit, the leading N-by-N part of this array contains -C the matrix Q' * A * Z in an upper quasi-triangular form. -C The elements below the first subdiagonal are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,N). -C -C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) -C On entry, the leading N-by-N part of this array must -C contain the original descriptor matrix E. -C On exit, the leading N-by-N part of this array contains -C the matrix Q' * E * Z in an upper triangular form. -C The elements below the diagonal are set to zero. -C -C LDE INTEGER -C The leading dimension of array E. LDE >= MAX(1,N). -C -C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading N-by-M part of this array must -C contain the input matrix B. -C On exit, the leading N-by-M part of this array contains -C the transformed input matrix Q' * B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,N). -C -C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -C On entry, the leading P-by-N part of this array must -C contain the output matrix C. -C On exit, the leading P-by-N part of this array contains -C the transformed output matrix C * Z. -C -C LDC INTEGER -C The leading dimension of array C. LDC >= MAX(1,P). -C -C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) -C The leading N-by-N part of this array contains the left -C orthogonal transformation matrix used to reduce (A,E) to -C the real generalized Schur form. -C The columns of Q are the left generalized Schur vectors -C of the pair (A,E). -C -C LDQ INTEGER -C The leading dimension of array Q. LDQ >= max(1,N). -C -C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) -C The leading N-by-N part of this array contains the right -C orthogonal transformation matrix used to reduce (A,E) to -C the real generalized Schur form. -C The columns of Z are the right generalized Schur vectors -C of the pair (A,E). -C -C LDZ INTEGER -C The leading dimension of array Z. LDZ >= max(1,N). -C -C ALPHAR (output) DOUBLE PRECISION array, dimension (N) -C ALPHAI (output) DOUBLE PRECISION array, dimension (N) -C BETA (output) DOUBLE PRECISION array, dimension (N) -C On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), -C j=1,...,N, will be the generalized eigenvalues. -C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the -C diagonals of the complex Schur form that would result if -C the 2-by-2 diagonal blocks of the real Schur form of -C (A,E) were further reduced to triangular form using -C 2-by-2 complex unitary transformations. -C If ALPHAI(j) is zero, then the j-th eigenvalue is real; -C if positive, then the j-th and (j+1)-st eigenvalues are a -C complex conjugate pair, with ALPHAI(j+1) negative. -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C On exit, if INFO = 0, DWORK(1) returns the optimal value -C of LDWORK. -C -C LDWORK INTEGER -C The dimension of working array DWORK. LDWORK >= 8*N+16. -C For optimum performance LDWORK should be larger. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C > 0: if INFO = i, the QZ algorithm failed to compute -C the generalized real Schur form; elements i+1:N of -C ALPHAR, ALPHAI, and BETA should be correct. -C -C METHOD -C -C The pair (A,E) is reduced to a real generalized Schur form using -C an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z) -C and the transformation is applied to the matrices B and C: -C B <-- Q'*B and C <-- C*Z. -C -C NUMERICAL ASPECTS -C 3 -C The algorithm requires about 25N floating point operations. -C -C CONTRIBUTOR -C -C A. Varga, German Aerospace Center, -C DLR Oberpfaffenhofen, July 2000. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. -C -C KEYWORDS -C -C Orthogonal transformation, generalized real Schur form, similarity -C transformation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, - $ M, N, P -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), - $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), - $ Q(LDQ,*), Z(LDZ,*) -C .. Local Scalars .. - LOGICAL BLAS3, BLOCK - INTEGER BL, CHUNK, I, J, MAXWRK, SDIM -C .. Local Arrays .. - LOGICAL BWORK(1) -C .. External Functions .. - LOGICAL LSAME, DELCTG - EXTERNAL LSAME, DELCTG -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, INT, MAX, MIN -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the scalar input parameters. -C - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( P.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDE.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - ELSE IF( LDC.LT.MAX( 1, P ) ) THEN - INFO = -11 - ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN - INFO = -13 - ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN - INFO = -15 - ELSE IF( LDWORK.LT.8*N+16 ) THEN - INFO = -20 - END IF -C - IF( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'TG01WD', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF( N.EQ.0 ) THEN - DWORK(1) = ONE - RETURN - END IF -C -C Reduce (A,E) to real generalized Schur form using an orthogonal -C equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate -C the transformations in Q and Z, and compute the generalized -C eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA). -C -C Workspace: need 8*N+16; -C prefer larger. -C - CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, - $ A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, - $ Z, LDZ, DWORK, LDWORK, BWORK, INFO ) - IF( INFO.NE.0 ) - $ RETURN - MAXWRK = INT( DWORK(1) ) -C -C Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space. -C - CHUNK = LDWORK / N - BLOCK = M.GT.1 - BLAS3 = CHUNK.GE.M .AND. BLOCK -C - IF( BLAS3 ) THEN -C -C Enough workspace for a fast BLAS 3 algorithm. -C - CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ, - $ DWORK, N, ZERO, B, LDB ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many columns of B as possible. -C - DO 10 J = 1, M, CHUNK - BL = MIN( M-J+1, CHUNK ) - CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N ) - CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q, - $ LDQ, DWORK, N, ZERO, B(1,J), LDB ) - 10 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. Here, M <= 1. -C - IF ( M.GT.0 ) THEN - CALL DCOPY( N, B, 1, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO, - $ B, 1 ) - END IF - END IF - MAXWRK = MAX( MAXWRK, N*M ) -C -C Apply the transformation: C <-- C*Z. Use BLAS 3, if enough space. -C - BLOCK = P.GT.1 - BLAS3 = CHUNK.GE.P .AND. BLOCK -C - IF ( BLAS3 ) THEN - CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) - CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, - $ DWORK, P, Z, LDZ, ZERO, C, LDC ) -C - ELSE IF ( BLOCK ) THEN -C -C Use as many rows of C as possible. -C - DO 20 I = 1, P, CHUNK - BL = MIN( P-I+1, CHUNK ) - CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL ) - CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, - $ DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC ) - 20 CONTINUE -C - ELSE -C -C Use a BLAS 2 algorithm. Here, P <= 1. -C - IF ( P.GT.0 ) THEN - CALL DCOPY( N, C, LDC, DWORK, 1 ) - CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO, - $ C, LDC ) - END IF -C - END IF - MAXWRK = MAX( MAXWRK, P*N ) -C - DWORK(1) = DBLE( MAXWRK ) -C - RETURN -C *** Last line of TG01WD *** - END diff --git a/slycot/src/UD01BD.f b/slycot/src/UD01BD.f deleted file mode 100644 index 256984c1..00000000 --- a/slycot/src/UD01BD.f +++ /dev/null @@ -1,149 +0,0 @@ - SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To read the coefficients of a matrix polynomial -C dp-1 dp -C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the matrix polynomial P(s). -C MP >= 1. -C -C NP (input) INTEGER -C The number of columns of the matrix polynomial P(s). -C NP >= 1. -C -C DP (input) INTEGER -C The degree of the matrix polynomial P(s). DP >= 0. -C -C NIN (input) INTEGER -C The input channel from which the elements of P(s) are -C read. NIN >= 0. -C -C P (output) DOUBLE PRECISION array, dimension -C (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array contains -C the coefficients of the matrix polynomial P(s). -C Specifically, P(i,j,k) contains the coefficient of -C s**(k-1) of the polynomial which is the (i,j)-th element -C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and -C k = 1,2,...,DP+1. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MP. -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= NP. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The coefficients P(i), i = 0, ..., DP, which are MP-by-NP -C matrices, are read from the input file NIN row by row. Each P(i) -C must be preceded by a text line. This text line can be used to -C indicate the coefficient matrices. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine RDMAPO by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN -C .. Array Arguments .. - DOUBLE PRECISION P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER I, J, K -C .. External Subroutines .. - EXTERNAL XERBLA -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( MP.LT.1 ) THEN - INFO = -1 - ELSE IF( NP.LT.1 ) THEN - INFO = -2 - ELSE IF( DP.LT.0 ) THEN - INFO = -3 - ELSE IF( NIN.LT.0 ) THEN - INFO = -4 - ELSE IF( LDP1.LT.MP ) THEN - INFO = -6 - ELSE IF( LDP2.LT.NP ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01BD', -INFO ) - RETURN - END IF -C -C Skip the text line preceding P(i) and read P(i), i = 0, ..., DP, -C row after row. -C - DO 20 K = 1, DP + 1 - READ ( NIN, FMT = '()' ) -C - DO 10 I = 1, MP - READ ( NIN, FMT = * ) ( P(I,J,K), J = 1, NP ) - 10 CONTINUE -C - 20 CONTINUE -C - RETURN -C *** Last line of UD01BD *** - END diff --git a/slycot/src/UD01CD.f b/slycot/src/UD01CD.f deleted file mode 100644 index 52a10455..00000000 --- a/slycot/src/UD01CD.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To read the elements of a sparse matrix polynomial -C dp-1 dp -C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the matrix polynomial P(s). -C MP >= 1. -C -C NP (input) INTEGER -C The number of columns of the matrix polynomial P(s). -C NP >= 1. -C -C DP (input) INTEGER -C The degree of the matrix polynomial P(s). DP >= 0. -C -C NIN (input) INTEGER -C The input channel from which the elements of P(s) are -C read. NIN >= 0. -C -C P (output) DOUBLE PRECISION array, dimension -C (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array contains -C the coefficients of the matrix polynomial P(s). -C Specifically, P(i,j,k) contains the coefficient of -C s**(k-1) of the polynomial which is the (i,j)-th element -C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and -C k = 1,2,...,DP+1. -C The not assigned elements are set to zero. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MP. -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= NP. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : if a row index i is read with i < 1 or i > MP or -C a column index j is read with j < 1 or j > NP or -C a coefficient degree d is read with d < 0 or -C d > DP + 1. This is a warning. -C -C METHOD -C -C First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and -C 1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial) -C elements are read from the input file NIN. Each nonzero element is -C given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is -C the degree and P(i,j,k) is the coefficient of s**(k-1) in the -C (i,j)-th element of P(s), i.e., let -C d -C P (s) = P (0) + P (1) * s + . . . + P (d) * s -C i,j i,j i,j i,j -C -C be the nonzero (i,j)-th element of the matrix polynomial P(s). -C -C Then P(i,j,k) corresponds to coefficient P (k-1), k = 1,...,d+1. -C i,j -C For each nonzero element, the values i, j, and d are read as one -C record of the file NIN, and the values P(i,j,k), k = 1,...,d+1, -C are read as the following record. -C The routine terminates after the last line has been read. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine RDSPOM by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN -C .. Array Arguments .. - DOUBLE PRECISION P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER D, I, J, K -C .. External Subroutines .. - EXTERNAL DLASET, XERBLA -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( MP.LT.1 ) THEN - INFO = -1 - ELSE IF( NP.LT.1 ) THEN - INFO = -2 - ELSE IF( DP.LT.0 ) THEN - INFO = -3 - ELSE IF( NIN.LT.0 ) THEN - INFO = -4 - ELSE IF( LDP1.LT.MP ) THEN - INFO = -6 - ELSE IF( LDP2.LT.NP ) THEN - INFO = -7 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01CD', -INFO ) - RETURN - END IF -C - DO 10 K = 1, DP+1 - CALL DLASET( 'Full', MP, NP, ZERO, ZERO, P(1,1,K), LDP1 ) - 10 CONTINUE -C -C Read (i, j, d, P(i,j,k), k=1,...,d+1) of the nonzero elements one -C by one. -C - 20 READ( NIN, FMT = *, END = 30 ) I, J, D - IF ( I.LT.1 .OR. I.GT.MP .OR. J.LT.1 .OR. J.GT.NP .OR. - $ D.LT.0 .OR. D.GT.(DP+1) ) THEN - INFO = 1 - READ ( NIN, FMT = * ) - ELSE - READ ( NIN, FMT = * ) ( P(I,J,K), K = 1, D+1 ) - END IF - GO TO 20 -C - 30 CONTINUE - RETURN -C *** Last line of UD01CD *** - END diff --git a/slycot/src/UD01DD.f b/slycot/src/UD01DD.f deleted file mode 100644 index d09cadbd..00000000 --- a/slycot/src/UD01DD.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To read the elements of a sparse matrix. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrix A. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrix A. N >= 0. -C -C NIN (input) INTEGER -C The input channel from which the elements of A are read. -C NIN >= 0. -C -C A (output) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array contains the sparse -C matrix A. The not assigned elements are set to zero. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value; -C = 1 : if a row index i is read with i < 1 or i > M or -C a column index j is read with j < 1 or j > N. -C This is a warning. -C -C METHOD -C -C First, the elements A(i,j) with 1 <= i <= M and 1 <= j <= N are -C set to zero. Next the nonzero elements are read from the input -C file NIN. Each line of NIN must contain consecutively the values -C i, j, A(i,j). The routine terminates after the last line has been -C read. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine RDSPAR by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) -C .. Scalar Arguments .. - INTEGER INFO, LDA, M, N, NIN -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION AIJ -C .. External Subroutines .. - EXTERNAL DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C -C .. Executable statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NIN.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01DD', -INFO ) - RETURN - END IF -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) -C -C Read (i, j, A(i,j)) of the nonzero elements one by one. -C - 10 READ( NIN, FMT = *, END = 20 ) I, J, AIJ - IF ( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN - INFO = 1 - ELSE - A(I,J) = AIJ - END IF - GO TO 10 - 20 CONTINUE -C - RETURN -C *** Last line of UD01DD *** - END diff --git a/slycot/src/UD01MD.f b/slycot/src/UD01MD.f deleted file mode 100644 index a44e6545..00000000 --- a/slycot/src/UD01MD.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To print an M-by-N real matrix A row by row. The elements of A -C are output to 7 significant figures. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of matrix A to be printed. M >= 1. -C -C N (input) INTEGER -C The number of columns of matrix A to be printed. N >= 1. -C -C L (input) INTEGER -C The number of elements of matrix A to be printed per line. -C 1 <= L <= 5. -C -C NOUT (input) INTEGER -C The output channel to which the results are sent. -C NOUT >= 0. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix to be printed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= M. -C -C TEXT (input) CHARACTER*72. -C Title caption of the matrix to be printed (up to a -C maximum of 72 characters). For example, TEXT = 'Matrix A'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine first prints the contents of TEXT as a title, followed -C by the elements of the matrix A such that -C -C (i) if N <= L, the leading M-by-N part is printed; -C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of -C consecutive columns of A are printed one after another -C followed by one M-by-p block containing the last p columns -C of A. -C -C Row numbers are printed on the left of each row and a column -C number appears on top of each column. -C The routine uses 2 + (k + 1)*(m + 1) lines and 8 + 15*c positions -C per line where c is the actual number of columns, (i.e. c = L -C or c = p). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. -C Supersedes Release 2.0 routine UD01AD by H. Willemsen, Eindhoven -C University of Technology, Holland. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, M, N, NOUT - CHARACTER*(*) TEXT -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC LEN, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( M.LT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.1 ) THEN - INFO = -2 - ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN - INFO = -3 - ELSE IF( NOUT.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.M ) THEN - INFO = -6 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01MD', -INFO ) - RETURN - END IF -C - LENTXT = LEN( TEXT ) -C - DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 - IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 - 20 CONTINUE -C - 40 CONTINUE - WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N - N1 = ( N-1 )/L - J1 = 1 - J2 = L -C - DO 80 J = 1, N1 - WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) -C - DO 60 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) - 60 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) - J1 = J1 + L - J2 = J2 + L - 80 CONTINUE -C - WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) -C - DO 100 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) - 100 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) -C - RETURN -C -99999 FORMAT (8X,5(5X,I5,5X) ) -99998 FORMAT (' ' ) -99997 FORMAT (1X,I5,2X,5D15.7 ) -99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) -C *** Last line of UD01MD *** - END diff --git a/slycot/src/UD01MZ.f b/slycot/src/UD01MZ.f deleted file mode 100644 index a9d83f70..00000000 --- a/slycot/src/UD01MZ.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To print an M-by-N real matrix A row by row. The elements of A -C are output to 7 significant figures. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of matrix A to be printed. M >= 1. -C -C N (input) INTEGER -C The number of columns of matrix A to be printed. N >= 1. -C -C L (input) INTEGER -C The number of elements of matrix A to be printed per line. -C 1 <= L <= 3. -C -C NOUT (input) INTEGER -C The output channel to which the results are sent. -C NOUT >= 0. -C -C A (input) COMPLEX*16 array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix to be printed. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= M. -C -C TEXT (input) CHARACTER*72. -C Title caption of the matrix to be printed (up to a -C maximum of 72 characters). For example, TEXT = 'Matrix A'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The routine first prints the contents of TEXT as a title, followed -C by the elements of the matrix A such that -C -C (i) if N <= L, the leading M-by-N part is printed; -C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of -C consecutive columns of A are printed one after another -C followed by one M-by-p block containing the last p columns -C of A. -C -C Row numbers are printed on the left of each row and a column -C number appears on top of each complex column. -C The routine uses 2 + (k + 1)*(m + 1) lines and 7 + 32*c positions -C per line where c is the actual number of columns, (i.e. c = L -C or c = p). -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. -C Complex version: V. Sima, Research Institute for Informatics, -C Bucharest, Dec. 2008. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER INFO, L, LDA, M, N, NOUT - CHARACTER*(*) TEXT -C .. Array Arguments .. - COMPLEX*16 A(LDA,*) -C .. Local Scalars .. - INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC LEN, MIN -C .. Executable Statements .. -C - INFO = 0 -C -C Test the input scalar arguments. -C - IF( M.LT.1 ) THEN - INFO = -1 - ELSE IF( N.LT.1 ) THEN - INFO = -2 - ELSE IF( L.LT.1 .OR. L.GT.3 ) THEN - INFO = -3 - ELSE IF( NOUT.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.M ) THEN - INFO = -6 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01MZ', -INFO ) - RETURN - END IF -C - LENTXT = LEN( TEXT ) -C - DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 - IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 - 20 CONTINUE -C - 40 CONTINUE - WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N - N1 = ( N-1 )/L - J1 = 1 - J2 = L -C - DO 80 J = 1, N1 - WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) -C - DO 60 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) - 60 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) - J1 = J1 + L - J2 = J2 + L - 80 CONTINUE -C - WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) -C - DO 100 I = 1, M - WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) - 100 CONTINUE -C - WRITE ( NOUT, FMT=99998 ) -C - RETURN -C -99999 FORMAT (7X,5(13X,I5,14X) ) -99998 FORMAT (' ' ) -99997 FORMAT (1X,I5,2X,3(D15.7,SP,D15.7,S,'i ') ) -99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) -C *** Last line of UD01MZ *** - END diff --git a/slycot/src/UD01ND.f b/slycot/src/UD01ND.f deleted file mode 100644 index 1791f986..00000000 --- a/slycot/src/UD01ND.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To print the MP-by-NP coefficient matrices of a matrix polynomial -C dp-1 dp -C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . -C -C The elements of the matrices are output to 7 significant figures. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C MP (input) INTEGER -C The number of rows of the matrix polynomial P(s). -C MP >= 1. -C -C NP (input) INTEGER -C The number of columns of the matrix polynomial P(s). -C NP >= 1. -C -C DP (input) INTEGER -C The degree of the matrix polynomial P(s). DP >= 0. -C -C L (input) INTEGER -C The number of elements of the coefficient matrices to be -C printed per line. 1 <= L <= 5. -C -C NOUT (input) INTEGER -C The output channel to which the results are sent. -C NOUT >= 0. -C -C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) -C The leading MP-by-NP-by-(DP+1) part of this array must -C contain the coefficients of the matrix polynomial P(s). -C Specifically, P(i,j,k) must contain the coefficient of -C s**(k-1) of the polynomial which is the (i,j)-th element -C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and -C k = 1,2,...,DP+1. -C -C LDP1 INTEGER -C The leading dimension of array P. LDP1 >= MP. -C -C LDP2 INTEGER -C The second dimension of array P. LDP2 >= NP. -C -C TEXT (input) CHARACTER*72 -C Title caption of the coefficient matrices to be printed. -C TEXT is followed by the degree of the coefficient matrix, -C within brackets. If TEXT = ' ', then the coefficient -C matrices are separated by an empty line. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C For i = 1, 2, ..., DP + 1 the routine first prints the contents of -C TEXT followed by (i-1) as a title, followed by the elements of the -C MP-by-NP coefficient matrix P(i) such that -C (i) if NP < L, then the leading MP-by-NP part is printed; -C (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of -C consecutive columns of P(i) are printed one after another -C followed by one MP-by-p block containing the last p columns -C of P(i). -C Row numbers are printed on the left of each row and a column -C number on top of each column. -C -C REFERENCES -C -C None. -C -C NUMERICAL ASPECTS -C -C None. -C -C CONTRIBUTOR -C -C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. -C Based on routine PRMAPO by A.J. Geurts, Eindhoven University of -C Technology, Holland. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - INTEGER DP, INFO, L, LDP1, LDP2, MP, NP, NOUT - CHARACTER*(*) TEXT -C .. Array Arguments .. - DOUBLE PRECISION P(LDP1,LDP2,*) -C .. Local Scalars .. - INTEGER I, J, J1, J2, JJ, K, LENTXT, LTEXT, N1 -C .. External Subroutines .. - EXTERNAL XERBLA -C .. Intrinsic Functions .. - INTRINSIC LEN, MIN -C -C .. Executable Statements .. -C - INFO = 0 -C -C Check the input scalar arguments. -C - IF( MP.LT.1 ) THEN - INFO = -1 - ELSE IF( NP.LT.1 ) THEN - INFO = -2 - ELSE IF( DP.LT.0 ) THEN - INFO = -3 - ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN - INFO = -4 - ELSE IF( NOUT.LT.0 ) THEN - INFO = -5 - ELSE IF( LDP1.LT.MP ) THEN - INFO = -7 - ELSE IF( LDP2.LT.NP ) THEN - INFO = -8 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'UD01ND', -INFO ) - RETURN - END IF -C - LENTXT = LEN( TEXT ) - LTEXT = MIN( 72, LENTXT ) -C WHILE ( TEXT(LTEXT:LTEXT) = ' ' ) DO - 10 IF ( TEXT(LTEXT:LTEXT).EQ.' ' ) THEN - LTEXT = LTEXT - 1 - GO TO 10 - END IF -C END WHILE 10 -C - DO 50 K = 1, DP + 1 - IF ( LTEXT.EQ.0 ) THEN - WRITE ( NOUT, FMT = 99999 ) - ELSE - WRITE ( NOUT, FMT = 99998 ) TEXT(1:LTEXT), K - 1, MP, NP - END IF - N1 = ( NP - 1 )/L - J1 = 1 - J2 = L -C - DO 30 J = 1, N1 - WRITE ( NOUT, FMT = 99997 ) ( JJ, JJ = J1, J2 ) -C - DO 20 I = 1, MP - WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, J2 ) - 20 CONTINUE -C - J1 = J1 + L - J2 = J2 + L - 30 CONTINUE -C - WRITE ( NOUT, FMT = 99997 ) ( J, J = J1, NP ) -C - DO 40 I = 1, MP - WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, NP ) - 40 CONTINUE -C - 50 CONTINUE -C - WRITE ( NOUT, FMT = 99999 ) -C - RETURN -C -99999 FORMAT (' ') -99998 FORMAT (/, 1X, A, '(', I2, ')', ' (', I2, 'X', I2, ')') -99997 FORMAT (5X, 5(6X, I2, 7X)) -99996 FORMAT (1X, I2, 2X, 5D15.7) -C -C *** Last line of UD01ND *** - END diff --git a/slycot/src/UE01MD.f b/slycot/src/UE01MD.f deleted file mode 100644 index c460bf9b..00000000 --- a/slycot/src/UE01MD.f +++ /dev/null @@ -1,266 +0,0 @@ - INTEGER FUNCTION UE01MD( ISPEC, NAME, OPTS, N1, N2, N3 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C PURPOSE -C -C To provide an extension of the LAPACK routine ILAENV to -C machine-specific parameters for SLICOT routines. -C -C The default values in this version aim to give good performance on -C a wide range of computers. For optimal performance, however, the -C user is advised to modify this routine. Note that an optimized -C BLAS is a crucial prerequisite for any speed gains. For further -C details, see ILAENV. -C -C FUNCTION VALUE -C -C UE01MD INTEGER -C The function value set according to ISPEC. -C -C ARGUMENTS -C -C Input/Output Parameters -C -C ISPEC (input) INTEGER -C Specifies the parameter to be returned as the value of -C UE01MD, as follows: -C = 1: the optimal blocksize; if the returned value is 1, an -C unblocked algorithm will give the best performance; -C = 2: the minimum block size for which the block routine -C should be used; if the usable block size is less than -C this value, an unblocked routine should be used; -C = 3: the crossover point (in a block routine, for N less -C than this value, an unblocked routine should be used) -C = 4: the number of shifts, used in the product eigenvalue -C routine; -C = 8: the crossover point for the multishift QR method for -C product eigenvalue problems. -C -C NAME (input) CHARACTER*(*) -C The name of the calling subroutine, in either upper case -C or lower case. -C -C OPTS (input) CHARACTER*(*) -C The character options to the subroutine NAME, concatenated -C into a single character string. -C -C N1 (input) INTEGER -C N2 (input) INTEGER -C N3 (input) INTEGER -C Problem dimensions for the subroutine NAME; these may not -C all be required. -C -C CONTRIBUTORS -C -C D. Kressner, Technical Univ. Berlin, Germany, and -C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. -C -C REVISIONS -C -C V. Sima, June 2008 (SLICOT version of the HAPACK routine ILAHAP). -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3 -C -C .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1, C3 - CHARACTER*2 C2 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -C .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -C .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, MAX -C -C .. Executable Statements .. -C - IF ( ISPEC.EQ.1 .OR. ISPEC.EQ.2 .OR. ISPEC.EQ.3 ) THEN -C -C Convert NAME to upper case if the first character is lower -C case. -C - UE01MD = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) - IZ = ICHAR( 'Z' ) - IF ( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -C -C ASCII character set. -C - IF ( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -C - ELSE IF ( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -C -C EBCDIC character set. -C - 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 20 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 ) - 20 CONTINUE - END IF -C - ELSE IF ( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -C -C Prime machines: ASCII+128. -C - IF ( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF ( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -C - 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( 4:5 ) - C3 = SUBNAM( 6:6 ) -C - IF ( ISPEC.EQ.1 ) THEN -C -C Block size. -C - NB = 1 - IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN - IF ( C3.EQ.'B' ) THEN - NB = ILAENV( 1, 'DGEQRF', ' ', N1, N2, -1, -1 ) / 2 - ELSE IF ( C3.EQ.'T' ) THEN - NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 4 - END IF - ELSE IF ( C2.EQ.'4P' ) THEN - IF ( C3.EQ.'B' ) THEN - NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 - END IF - ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN - IF ( C3.EQ.'D' ) THEN - NB = ILAENV( 1, 'DORGQR', ' ', N1, N2, N3, -1 ) / 2 - ELSE IF ( C3.EQ.'B' ) THEN - NB = ILAENV( 1, 'DORMQR', ' ', N1, N2, N3, -1 ) / 2 - END IF -** ELSE IF ( C2.EQ.'SH' ) THEN -** IF ( C3.EQ.'PVB' ) THEN -** NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 -** END IF - END IF - UE01MD = NB - ELSE IF ( ISPEC.EQ.2 ) THEN -C -C Minimum block size. -C - NBMIN = 2 - IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN - IF ( C3.EQ.'B' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', N1, N2, -1, - $ -1 ) / 2 ) - ELSE IF ( C3.EQ.'T' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, - $ -1 ) / 4 ) - END IF - ELSE IF ( C2.EQ.'4P' ) THEN - IF ( C3.EQ.'B' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, - $ -1 ) / 4 ) - END IF - ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN - IF ( C3.EQ.'D' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', N1, N2, N3, - $ -1 ) / 2 ) - ELSE IF ( C3.EQ.'B' ) THEN - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', ' ', N1, N2, N3, - $ -1 ) / 2 ) - END IF -** ELSE IF ( C2.EQ.'SH' ) THEN -** IF ( C3.EQ.'PVB' ) THEN -** NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, -** $ -1 ) / 4 ) -** END IF - END IF - UE01MD = NBMIN - ELSE IF ( ISPEC.EQ.3 ) THEN -C -C Crossover point. -C - NX = 0 - IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN - IF ( C3.EQ.'B' ) THEN - NX = ILAENV( 3, 'DGEQRF', ' ', N1, N2, -1, -1 ) - ELSE IF ( C3.EQ.'T' ) THEN - NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 - END IF - ELSE IF ( C2.EQ.'4P' ) THEN - IF ( C3.EQ.'B' ) THEN - NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 - END IF - ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN - IF ( C3.EQ.'D' ) THEN - NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) - ELSE IF ( C3.EQ.'B' ) THEN - NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) - END IF -** ELSE IF ( C2.EQ.'SH' ) THEN -** IF ( C3.EQ.'PVB' ) THEN -** NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 -** END IF - END IF - UE01MD = NX - END IF - ELSE IF ( ISPEC.EQ.4 ) THEN -C -C Number of shifts (used by MB03XP). -C - UE01MD = ILAENV( 4, 'DHSEQR', OPTS, N1, N2, N3, -1 ) - ELSE IF ( ISPEC.EQ.8 ) THEN -C -C Crossover point for multishift (used by MB03XP). -C - UE01MD = ILAENV( 8, 'DHSEQR', OPTS, N1, N2, N3, -1 ) - ELSE -C -C Invalid value for ISPEC. -C - UE01MD = -1 - END IF - RETURN -C *** Last line of UE01MD *** - END diff --git a/slycot/src/delctg.f b/slycot/src/delctg.f deleted file mode 100644 index b6b44b7c..00000000 --- a/slycot/src/delctg.f +++ /dev/null @@ -1,27 +0,0 @@ - LOGICAL FUNCTION DELCTG( PAR1, PAR2, PAR3 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Void logical function for DGGES. -C - DOUBLE PRECISION PAR1, PAR2, PAR3 -C - DELCTG = .TRUE. - RETURN - END diff --git a/slycot/src/makefile b/slycot/src/makefile deleted file mode 100644 index 0e56f8c5..00000000 --- a/slycot/src/makefile +++ /dev/null @@ -1,120 +0,0 @@ -#################################################################### -# SLICOT routines makefile # -# Makefile for creating/updating the SLICOT Library object file # -# on Unix machines. # -# SLICOT, Release 5.0 ./slicot/src/makefile # -# Vasile Sima, KU Leuven # -# October 31, 1996. # -# Revised June 25, 1998. # -# Revised December 7, 1999, September 5, 2003, Jan. 9, 2009. # -#################################################################### -# -# This is the makefile to create/update the library for SLICOT. -# The SLICOT Library routines are written for double precision only. -# -# The command -# make -# without any arguments creates or updates a library called -# slicot.a -# in the next higher directory level. -# -# To remove the object files after the library is created, enter -# make clean -# -# On some systems, you can force the source files to be recompiled by -# entering (for example) -# make double FRC=FRC -# -####################################################################### - -include ../make.inc - -DSLSRC = \ - AB01MD.o AB01ND.o AB01OD.o AB04MD.o AB05MD.o AB05ND.o AB05OD.o \ - AB05PD.o AB05QD.o AB05RD.o AB05SD.o AB07MD.o AB07ND.o AB08MD.o \ - AB08ND.o AB08NX.o AB09AD.o AB09AX.o AB09BD.o AB09BX.o AB09CD.o \ - AB09CX.o AB09DD.o AB09ED.o AB09FD.o AB09GD.o AB09HD.o AB09HX.o \ - AB09HY.o AB09ID.o AB09IX.o AB09IY.o AB09JD.o AB09JV.o AB09JW.o \ - AB09JX.o AB09KD.o AB09KX.o AB09MD.o AB09ND.o AB13AD.o AB13AX.o \ - AB13BD.o AB13CD.o AB13DD.o AB13DX.o AB13ED.o AB13FD.o AB13MD.o \ - AG07BD.o AG08BD.o AG08BY.o \ - BB01AD.o BB02AD.o BB03AD.o BB04AD.o BD01AD.o BD02AD.o \ - DE01OD.o DE01PD.o DF01MD.o DG01MD.o DG01ND.o DG01NY.o DG01OD.o \ - DK01MD.o \ - FB01QD.o FB01RD.o FB01SD.o FB01TD.o FB01VD.o FD01AD.o \ - IB01AD.o IB01BD.o IB01CD.o IB01MD.o IB01MY.o IB01ND.o IB01OD.o \ - IB01OY.o IB01PD.o IB01PX.o IB01PY.o IB01QD.o IB01RD.o \ - IB03AD.o IB03BD.o \ - MA01AD.o MA02AD.o MA02BD.o MA02CD.o MA02DD.o MA02ED.o MA02FD.o \ - MA02GD.o MA02HD.o MB01PD.o MB01QD.o MB01RD.o MB01RU.o MB01RW.o \ - MB01RX.o MB01RY.o MB01SD.o MB01TD.o MB01UD.o MB01UW.o MB01VD.o \ - MB01WD.o MB01XD.o MB01XY.o MB01YD.o MB01ZD.o MB02CD.o MB02CU.o \ - MB02CV.o MB02CX.o MB02CY.o MB02DD.o MB02ED.o MB02FD.o MB02GD.o \ - MB02HD.o MB02ID.o MB02JD.o MB02JX.o MB02KD.o MB02MD.o MB02ND.o \ - MB02NY.o MB02OD.o MB02PD.o MB02QD.o MB02QY.o MB02RD.o MB02RZ.o \ - MB02SD.o MB02SZ.o MB02TD.o MB02TZ.o MB02UD.o MB02UU.o MB02UV.o \ - MB02VD.o MB02WD.o MB02XD.o MB02YD.o \ - MB03MD.o MB03MY.o MB03ND.o MB03NY.o MB03OD.o MB03OY.o \ - MB03PD.o MB03PY.o MB03QD.o MB03QX.o MB03QY.o MB03RD.o MB03RX.o \ - MB03RY.o MB03SD.o MB03UD.o MB03VD.o MB03VY.o MB03WD.o MB03WX.o \ - MB04DY.o MB04GD.o MB04ID.o MB04IY.o MB04JD.o MB04KD.o MB04LD.o \ - MB04MD.o MB04ND.o MB04NY.o MB04OD.o MB04OW.o MB04OX.o MB04OY.o \ - MB04PY.o MB04TT.o MB04TU.o MB04TV.o MB04TW.o MB04TX.o MB04TY.o \ - MB04UD.o MB04VD.o MB04VX.o MB04XD.o MB04XY.o MB04YD.o MB04YW.o \ - MB04ZD.o MB05MD.o MB05MY.o MB05ND.o MB05OD.o MB05OY.o MC01MD.o \ - MC01ND.o MC01OD.o MC01PD.o MC01PY.o MC01QD.o MC01RD.o MC01SD.o \ - MC01SW.o MC01SX.o MC01SY.o MC01TD.o MC01VD.o MC01WD.o MC03MD.o \ - MC03ND.o MC03NX.o MC03NY.o \ - MD03AD.o MD03BA.o MD03BB.o MD03BD.o MD03BF.o MD03BX.o MD03BY.o \ - NF01AD.o NF01AY.o NF01BA.o NF01BB.o NF01BD.o NF01BE.o NF01BF.o \ - NF01BP.o NF01BQ.o NF01BR.o NF01BS.o NF01BU.o NF01BV.o NF01BW.o \ - NF01BX.o NF01BY.o \ - SB01BD.o SB01BX.o SB01BY.o SB01DD.o SB01FY.o SB01MD.o SB02CX.o \ - SB02MD.o SB02MR.o SB02MS.o SB02MT.o SB02MU.o SB02MV.o SB02MW.o \ - SB02ND.o SB02OD.o SB02OU.o SB02OV.o SB02OW.o SB02OX.o SB02OY.o \ - SB02PD.o SB02QD.o SB02RD.o SB02RU.o SB02SD.o SB03MD.o SB03MU.o \ - SB03MV.o SB03MW.o SB03MX.o SB03MY.o SB03OD.o SB03OR.o SB03OT.o \ - SB03OU.o SB03OV.o SB03OY.o SB03PD.o SB03QD.o SB03QX.o SB03QY.o \ - SB03RD.o SB03SD.o SB03SX.o SB03SY.o SB03TD.o SB03UD.o SB04MD.o \ - SB04MR.o SB04MU.o SB04MW.o SB04MY.o SB04ND.o SB04NV.o SB04NW.o \ - SB04NX.o SB04NY.o SB04OD.o SB04PD.o SB04PX.o SB04PY.o SB04QD.o \ - SB04QR.o SB04QU.o SB04QY.o SB04RD.o SB04RV.o SB04RW.o SB04RX.o \ - SB04RY.o SB06ND.o SB08CD.o SB08DD.o SB08ED.o SB08FD.o SB08GD.o \ - SB08HD.o SB08MD.o SB08MY.o SB08ND.o SB08NY.o SB09MD.o SB10AD.o \ - SB10DD.o SB10ED.o SB10FD.o SB10HD.o SB10ID.o SB10JD.o SB10KD.o \ - SB10MD.o SB10LD.o SB10PD.o SB10QD.o SB10RD.o SB10SD.o SB10TD.o \ - SB10UD.o SB10VD.o SB10WD.o SB10YD.o SB10ZD.o SB10ZP.o SB16AD.o \ - SB16AY.o SB16BD.o SB16CD.o SB16CY.o SG02AD.o SG03AD.o SG03AX.o \ - SG03AY.o SG03BD.o SG03BU.o SG03BV.o SG03BW.o SG03BX.o SG03BY.o \ - TB01ID.o TB01KD.o TB01LD.o TB01MD.o TB01ND.o TB01PD.o TB01TD.o \ - TB01TY.o TB01UD.o TB01VD.o TB01VY.o TB01WD.o TB01XD.o TB01YD.o \ - TB01ZD.o TB03AD.o TB03AY.o TB04AD.o TB04AY.o TB04BD.o TB04BV.o \ - TB04BW.o TB04BX.o TB04CD.o TB05AD.o TC01OD.o TC04AD.o TC05AD.o \ - TD03AD.o TD03AY.o TD04AD.o TD05AD.o TF01MD.o TF01MX.o TF01MY.o \ - TF01ND.o TF01OD.o TF01PD.o TF01QD.o TF01RD.o TG01AD.o TG01BD.o \ - TG01CD.o TG01DD.o TG01ED.o TG01FD.o TG01HD.o TG01HX.o TG01ID.o \ - TG01JD.o TG01WD.o \ - UD01BD.o UD01CD.o UD01DD.o UD01MD.o UD01ND.o select.o delctg.o \ - MA02ID.o MA02JD.o MB01MD.o MB01ND.o MB01UX.o MB03TD.o MB03TS.o \ - MB03WA.o MB03XD.o MB03XP.o MB03XU.o MB03YA.o MB03YD.o MB03YT.o \ - MB03ZA.o MB03ZD.o MB04DD.o MB04DI.o MB04DS.o MB04PA.o MB04PB.o \ - MB04PU.o MB04QB.o MB04QC.o MB04QF.o MB04QU.o MB04TB.o MB04TS.o \ - MB04WD.o MB04WP.o MB04WR.o MB04WU.o SB04OW.o UE01MD.o UD01MZ.o \ - AB08MZ.o AB08NZ.o AB8NXZ.o AG08BZ.o AG8BYZ.o MA02BZ.o MA02CZ.o \ - MB04IZ.o MB3OYZ.o MB3PYZ.o TB01IZ.o TB01XZ.o TG01AZ.o TG01FZ.o - -all: double - -double: $(DSLSRC) - $(ARCH) $(ARCHFLAGS) $(SLICOTLIB) $(DSLSRC) - -$(DSLSRC): $(FRC) - -FRC: - @FRC=$(FRC) - -clean: - rm -f *.o - -.f.o: - $(FORTRAN) $(OPTS) -c $< diff --git a/slycot/src/readme b/slycot/src/readme deleted file mode 100644 index 85f5bce3..00000000 --- a/slycot/src/readme +++ /dev/null @@ -1,8 +0,0 @@ -SLICOT Library Subdirectory src -------------------------------- - -SLICOT Library Subdirectory src contains all source files of the -SLICOT Library routines. The codes follow the Fortran 77 language -conventions. SLICOT routines make calls to the state-of-the-art -packages LAPACK (Linear Algebra Package) and BLAS (Basic Linear -Algebra Subprograms). diff --git a/slycot/src/select.f b/slycot/src/select.f deleted file mode 100644 index dd3e62ba..00000000 --- a/slycot/src/select.f +++ /dev/null @@ -1,27 +0,0 @@ - LOGICAL FUNCTION SELECT( PAR1, PAR2 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2009 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C . -C -C Void logical function for DGEES. -C - DOUBLE PRECISION PAR1, PAR2 -C - SELECT = .TRUE. - RETURN - END From 4a0883e7abc2d5a0b94555699f9aebe6b7dde425 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 20:53:23 +0100 Subject: [PATCH 256/405] use SLICOT-reference fork with slycot fixes --- .gitmodules | 2 +- slycot/src/SLICOT-reference | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 9f8e0253..1386908d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "slycot/src/SLICOT-reference"] path = slycot/src/SLICOT-reference - url = https://github.com/SLICOT/SLICOT-reference + url = ../SLICOT-reference diff --git a/slycot/src/SLICOT-reference b/slycot/src/SLICOT-reference index b19fe520..bb4b0253 160000 --- a/slycot/src/SLICOT-reference +++ b/slycot/src/SLICOT-reference @@ -1 +1 @@ -Subproject commit b19fe52072f82d99168511153ae9bd1b586e81f5 +Subproject commit bb4b02538b769b0b0fcc085799b58522d897af48 From d1813f2b43fa46f2a5c959ad1dbcda3567c63b9c Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 21:21:57 +0100 Subject: [PATCH 257/405] add the submodule check back into setup.py --- setup.py | 30 +++++++++++++++++++++++++++++- slycot/src/Readme.md | 2 +- 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/setup.py b/setup.py index be412257..10f5e166 100644 --- a/setup.py +++ b/setup.py @@ -187,7 +187,34 @@ def get_version_info(srcdir=None): return FULLVERSION, GIT_REVISION - +def check_submodules(): + """ verify that the submodules are checked out and clean + use `git submodule update --init`; on failure + """ + if not os.path.exists('.git'): + return + with open('.gitmodules') as f: + for l in f: + if 'path' in l: + p = l.split('=')[-1].strip() + if not os.path.exists(p): + raise ValueError('Submodule %s missing' % p) + + proc = subprocess.Popen(['git', 'submodule', 'status'], + stdout=subprocess.PIPE) + status, _ = proc.communicate() + status = status.decode("ascii", "replace") + for line in status.splitlines(): + if line.startswith('-') or line.startswith('+'): + raise ValueError('Submodule not clean: %s' % line) + + +class sdist_checked(sdist): + """ check submodules on sdist to prevent incomplete tarballs """ + def run(self): + # slycot had no submodules currently + # check_submodules() + sdist.run(self) def setup_package(): src_path = os.path.dirname(os.path.abspath(__file__)) @@ -210,6 +237,7 @@ def setup_package(): license='GPL-2.0', classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], + cmdclass={"sdist": sdist_checked}, cmake_args=['-DSLYCOT_VERSION:STRING=' + VERSION, '-DGIT_REVISION:STRING=' + gitrevision, '-DISRELEASE:STRING=' + str(ISRELEASED), diff --git a/slycot/src/Readme.md b/slycot/src/Readme.md index 5c06279e..a1f3a580 100644 --- a/slycot/src/Readme.md +++ b/slycot/src/Readme.md @@ -3,7 +3,7 @@ Fortran sources This directory contains the f2py wrappers and some helper functions to work with the SLICOT Library routines. SLICOT-reference is a git submodule -referencing [SLICOT-reference](https://github.com/SLICOT/SLICOT-reference) +forked from [SLICOT-reference](https://github.com/SLICOT/SLICOT-reference) plus some backported improvements. The codes follow the Fortran 77 language conventions. SLICOT routines make From 3f35b310289368ba6abdc81ae20c7cfec48d0d57 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 21:22:23 +0100 Subject: [PATCH 258/405] checkout the submodule on workflows --- .github/workflows/slycot-build-and-test.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index ab9f907b..4fc29167 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -21,6 +21,7 @@ jobs: uses: actions/checkout@v2 with: fetch-depth: 0 + submodules: 'recursive' - name: Set up Python uses: actions/setup-python@v2 - name: Setup Ubuntu @@ -71,6 +72,7 @@ jobs: uses: actions/checkout@v2 with: fetch-depth: 0 + submodules: 'recursive' - name: Set up Python uses: actions/setup-python@v2 with: @@ -139,6 +141,7 @@ jobs: uses: actions/checkout@v2 with: fetch-depth: 0 + submodules: 'recursive' - name: Setup Conda uses: conda-incubator/setup-miniconda@v2 with: From d9184eea9040f79b7f8e0482530998600a7ebe57 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 21:53:50 +0100 Subject: [PATCH 259/405] rename to SLICOT-Reference and hardcode path --- .gitmodules | 6 +- MANIFEST.in | 2 +- slycot/CMakeLists.txt | 1186 ++++++++--------- slycot/src/Readme.md | 2 +- .../{SLICOT-reference => SLICOT-Reference} | 0 5 files changed, 598 insertions(+), 598 deletions(-) rename slycot/src/{SLICOT-reference => SLICOT-Reference} (100%) diff --git a/.gitmodules b/.gitmodules index 1386908d..95ba6522 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ -[submodule "slycot/src/SLICOT-reference"] - path = slycot/src/SLICOT-reference - url = ../SLICOT-reference +[submodule "slycot/src/SLICOT-Reference"] + path = slycot/src/SLICOT-Reference + url = https://github.com/bnavigator/SLICOT-Reference diff --git a/MANIFEST.in b/MANIFEST.in index 105f8d8b..8fecc477 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -12,4 +12,4 @@ include slycot/*.py include slycot/version.py.in include slycot/src/*.f include slycot/tests/*.py - +graft slycot/src/SLICOT-Reference diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 91ce0876..2276d8b4 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -6,601 +6,601 @@ # set(SLICOT_FSOURCE -src/SLICOT-reference/src/AB01MD.f -src/SLICOT-reference/src/AB01ND.f -src/SLICOT-reference/src/AB01OD.f -src/SLICOT-reference/src/AB04MD.f -src/SLICOT-reference/src/AB05MD.f -src/SLICOT-reference/src/AB05ND.f -src/SLICOT-reference/src/AB05OD.f -src/SLICOT-reference/src/AB05PD.f -src/SLICOT-reference/src/AB05QD.f -src/SLICOT-reference/src/AB05RD.f -src/SLICOT-reference/src/AB05SD.f -src/SLICOT-reference/src/AB07MD.f -src/SLICOT-reference/src/AB07ND.f -src/SLICOT-reference/src/AB08MD.f -src/SLICOT-reference/src/AB08MZ.f -src/SLICOT-reference/src/AB08ND.f -src/SLICOT-reference/src/AB08NW.f -src/SLICOT-reference/src/AB08NX.f -src/SLICOT-reference/src/AB08NY.f -src/SLICOT-reference/src/AB08NZ.f -src/SLICOT-reference/src/AB09AD.f -src/SLICOT-reference/src/AB09AX.f -src/SLICOT-reference/src/AB09BD.f -src/SLICOT-reference/src/AB09BX.f -src/SLICOT-reference/src/AB09CD.f -src/SLICOT-reference/src/AB09CX.f -src/SLICOT-reference/src/AB09DD.f -src/SLICOT-reference/src/AB09ED.f -src/SLICOT-reference/src/AB09FD.f -src/SLICOT-reference/src/AB09GD.f -src/SLICOT-reference/src/AB09HD.f -src/SLICOT-reference/src/AB09HX.f -src/SLICOT-reference/src/AB09HY.f -src/SLICOT-reference/src/AB09ID.f -src/SLICOT-reference/src/AB09IX.f -src/SLICOT-reference/src/AB09IY.f -src/SLICOT-reference/src/AB09JD.f -src/SLICOT-reference/src/AB09JV.f -src/SLICOT-reference/src/AB09JW.f -src/SLICOT-reference/src/AB09JX.f -src/SLICOT-reference/src/AB09KD.f -src/SLICOT-reference/src/AB09KX.f -src/SLICOT-reference/src/AB09MD.f -src/SLICOT-reference/src/AB09ND.f -src/SLICOT-reference/src/AB13AD.f -src/SLICOT-reference/src/AB13AX.f -src/SLICOT-reference/src/AB13BD.f -src/SLICOT-reference/src/AB13CD.f -src/SLICOT-reference/src/AB13DD.f -src/SLICOT-reference/src/AB13DX.f -src/SLICOT-reference/src/AB13ED.f -src/SLICOT-reference/src/AB13FD.f -src/SLICOT-reference/src/AB13ID.f -src/SLICOT-reference/src/AB13MD.f -src/SLICOT-reference/src/AB8NXZ.f -src/SLICOT-reference/src/AG07BD.f -src/SLICOT-reference/src/AG08BD.f -src/SLICOT-reference/src/AG08BY.f -src/SLICOT-reference/src/AG08BZ.f -src/SLICOT-reference/src/AG8BYZ.f -src/SLICOT-reference/src/BB01AD.f -src/SLICOT-reference/src/BB02AD.f -src/SLICOT-reference/src/BB03AD.f -src/SLICOT-reference/src/BB04AD.f -src/SLICOT-reference/src/BD01AD.f -src/SLICOT-reference/src/BD02AD.f -src/SLICOT-reference/src/DE01OD.f -src/SLICOT-reference/src/DE01PD.f -src/SLICOT-reference/src/DF01MD.f -src/SLICOT-reference/src/DG01MD.f -src/SLICOT-reference/src/DG01ND.f -src/SLICOT-reference/src/DG01NY.f -src/SLICOT-reference/src/DG01OD.f -src/SLICOT-reference/src/DK01MD.f -src/SLICOT-reference/src/FB01QD.f -src/SLICOT-reference/src/FB01RD.f -src/SLICOT-reference/src/FB01SD.f -src/SLICOT-reference/src/FB01TD.f -src/SLICOT-reference/src/FB01VD.f -src/SLICOT-reference/src/FD01AD.f -src/SLICOT-reference/src/IB01AD.f -src/SLICOT-reference/src/IB01BD.f -src/SLICOT-reference/src/IB01CD.f -src/SLICOT-reference/src/IB01MD.f -src/SLICOT-reference/src/IB01MY.f -src/SLICOT-reference/src/IB01ND.f -src/SLICOT-reference/src/IB01OD.f -src/SLICOT-reference/src/IB01OY.f -src/SLICOT-reference/src/IB01PD.f -src/SLICOT-reference/src/IB01PX.f -src/SLICOT-reference/src/IB01PY.f -src/SLICOT-reference/src/IB01QD.f -src/SLICOT-reference/src/IB01RD.f -src/SLICOT-reference/src/IB03AD.f -src/SLICOT-reference/src/IB03BD.f -src/SLICOT-reference/src/MA01AD.f -src/SLICOT-reference/src/MA01BD.f -src/SLICOT-reference/src/MA01BZ.f -src/SLICOT-reference/src/MA01CD.f -src/SLICOT-reference/src/MA02AD.f -src/SLICOT-reference/src/MA02BD.f -src/SLICOT-reference/src/MA02BZ.f -src/SLICOT-reference/src/MA02CD.f -src/SLICOT-reference/src/MA02CZ.f -src/SLICOT-reference/src/MA02DD.f -src/SLICOT-reference/src/MA02ED.f -src/SLICOT-reference/src/MA02ES.f -src/SLICOT-reference/src/MA02EZ.f -src/SLICOT-reference/src/MA02FD.f -src/SLICOT-reference/src/MA02GD.f -src/SLICOT-reference/src/MA02GZ.f -src/SLICOT-reference/src/MA02HD.f -src/SLICOT-reference/src/MA02HZ.f -src/SLICOT-reference/src/MA02ID.f -src/SLICOT-reference/src/MA02IZ.f -src/SLICOT-reference/src/MA02JD.f -src/SLICOT-reference/src/MA02JZ.f -src/SLICOT-reference/src/MA02MD.f -src/SLICOT-reference/src/MA02MZ.f -src/SLICOT-reference/src/MA02NZ.f -src/SLICOT-reference/src/MA02OD.f -src/SLICOT-reference/src/MA02OZ.f -src/SLICOT-reference/src/MA02PD.f -src/SLICOT-reference/src/MA02PZ.f -src/SLICOT-reference/src/MB01KD.f -src/SLICOT-reference/src/MB01LD.f -src/SLICOT-reference/src/MB01MD.f -src/SLICOT-reference/src/MB01ND.f -src/SLICOT-reference/src/MB01OC.f -src/SLICOT-reference/src/MB01OD.f -src/SLICOT-reference/src/MB01OE.f -src/SLICOT-reference/src/MB01OH.f -src/SLICOT-reference/src/MB01OO.f -src/SLICOT-reference/src/MB01OS.f -src/SLICOT-reference/src/MB01OT.f -src/SLICOT-reference/src/MB01PD.f -src/SLICOT-reference/src/MB01QD.f -src/SLICOT-reference/src/MB01RB.f -src/SLICOT-reference/src/MB01RD.f -src/SLICOT-reference/src/MB01RH.f -src/SLICOT-reference/src/MB01RT.f -src/SLICOT-reference/src/MB01RU.f -src/SLICOT-reference/src/MB01RW.f -src/SLICOT-reference/src/MB01RX.f -src/SLICOT-reference/src/MB01RY.f -src/SLICOT-reference/src/MB01SD.f -src/SLICOT-reference/src/MB01SS.f -src/SLICOT-reference/src/MB01TD.f -src/SLICOT-reference/src/MB01UD.f -src/SLICOT-reference/src/MB01UW.f -src/SLICOT-reference/src/MB01UX.f -src/SLICOT-reference/src/MB01VD.f -src/SLICOT-reference/src/MB01WD.f -src/SLICOT-reference/src/MB01XD.f -src/SLICOT-reference/src/MB01XY.f -src/SLICOT-reference/src/MB01YD.f -src/SLICOT-reference/src/MB01ZD.f -src/SLICOT-reference/src/MB02CD.f -src/SLICOT-reference/src/MB02CU.f -src/SLICOT-reference/src/MB02CV.f -src/SLICOT-reference/src/MB02CX.f -src/SLICOT-reference/src/MB02CY.f -src/SLICOT-reference/src/MB02DD.f -src/SLICOT-reference/src/MB02ED.f -src/SLICOT-reference/src/MB02FD.f -src/SLICOT-reference/src/MB02GD.f -src/SLICOT-reference/src/MB02HD.f -src/SLICOT-reference/src/MB02ID.f -src/SLICOT-reference/src/MB02JD.f -src/SLICOT-reference/src/MB02JX.f -src/SLICOT-reference/src/MB02KD.f -src/SLICOT-reference/src/MB02MD.f -src/SLICOT-reference/src/MB02ND.f -src/SLICOT-reference/src/MB02NY.f -src/SLICOT-reference/src/MB02OD.f -src/SLICOT-reference/src/MB02PD.f -src/SLICOT-reference/src/MB02QD.f -src/SLICOT-reference/src/MB02QY.f -src/SLICOT-reference/src/MB02RD.f -src/SLICOT-reference/src/MB02RZ.f -src/SLICOT-reference/src/MB02SD.f -src/SLICOT-reference/src/MB02SZ.f -src/SLICOT-reference/src/MB02TD.f -src/SLICOT-reference/src/MB02TZ.f -src/SLICOT-reference/src/MB02UD.f -src/SLICOT-reference/src/MB02UU.f -src/SLICOT-reference/src/MB02UV.f -src/SLICOT-reference/src/MB02UW.f -src/SLICOT-reference/src/MB02VD.f -src/SLICOT-reference/src/MB02WD.f -src/SLICOT-reference/src/MB02XD.f -src/SLICOT-reference/src/MB02YD.f -src/SLICOT-reference/src/MB03AB.f -src/SLICOT-reference/src/MB03AD.f -src/SLICOT-reference/src/MB03AE.f -src/SLICOT-reference/src/MB03AF.f -src/SLICOT-reference/src/MB03AG.f -src/SLICOT-reference/src/MB03AH.f -src/SLICOT-reference/src/MB03AI.f -src/SLICOT-reference/src/MB03BA.f -src/SLICOT-reference/src/MB03BB.f -src/SLICOT-reference/src/MB03BC.f -src/SLICOT-reference/src/MB03BD.f -src/SLICOT-reference/src/MB03BE.f -src/SLICOT-reference/src/MB03BF.f -src/SLICOT-reference/src/MB03BG.f -src/SLICOT-reference/src/MB03BZ.f -src/SLICOT-reference/src/MB03CD.f -src/SLICOT-reference/src/MB03CZ.f -src/SLICOT-reference/src/MB03DD.f -src/SLICOT-reference/src/MB03DZ.f -src/SLICOT-reference/src/MB03ED.f -src/SLICOT-reference/src/MB03FD.f -src/SLICOT-reference/src/MB03FZ.f -src/SLICOT-reference/src/MB03GD.f -src/SLICOT-reference/src/MB03GZ.f -src/SLICOT-reference/src/MB03HD.f -src/SLICOT-reference/src/MB03HZ.f -src/SLICOT-reference/src/MB03ID.f -src/SLICOT-reference/src/MB03IZ.f -src/SLICOT-reference/src/MB03JD.f -src/SLICOT-reference/src/MB03JP.f -src/SLICOT-reference/src/MB03JZ.f -src/SLICOT-reference/src/MB03KA.f -src/SLICOT-reference/src/MB03KB.f -src/SLICOT-reference/src/MB03KC.f -src/SLICOT-reference/src/MB03KD.f -src/SLICOT-reference/src/MB03KE.f -src/SLICOT-reference/src/MB03LD.f -src/SLICOT-reference/src/MB03LF.f -src/SLICOT-reference/src/MB03LP.f -src/SLICOT-reference/src/MB03LZ.f -src/SLICOT-reference/src/MB03MD.f -src/SLICOT-reference/src/MB03MY.f -src/SLICOT-reference/src/MB03ND.f -src/SLICOT-reference/src/MB03NY.f -src/SLICOT-reference/src/MB03OD.f -src/SLICOT-reference/src/MB03OY.f -src/SLICOT-reference/src/MB03PD.f -src/SLICOT-reference/src/MB03PY.f -src/SLICOT-reference/src/MB03QD.f -src/SLICOT-reference/src/MB03QG.f -src/SLICOT-reference/src/MB03QV.f -src/SLICOT-reference/src/MB03QW.f -src/SLICOT-reference/src/MB03QX.f -src/SLICOT-reference/src/MB03QY.f -src/SLICOT-reference/src/MB03RD.f -src/SLICOT-reference/src/MB03RX.f -src/SLICOT-reference/src/MB03RY.f -src/SLICOT-reference/src/MB03SD.f -src/SLICOT-reference/src/MB03TD.f -src/SLICOT-reference/src/MB03TS.f -src/SLICOT-reference/src/MB03UD.f -src/SLICOT-reference/src/MB03VD.f -src/SLICOT-reference/src/MB03VY.f -src/SLICOT-reference/src/MB03WA.f -src/SLICOT-reference/src/MB03WD.f -src/SLICOT-reference/src/MB03WX.f -src/SLICOT-reference/src/MB03XD.f -src/SLICOT-reference/src/MB03XP.f -src/SLICOT-reference/src/MB03XS.f -src/SLICOT-reference/src/MB03XU.f -src/SLICOT-reference/src/MB03XZ.f -src/SLICOT-reference/src/MB03YA.f -src/SLICOT-reference/src/MB03YD.f -src/SLICOT-reference/src/MB03YT.f -src/SLICOT-reference/src/MB03ZA.f -src/SLICOT-reference/src/MB03ZD.f -src/SLICOT-reference/src/MB04AD.f -src/SLICOT-reference/src/MB04AZ.f -src/SLICOT-reference/src/MB04BD.f -src/SLICOT-reference/src/MB04BP.f -src/SLICOT-reference/src/MB04BZ.f -src/SLICOT-reference/src/MB04CD.f -src/SLICOT-reference/src/MB04DB.f -src/SLICOT-reference/src/MB04DD.f -src/SLICOT-reference/src/MB04DI.f -src/SLICOT-reference/src/MB04DL.f -src/SLICOT-reference/src/MB04DP.f -src/SLICOT-reference/src/MB04DS.f -src/SLICOT-reference/src/MB04DY.f -src/SLICOT-reference/src/MB04DZ.f -src/SLICOT-reference/src/MB04ED.f -src/SLICOT-reference/src/MB04FD.f -src/SLICOT-reference/src/MB04FP.f -src/SLICOT-reference/src/MB04GD.f -src/SLICOT-reference/src/MB04HD.f -src/SLICOT-reference/src/MB04ID.f -src/SLICOT-reference/src/MB04IY.f -src/SLICOT-reference/src/MB04IZ.f -src/SLICOT-reference/src/MB04JD.f -src/SLICOT-reference/src/MB04KD.f -src/SLICOT-reference/src/MB04LD.f -src/SLICOT-reference/src/MB04MD.f -src/SLICOT-reference/src/MB04ND.f -src/SLICOT-reference/src/MB04NY.f -src/SLICOT-reference/src/MB04OD.f -src/SLICOT-reference/src/MB04OW.f -src/SLICOT-reference/src/MB04OX.f -src/SLICOT-reference/src/MB04OY.f -src/SLICOT-reference/src/MB04PA.f -src/SLICOT-reference/src/MB04PB.f -src/SLICOT-reference/src/MB04PU.f -src/SLICOT-reference/src/MB04PY.f -src/SLICOT-reference/src/MB04QB.f -src/SLICOT-reference/src/MB04QC.f -src/SLICOT-reference/src/MB04QF.f -src/SLICOT-reference/src/MB04QS.f -src/SLICOT-reference/src/MB04QU.f -src/SLICOT-reference/src/MB04RB.f -src/SLICOT-reference/src/MB04RU.f -src/SLICOT-reference/src/MB04SU.f -src/SLICOT-reference/src/MB04TB.f -src/SLICOT-reference/src/MB04TS.f -src/SLICOT-reference/src/MB04TT.f -src/SLICOT-reference/src/MB04TU.f -src/SLICOT-reference/src/MB04TV.f -src/SLICOT-reference/src/MB04TW.f -src/SLICOT-reference/src/MB04TX.f -src/SLICOT-reference/src/MB04TY.f -src/SLICOT-reference/src/MB04UD.f -src/SLICOT-reference/src/MB04VD.f -src/SLICOT-reference/src/MB04VX.f -src/SLICOT-reference/src/MB04WD.f -src/SLICOT-reference/src/MB04WP.f -src/SLICOT-reference/src/MB04WR.f -src/SLICOT-reference/src/MB04WU.f -src/SLICOT-reference/src/MB04XD.f -src/SLICOT-reference/src/MB04XY.f -src/SLICOT-reference/src/MB04YD.f -src/SLICOT-reference/src/MB04YW.f -src/SLICOT-reference/src/MB04ZD.f -src/SLICOT-reference/src/MB05MD.f -src/SLICOT-reference/src/MB05MY.f -src/SLICOT-reference/src/MB05ND.f -src/SLICOT-reference/src/MB05OD.f -src/SLICOT-reference/src/MB05OY.f -src/SLICOT-reference/src/MB3JZP.f -src/SLICOT-reference/src/MB3LZP.f -src/SLICOT-reference/src/MB3OYZ.f -src/SLICOT-reference/src/MB3PYZ.f -src/SLICOT-reference/src/MB4DBZ.f -src/SLICOT-reference/src/MB4DLZ.f -src/SLICOT-reference/src/MB4DPZ.f -src/SLICOT-reference/src/MC01MD.f -src/SLICOT-reference/src/MC01ND.f -src/SLICOT-reference/src/MC01OD.f -src/SLICOT-reference/src/MC01PD.f -src/SLICOT-reference/src/MC01PY.f -src/SLICOT-reference/src/MC01QD.f -src/SLICOT-reference/src/MC01RD.f -src/SLICOT-reference/src/MC01SD.f -src/SLICOT-reference/src/MC01SW.f -src/SLICOT-reference/src/MC01SX.f -src/SLICOT-reference/src/MC01SY.f -src/SLICOT-reference/src/MC01TD.f -src/SLICOT-reference/src/MC01VD.f -src/SLICOT-reference/src/MC01WD.f -src/SLICOT-reference/src/MC01XD.f -src/SLICOT-reference/src/MC03MD.f -src/SLICOT-reference/src/MC03ND.f -src/SLICOT-reference/src/MC03NX.f -src/SLICOT-reference/src/MC03NY.f -src/SLICOT-reference/src/MD03AD.f -src/SLICOT-reference/src/MD03BA.f -src/SLICOT-reference/src/MD03BB.f -src/SLICOT-reference/src/MD03BD.f -src/SLICOT-reference/src/MD03BF.f -src/SLICOT-reference/src/MD03BX.f -src/SLICOT-reference/src/MD03BY.f -src/SLICOT-reference/src/NF01AD.f -src/SLICOT-reference/src/NF01AY.f -src/SLICOT-reference/src/NF01BA.f -src/SLICOT-reference/src/NF01BB.f -src/SLICOT-reference/src/NF01BD.f -src/SLICOT-reference/src/NF01BE.f -src/SLICOT-reference/src/NF01BF.f -src/SLICOT-reference/src/NF01BP.f -src/SLICOT-reference/src/NF01BQ.f -src/SLICOT-reference/src/NF01BR.f -src/SLICOT-reference/src/NF01BS.f -src/SLICOT-reference/src/NF01BU.f -src/SLICOT-reference/src/NF01BV.f -src/SLICOT-reference/src/NF01BW.f -src/SLICOT-reference/src/NF01BX.f -src/SLICOT-reference/src/NF01BY.f -src/SLICOT-reference/src/SB01BD.f -src/SLICOT-reference/src/SB01BX.f -src/SLICOT-reference/src/SB01BY.f -src/SLICOT-reference/src/SB01DD.f -src/SLICOT-reference/src/SB01FY.f -src/SLICOT-reference/src/SB01MD.f -src/SLICOT-reference/src/SB02CX.f -src/SLICOT-reference/src/SB02MD.f -src/SLICOT-reference/src/SB02MR.f -src/SLICOT-reference/src/SB02MS.f -src/SLICOT-reference/src/SB02MT.f -src/SLICOT-reference/src/SB02MU.f -src/SLICOT-reference/src/SB02MV.f -src/SLICOT-reference/src/SB02MW.f -src/SLICOT-reference/src/SB02MX.f -src/SLICOT-reference/src/SB02ND.f -src/SLICOT-reference/src/SB02OD.f -src/SLICOT-reference/src/SB02OU.f -src/SLICOT-reference/src/SB02OV.f -src/SLICOT-reference/src/SB02OW.f -src/SLICOT-reference/src/SB02OX.f -src/SLICOT-reference/src/SB02OY.f -src/SLICOT-reference/src/SB02PD.f -src/SLICOT-reference/src/SB02QD.f -src/SLICOT-reference/src/SB02RD.f -src/SLICOT-reference/src/SB02RU.f -src/SLICOT-reference/src/SB02SD.f -src/SLICOT-reference/src/SB03MD.f -src/SLICOT-reference/src/SB03MU.f -src/SLICOT-reference/src/SB03MV.f -src/SLICOT-reference/src/SB03MW.f -src/SLICOT-reference/src/SB03MX.f -src/SLICOT-reference/src/SB03MY.f -src/SLICOT-reference/src/SB03OD.f -src/SLICOT-reference/src/SB03OR.f -src/SLICOT-reference/src/SB03OT.f -src/SLICOT-reference/src/SB03OU.f -src/SLICOT-reference/src/SB03OV.f -src/SLICOT-reference/src/SB03OY.f -src/SLICOT-reference/src/SB03PD.f -src/SLICOT-reference/src/SB03QD.f -src/SLICOT-reference/src/SB03QX.f -src/SLICOT-reference/src/SB03QY.f -src/SLICOT-reference/src/SB03RD.f -src/SLICOT-reference/src/SB03SD.f -src/SLICOT-reference/src/SB03SX.f -src/SLICOT-reference/src/SB03SY.f -src/SLICOT-reference/src/SB03TD.f -src/SLICOT-reference/src/SB03UD.f -src/SLICOT-reference/src/SB04MD.f -src/SLICOT-reference/src/SB04MR.f -src/SLICOT-reference/src/SB04MU.f -src/SLICOT-reference/src/SB04MW.f -src/SLICOT-reference/src/SB04MY.f -src/SLICOT-reference/src/SB04ND.f -src/SLICOT-reference/src/SB04NV.f -src/SLICOT-reference/src/SB04NW.f -src/SLICOT-reference/src/SB04NX.f -src/SLICOT-reference/src/SB04NY.f -src/SLICOT-reference/src/SB04OD.f -src/SLICOT-reference/src/SB04OW.f -src/SLICOT-reference/src/SB04PD.f -src/SLICOT-reference/src/SB04PX.f -src/SLICOT-reference/src/SB04PY.f -src/SLICOT-reference/src/SB04QD.f -src/SLICOT-reference/src/SB04QR.f -src/SLICOT-reference/src/SB04QU.f -src/SLICOT-reference/src/SB04QY.f -src/SLICOT-reference/src/SB04RD.f -src/SLICOT-reference/src/SB04RV.f -src/SLICOT-reference/src/SB04RW.f -src/SLICOT-reference/src/SB04RX.f -src/SLICOT-reference/src/SB04RY.f -src/SLICOT-reference/src/SB06ND.f -src/SLICOT-reference/src/SB08CD.f -src/SLICOT-reference/src/SB08DD.f -src/SLICOT-reference/src/SB08ED.f -src/SLICOT-reference/src/SB08FD.f -src/SLICOT-reference/src/SB08GD.f -src/SLICOT-reference/src/SB08HD.f -src/SLICOT-reference/src/SB08MD.f -src/SLICOT-reference/src/SB08MY.f -src/SLICOT-reference/src/SB08ND.f -src/SLICOT-reference/src/SB08NY.f -src/SLICOT-reference/src/SB09MD.f -src/SLICOT-reference/src/SB10AD.f -src/SLICOT-reference/src/SB10DD.f -src/SLICOT-reference/src/SB10ED.f -src/SLICOT-reference/src/SB10FD.f -src/SLICOT-reference/src/SB10HD.f -src/SLICOT-reference/src/SB10ID.f -src/SLICOT-reference/src/SB10JD.f -src/SLICOT-reference/src/SB10KD.f -src/SLICOT-reference/src/SB10LD.f -src/SLICOT-reference/src/SB10MD.f -src/SLICOT-reference/src/SB10PD.f -src/SLICOT-reference/src/SB10QD.f -src/SLICOT-reference/src/SB10RD.f -src/SLICOT-reference/src/SB10SD.f -src/SLICOT-reference/src/SB10TD.f -src/SLICOT-reference/src/SB10UD.f -src/SLICOT-reference/src/SB10VD.f -src/SLICOT-reference/src/SB10WD.f -src/SLICOT-reference/src/SB10YD.f -src/SLICOT-reference/src/SB10ZD.f -src/SLICOT-reference/src/SB10ZP.f -src/SLICOT-reference/src/SB16AD.f -src/SLICOT-reference/src/SB16AY.f -src/SLICOT-reference/src/SB16BD.f -src/SLICOT-reference/src/SB16CD.f -src/SLICOT-reference/src/SB16CY.f -src/SLICOT-reference/src/SG02AD.f -src/SLICOT-reference/src/SG02CV.f -src/SLICOT-reference/src/SG02CW.f -src/SLICOT-reference/src/SG02CX.f -src/SLICOT-reference/src/SG02ND.f -src/SLICOT-reference/src/SG03AD.f -src/SLICOT-reference/src/SG03AX.f -src/SLICOT-reference/src/SG03AY.f -src/SLICOT-reference/src/SG03BD.f -src/SLICOT-reference/src/SG03BU.f -src/SLICOT-reference/src/SG03BV.f -src/SLICOT-reference/src/SG03BW.f -src/SLICOT-reference/src/SG03BX.f -src/SLICOT-reference/src/SG03BY.f -src/SLICOT-reference/src/TB01ID.f -src/SLICOT-reference/src/TB01IZ.f -src/SLICOT-reference/src/TB01KD.f -src/SLICOT-reference/src/TB01KX.f -src/SLICOT-reference/src/TB01LD.f -src/SLICOT-reference/src/TB01MD.f -src/SLICOT-reference/src/TB01ND.f -src/SLICOT-reference/src/TB01PD.f -src/SLICOT-reference/src/TB01PX.f -src/SLICOT-reference/src/TB01TD.f -src/SLICOT-reference/src/TB01TY.f -src/SLICOT-reference/src/TB01UD.f -src/SLICOT-reference/src/TB01UX.f -src/SLICOT-reference/src/TB01UY.f -src/SLICOT-reference/src/TB01VD.f -src/SLICOT-reference/src/TB01VY.f -src/SLICOT-reference/src/TB01WD.f -src/SLICOT-reference/src/TB01WX.f -src/SLICOT-reference/src/TB01XD.f -src/SLICOT-reference/src/TB01XZ.f -src/SLICOT-reference/src/TB01YD.f -src/SLICOT-reference/src/TB01ZD.f -src/SLICOT-reference/src/TB03AD.f -src/SLICOT-reference/src/TB03AY.f -src/SLICOT-reference/src/TB04AD.f -src/SLICOT-reference/src/TB04AY.f -src/SLICOT-reference/src/TB04BD.f -src/SLICOT-reference/src/TB04BV.f -src/SLICOT-reference/src/TB04BW.f -src/SLICOT-reference/src/TB04BX.f -src/SLICOT-reference/src/TB04CD.f -src/SLICOT-reference/src/TB05AD.f -src/SLICOT-reference/src/TC01OD.f -src/SLICOT-reference/src/TC04AD.f -src/SLICOT-reference/src/TC05AD.f -src/SLICOT-reference/src/TD03AD.f -src/SLICOT-reference/src/TD03AY.f -src/SLICOT-reference/src/TD04AD.f -src/SLICOT-reference/src/TD05AD.f -src/SLICOT-reference/src/TF01MD.f -src/SLICOT-reference/src/TF01MX.f -src/SLICOT-reference/src/TF01MY.f -src/SLICOT-reference/src/TF01ND.f -src/SLICOT-reference/src/TF01OD.f -src/SLICOT-reference/src/TF01PD.f -src/SLICOT-reference/src/TF01QD.f -src/SLICOT-reference/src/TF01RD.f -src/SLICOT-reference/src/TG01AD.f -src/SLICOT-reference/src/TG01AZ.f -src/SLICOT-reference/src/TG01BD.f -src/SLICOT-reference/src/TG01CD.f -src/SLICOT-reference/src/TG01DD.f -src/SLICOT-reference/src/TG01ED.f -src/SLICOT-reference/src/TG01FD.f -src/SLICOT-reference/src/TG01FZ.f -src/SLICOT-reference/src/TG01GD.f -src/SLICOT-reference/src/TG01HD.f -src/SLICOT-reference/src/TG01HU.f -src/SLICOT-reference/src/TG01HX.f -src/SLICOT-reference/src/TG01HY.f -src/SLICOT-reference/src/TG01ID.f -src/SLICOT-reference/src/TG01JD.f -src/SLICOT-reference/src/TG01JY.f -src/SLICOT-reference/src/TG01LD.f -src/SLICOT-reference/src/TG01LY.f -src/SLICOT-reference/src/TG01MD.f -src/SLICOT-reference/src/TG01ND.f -src/SLICOT-reference/src/TG01NX.f -src/SLICOT-reference/src/TG01PD.f -src/SLICOT-reference/src/TG01QD.f -src/SLICOT-reference/src/TG01WD.f -src/SLICOT-reference/src/UD01BD.f -src/SLICOT-reference/src/UD01CD.f -src/SLICOT-reference/src/UD01DD.f -src/SLICOT-reference/src/UD01MD.f -src/SLICOT-reference/src/UD01MZ.f -src/SLICOT-reference/src/UD01ND.f -src/SLICOT-reference/src/UE01MD.f +src/SLICOT-Reference/src/AB01MD.f +src/SLICOT-Reference/src/AB01ND.f +src/SLICOT-Reference/src/AB01OD.f +src/SLICOT-Reference/src/AB04MD.f +src/SLICOT-Reference/src/AB05MD.f +src/SLICOT-Reference/src/AB05ND.f +src/SLICOT-Reference/src/AB05OD.f +src/SLICOT-Reference/src/AB05PD.f +src/SLICOT-Reference/src/AB05QD.f +src/SLICOT-Reference/src/AB05RD.f +src/SLICOT-Reference/src/AB05SD.f +src/SLICOT-Reference/src/AB07MD.f +src/SLICOT-Reference/src/AB07ND.f +src/SLICOT-Reference/src/AB08MD.f +src/SLICOT-Reference/src/AB08MZ.f +src/SLICOT-Reference/src/AB08ND.f +src/SLICOT-Reference/src/AB08NW.f +src/SLICOT-Reference/src/AB08NX.f +src/SLICOT-Reference/src/AB08NY.f +src/SLICOT-Reference/src/AB08NZ.f +src/SLICOT-Reference/src/AB09AD.f +src/SLICOT-Reference/src/AB09AX.f +src/SLICOT-Reference/src/AB09BD.f +src/SLICOT-Reference/src/AB09BX.f +src/SLICOT-Reference/src/AB09CD.f +src/SLICOT-Reference/src/AB09CX.f +src/SLICOT-Reference/src/AB09DD.f +src/SLICOT-Reference/src/AB09ED.f +src/SLICOT-Reference/src/AB09FD.f +src/SLICOT-Reference/src/AB09GD.f +src/SLICOT-Reference/src/AB09HD.f +src/SLICOT-Reference/src/AB09HX.f +src/SLICOT-Reference/src/AB09HY.f +src/SLICOT-Reference/src/AB09ID.f +src/SLICOT-Reference/src/AB09IX.f +src/SLICOT-Reference/src/AB09IY.f +src/SLICOT-Reference/src/AB09JD.f +src/SLICOT-Reference/src/AB09JV.f +src/SLICOT-Reference/src/AB09JW.f +src/SLICOT-Reference/src/AB09JX.f +src/SLICOT-Reference/src/AB09KD.f +src/SLICOT-Reference/src/AB09KX.f +src/SLICOT-Reference/src/AB09MD.f +src/SLICOT-Reference/src/AB09ND.f +src/SLICOT-Reference/src/AB13AD.f +src/SLICOT-Reference/src/AB13AX.f +src/SLICOT-Reference/src/AB13BD.f +src/SLICOT-Reference/src/AB13CD.f +src/SLICOT-Reference/src/AB13DD.f +src/SLICOT-Reference/src/AB13DX.f +src/SLICOT-Reference/src/AB13ED.f +src/SLICOT-Reference/src/AB13FD.f +src/SLICOT-Reference/src/AB13ID.f +src/SLICOT-Reference/src/AB13MD.f +src/SLICOT-Reference/src/AB8NXZ.f +src/SLICOT-Reference/src/AG07BD.f +src/SLICOT-Reference/src/AG08BD.f +src/SLICOT-Reference/src/AG08BY.f +src/SLICOT-Reference/src/AG08BZ.f +src/SLICOT-Reference/src/AG8BYZ.f +src/SLICOT-Reference/src/BB01AD.f +src/SLICOT-Reference/src/BB02AD.f +src/SLICOT-Reference/src/BB03AD.f +src/SLICOT-Reference/src/BB04AD.f +src/SLICOT-Reference/src/BD01AD.f +src/SLICOT-Reference/src/BD02AD.f +src/SLICOT-Reference/src/DE01OD.f +src/SLICOT-Reference/src/DE01PD.f +src/SLICOT-Reference/src/DF01MD.f +src/SLICOT-Reference/src/DG01MD.f +src/SLICOT-Reference/src/DG01ND.f +src/SLICOT-Reference/src/DG01NY.f +src/SLICOT-Reference/src/DG01OD.f +src/SLICOT-Reference/src/DK01MD.f +src/SLICOT-Reference/src/FB01QD.f +src/SLICOT-Reference/src/FB01RD.f +src/SLICOT-Reference/src/FB01SD.f +src/SLICOT-Reference/src/FB01TD.f +src/SLICOT-Reference/src/FB01VD.f +src/SLICOT-Reference/src/FD01AD.f +src/SLICOT-Reference/src/IB01AD.f +src/SLICOT-Reference/src/IB01BD.f +src/SLICOT-Reference/src/IB01CD.f +src/SLICOT-Reference/src/IB01MD.f +src/SLICOT-Reference/src/IB01MY.f +src/SLICOT-Reference/src/IB01ND.f +src/SLICOT-Reference/src/IB01OD.f +src/SLICOT-Reference/src/IB01OY.f +src/SLICOT-Reference/src/IB01PD.f +src/SLICOT-Reference/src/IB01PX.f +src/SLICOT-Reference/src/IB01PY.f +src/SLICOT-Reference/src/IB01QD.f +src/SLICOT-Reference/src/IB01RD.f +src/SLICOT-Reference/src/IB03AD.f +src/SLICOT-Reference/src/IB03BD.f +src/SLICOT-Reference/src/MA01AD.f +src/SLICOT-Reference/src/MA01BD.f +src/SLICOT-Reference/src/MA01BZ.f +src/SLICOT-Reference/src/MA01CD.f +src/SLICOT-Reference/src/MA02AD.f +src/SLICOT-Reference/src/MA02BD.f +src/SLICOT-Reference/src/MA02BZ.f +src/SLICOT-Reference/src/MA02CD.f +src/SLICOT-Reference/src/MA02CZ.f +src/SLICOT-Reference/src/MA02DD.f +src/SLICOT-Reference/src/MA02ED.f +src/SLICOT-Reference/src/MA02ES.f +src/SLICOT-Reference/src/MA02EZ.f +src/SLICOT-Reference/src/MA02FD.f +src/SLICOT-Reference/src/MA02GD.f +src/SLICOT-Reference/src/MA02GZ.f +src/SLICOT-Reference/src/MA02HD.f +src/SLICOT-Reference/src/MA02HZ.f +src/SLICOT-Reference/src/MA02ID.f +src/SLICOT-Reference/src/MA02IZ.f +src/SLICOT-Reference/src/MA02JD.f +src/SLICOT-Reference/src/MA02JZ.f +src/SLICOT-Reference/src/MA02MD.f +src/SLICOT-Reference/src/MA02MZ.f +src/SLICOT-Reference/src/MA02NZ.f +src/SLICOT-Reference/src/MA02OD.f +src/SLICOT-Reference/src/MA02OZ.f +src/SLICOT-Reference/src/MA02PD.f +src/SLICOT-Reference/src/MA02PZ.f +src/SLICOT-Reference/src/MB01KD.f +src/SLICOT-Reference/src/MB01LD.f +src/SLICOT-Reference/src/MB01MD.f +src/SLICOT-Reference/src/MB01ND.f +src/SLICOT-Reference/src/MB01OC.f +src/SLICOT-Reference/src/MB01OD.f +src/SLICOT-Reference/src/MB01OE.f +src/SLICOT-Reference/src/MB01OH.f +src/SLICOT-Reference/src/MB01OO.f +src/SLICOT-Reference/src/MB01OS.f +src/SLICOT-Reference/src/MB01OT.f +src/SLICOT-Reference/src/MB01PD.f +src/SLICOT-Reference/src/MB01QD.f +src/SLICOT-Reference/src/MB01RB.f +src/SLICOT-Reference/src/MB01RD.f +src/SLICOT-Reference/src/MB01RH.f +src/SLICOT-Reference/src/MB01RT.f +src/SLICOT-Reference/src/MB01RU.f +src/SLICOT-Reference/src/MB01RW.f +src/SLICOT-Reference/src/MB01RX.f +src/SLICOT-Reference/src/MB01RY.f +src/SLICOT-Reference/src/MB01SD.f +src/SLICOT-Reference/src/MB01SS.f +src/SLICOT-Reference/src/MB01TD.f +src/SLICOT-Reference/src/MB01UD.f +src/SLICOT-Reference/src/MB01UW.f +src/SLICOT-Reference/src/MB01UX.f +src/SLICOT-Reference/src/MB01VD.f +src/SLICOT-Reference/src/MB01WD.f +src/SLICOT-Reference/src/MB01XD.f +src/SLICOT-Reference/src/MB01XY.f +src/SLICOT-Reference/src/MB01YD.f +src/SLICOT-Reference/src/MB01ZD.f +src/SLICOT-Reference/src/MB02CD.f +src/SLICOT-Reference/src/MB02CU.f +src/SLICOT-Reference/src/MB02CV.f +src/SLICOT-Reference/src/MB02CX.f +src/SLICOT-Reference/src/MB02CY.f +src/SLICOT-Reference/src/MB02DD.f +src/SLICOT-Reference/src/MB02ED.f +src/SLICOT-Reference/src/MB02FD.f +src/SLICOT-Reference/src/MB02GD.f +src/SLICOT-Reference/src/MB02HD.f +src/SLICOT-Reference/src/MB02ID.f +src/SLICOT-Reference/src/MB02JD.f +src/SLICOT-Reference/src/MB02JX.f +src/SLICOT-Reference/src/MB02KD.f +src/SLICOT-Reference/src/MB02MD.f +src/SLICOT-Reference/src/MB02ND.f +src/SLICOT-Reference/src/MB02NY.f +src/SLICOT-Reference/src/MB02OD.f +src/SLICOT-Reference/src/MB02PD.f +src/SLICOT-Reference/src/MB02QD.f +src/SLICOT-Reference/src/MB02QY.f +src/SLICOT-Reference/src/MB02RD.f +src/SLICOT-Reference/src/MB02RZ.f +src/SLICOT-Reference/src/MB02SD.f +src/SLICOT-Reference/src/MB02SZ.f +src/SLICOT-Reference/src/MB02TD.f +src/SLICOT-Reference/src/MB02TZ.f +src/SLICOT-Reference/src/MB02UD.f +src/SLICOT-Reference/src/MB02UU.f +src/SLICOT-Reference/src/MB02UV.f +src/SLICOT-Reference/src/MB02UW.f +src/SLICOT-Reference/src/MB02VD.f +src/SLICOT-Reference/src/MB02WD.f +src/SLICOT-Reference/src/MB02XD.f +src/SLICOT-Reference/src/MB02YD.f +src/SLICOT-Reference/src/MB03AB.f +src/SLICOT-Reference/src/MB03AD.f +src/SLICOT-Reference/src/MB03AE.f +src/SLICOT-Reference/src/MB03AF.f +src/SLICOT-Reference/src/MB03AG.f +src/SLICOT-Reference/src/MB03AH.f +src/SLICOT-Reference/src/MB03AI.f +src/SLICOT-Reference/src/MB03BA.f +src/SLICOT-Reference/src/MB03BB.f +src/SLICOT-Reference/src/MB03BC.f +src/SLICOT-Reference/src/MB03BD.f +src/SLICOT-Reference/src/MB03BE.f +src/SLICOT-Reference/src/MB03BF.f +src/SLICOT-Reference/src/MB03BG.f +src/SLICOT-Reference/src/MB03BZ.f +src/SLICOT-Reference/src/MB03CD.f +src/SLICOT-Reference/src/MB03CZ.f +src/SLICOT-Reference/src/MB03DD.f +src/SLICOT-Reference/src/MB03DZ.f +src/SLICOT-Reference/src/MB03ED.f +src/SLICOT-Reference/src/MB03FD.f +src/SLICOT-Reference/src/MB03FZ.f +src/SLICOT-Reference/src/MB03GD.f +src/SLICOT-Reference/src/MB03GZ.f +src/SLICOT-Reference/src/MB03HD.f +src/SLICOT-Reference/src/MB03HZ.f +src/SLICOT-Reference/src/MB03ID.f +src/SLICOT-Reference/src/MB03IZ.f +src/SLICOT-Reference/src/MB03JD.f +src/SLICOT-Reference/src/MB03JP.f +src/SLICOT-Reference/src/MB03JZ.f +src/SLICOT-Reference/src/MB03KA.f +src/SLICOT-Reference/src/MB03KB.f +src/SLICOT-Reference/src/MB03KC.f +src/SLICOT-Reference/src/MB03KD.f +src/SLICOT-Reference/src/MB03KE.f +src/SLICOT-Reference/src/MB03LD.f +src/SLICOT-Reference/src/MB03LF.f +src/SLICOT-Reference/src/MB03LP.f +src/SLICOT-Reference/src/MB03LZ.f +src/SLICOT-Reference/src/MB03MD.f +src/SLICOT-Reference/src/MB03MY.f +src/SLICOT-Reference/src/MB03ND.f +src/SLICOT-Reference/src/MB03NY.f +src/SLICOT-Reference/src/MB03OD.f +src/SLICOT-Reference/src/MB03OY.f +src/SLICOT-Reference/src/MB03PD.f +src/SLICOT-Reference/src/MB03PY.f +src/SLICOT-Reference/src/MB03QD.f +src/SLICOT-Reference/src/MB03QG.f +src/SLICOT-Reference/src/MB03QV.f +src/SLICOT-Reference/src/MB03QW.f +src/SLICOT-Reference/src/MB03QX.f +src/SLICOT-Reference/src/MB03QY.f +src/SLICOT-Reference/src/MB03RD.f +src/SLICOT-Reference/src/MB03RX.f +src/SLICOT-Reference/src/MB03RY.f +src/SLICOT-Reference/src/MB03SD.f +src/SLICOT-Reference/src/MB03TD.f +src/SLICOT-Reference/src/MB03TS.f +src/SLICOT-Reference/src/MB03UD.f +src/SLICOT-Reference/src/MB03VD.f +src/SLICOT-Reference/src/MB03VY.f +src/SLICOT-Reference/src/MB03WA.f +src/SLICOT-Reference/src/MB03WD.f +src/SLICOT-Reference/src/MB03WX.f +src/SLICOT-Reference/src/MB03XD.f +src/SLICOT-Reference/src/MB03XP.f +src/SLICOT-Reference/src/MB03XS.f +src/SLICOT-Reference/src/MB03XU.f +src/SLICOT-Reference/src/MB03XZ.f +src/SLICOT-Reference/src/MB03YA.f +src/SLICOT-Reference/src/MB03YD.f +src/SLICOT-Reference/src/MB03YT.f +src/SLICOT-Reference/src/MB03ZA.f +src/SLICOT-Reference/src/MB03ZD.f +src/SLICOT-Reference/src/MB04AD.f +src/SLICOT-Reference/src/MB04AZ.f +src/SLICOT-Reference/src/MB04BD.f +src/SLICOT-Reference/src/MB04BP.f +src/SLICOT-Reference/src/MB04BZ.f +src/SLICOT-Reference/src/MB04CD.f +src/SLICOT-Reference/src/MB04DB.f +src/SLICOT-Reference/src/MB04DD.f +src/SLICOT-Reference/src/MB04DI.f +src/SLICOT-Reference/src/MB04DL.f +src/SLICOT-Reference/src/MB04DP.f +src/SLICOT-Reference/src/MB04DS.f +src/SLICOT-Reference/src/MB04DY.f +src/SLICOT-Reference/src/MB04DZ.f +src/SLICOT-Reference/src/MB04ED.f +src/SLICOT-Reference/src/MB04FD.f +src/SLICOT-Reference/src/MB04FP.f +src/SLICOT-Reference/src/MB04GD.f +src/SLICOT-Reference/src/MB04HD.f +src/SLICOT-Reference/src/MB04ID.f +src/SLICOT-Reference/src/MB04IY.f +src/SLICOT-Reference/src/MB04IZ.f +src/SLICOT-Reference/src/MB04JD.f +src/SLICOT-Reference/src/MB04KD.f +src/SLICOT-Reference/src/MB04LD.f +src/SLICOT-Reference/src/MB04MD.f +src/SLICOT-Reference/src/MB04ND.f +src/SLICOT-Reference/src/MB04NY.f +src/SLICOT-Reference/src/MB04OD.f +src/SLICOT-Reference/src/MB04OW.f +src/SLICOT-Reference/src/MB04OX.f +src/SLICOT-Reference/src/MB04OY.f +src/SLICOT-Reference/src/MB04PA.f +src/SLICOT-Reference/src/MB04PB.f +src/SLICOT-Reference/src/MB04PU.f +src/SLICOT-Reference/src/MB04PY.f +src/SLICOT-Reference/src/MB04QB.f +src/SLICOT-Reference/src/MB04QC.f +src/SLICOT-Reference/src/MB04QF.f +src/SLICOT-Reference/src/MB04QS.f +src/SLICOT-Reference/src/MB04QU.f +src/SLICOT-Reference/src/MB04RB.f +src/SLICOT-Reference/src/MB04RU.f +src/SLICOT-Reference/src/MB04SU.f +src/SLICOT-Reference/src/MB04TB.f +src/SLICOT-Reference/src/MB04TS.f +src/SLICOT-Reference/src/MB04TT.f +src/SLICOT-Reference/src/MB04TU.f +src/SLICOT-Reference/src/MB04TV.f +src/SLICOT-Reference/src/MB04TW.f +src/SLICOT-Reference/src/MB04TX.f +src/SLICOT-Reference/src/MB04TY.f +src/SLICOT-Reference/src/MB04UD.f +src/SLICOT-Reference/src/MB04VD.f +src/SLICOT-Reference/src/MB04VX.f +src/SLICOT-Reference/src/MB04WD.f +src/SLICOT-Reference/src/MB04WP.f +src/SLICOT-Reference/src/MB04WR.f +src/SLICOT-Reference/src/MB04WU.f +src/SLICOT-Reference/src/MB04XD.f +src/SLICOT-Reference/src/MB04XY.f +src/SLICOT-Reference/src/MB04YD.f +src/SLICOT-Reference/src/MB04YW.f +src/SLICOT-Reference/src/MB04ZD.f +src/SLICOT-Reference/src/MB05MD.f +src/SLICOT-Reference/src/MB05MY.f +src/SLICOT-Reference/src/MB05ND.f +src/SLICOT-Reference/src/MB05OD.f +src/SLICOT-Reference/src/MB05OY.f +src/SLICOT-Reference/src/MB3JZP.f +src/SLICOT-Reference/src/MB3LZP.f +src/SLICOT-Reference/src/MB3OYZ.f +src/SLICOT-Reference/src/MB3PYZ.f +src/SLICOT-Reference/src/MB4DBZ.f +src/SLICOT-Reference/src/MB4DLZ.f +src/SLICOT-Reference/src/MB4DPZ.f +src/SLICOT-Reference/src/MC01MD.f +src/SLICOT-Reference/src/MC01ND.f +src/SLICOT-Reference/src/MC01OD.f +src/SLICOT-Reference/src/MC01PD.f +src/SLICOT-Reference/src/MC01PY.f +src/SLICOT-Reference/src/MC01QD.f +src/SLICOT-Reference/src/MC01RD.f +src/SLICOT-Reference/src/MC01SD.f +src/SLICOT-Reference/src/MC01SW.f +src/SLICOT-Reference/src/MC01SX.f +src/SLICOT-Reference/src/MC01SY.f +src/SLICOT-Reference/src/MC01TD.f +src/SLICOT-Reference/src/MC01VD.f +src/SLICOT-Reference/src/MC01WD.f +src/SLICOT-Reference/src/MC01XD.f +src/SLICOT-Reference/src/MC03MD.f +src/SLICOT-Reference/src/MC03ND.f +src/SLICOT-Reference/src/MC03NX.f +src/SLICOT-Reference/src/MC03NY.f +src/SLICOT-Reference/src/MD03AD.f +src/SLICOT-Reference/src/MD03BA.f +src/SLICOT-Reference/src/MD03BB.f +src/SLICOT-Reference/src/MD03BD.f +src/SLICOT-Reference/src/MD03BF.f +src/SLICOT-Reference/src/MD03BX.f +src/SLICOT-Reference/src/MD03BY.f +src/SLICOT-Reference/src/NF01AD.f +src/SLICOT-Reference/src/NF01AY.f +src/SLICOT-Reference/src/NF01BA.f +src/SLICOT-Reference/src/NF01BB.f +src/SLICOT-Reference/src/NF01BD.f +src/SLICOT-Reference/src/NF01BE.f +src/SLICOT-Reference/src/NF01BF.f +src/SLICOT-Reference/src/NF01BP.f +src/SLICOT-Reference/src/NF01BQ.f +src/SLICOT-Reference/src/NF01BR.f +src/SLICOT-Reference/src/NF01BS.f +src/SLICOT-Reference/src/NF01BU.f +src/SLICOT-Reference/src/NF01BV.f +src/SLICOT-Reference/src/NF01BW.f +src/SLICOT-Reference/src/NF01BX.f +src/SLICOT-Reference/src/NF01BY.f +src/SLICOT-Reference/src/SB01BD.f +src/SLICOT-Reference/src/SB01BX.f +src/SLICOT-Reference/src/SB01BY.f +src/SLICOT-Reference/src/SB01DD.f +src/SLICOT-Reference/src/SB01FY.f +src/SLICOT-Reference/src/SB01MD.f +src/SLICOT-Reference/src/SB02CX.f +src/SLICOT-Reference/src/SB02MD.f +src/SLICOT-Reference/src/SB02MR.f +src/SLICOT-Reference/src/SB02MS.f +src/SLICOT-Reference/src/SB02MT.f +src/SLICOT-Reference/src/SB02MU.f +src/SLICOT-Reference/src/SB02MV.f +src/SLICOT-Reference/src/SB02MW.f +src/SLICOT-Reference/src/SB02MX.f +src/SLICOT-Reference/src/SB02ND.f +src/SLICOT-Reference/src/SB02OD.f +src/SLICOT-Reference/src/SB02OU.f +src/SLICOT-Reference/src/SB02OV.f +src/SLICOT-Reference/src/SB02OW.f +src/SLICOT-Reference/src/SB02OX.f +src/SLICOT-Reference/src/SB02OY.f +src/SLICOT-Reference/src/SB02PD.f +src/SLICOT-Reference/src/SB02QD.f +src/SLICOT-Reference/src/SB02RD.f +src/SLICOT-Reference/src/SB02RU.f +src/SLICOT-Reference/src/SB02SD.f +src/SLICOT-Reference/src/SB03MD.f +src/SLICOT-Reference/src/SB03MU.f +src/SLICOT-Reference/src/SB03MV.f +src/SLICOT-Reference/src/SB03MW.f +src/SLICOT-Reference/src/SB03MX.f +src/SLICOT-Reference/src/SB03MY.f +src/SLICOT-Reference/src/SB03OD.f +src/SLICOT-Reference/src/SB03OR.f +src/SLICOT-Reference/src/SB03OT.f +src/SLICOT-Reference/src/SB03OU.f +src/SLICOT-Reference/src/SB03OV.f +src/SLICOT-Reference/src/SB03OY.f +src/SLICOT-Reference/src/SB03PD.f +src/SLICOT-Reference/src/SB03QD.f +src/SLICOT-Reference/src/SB03QX.f +src/SLICOT-Reference/src/SB03QY.f +src/SLICOT-Reference/src/SB03RD.f +src/SLICOT-Reference/src/SB03SD.f +src/SLICOT-Reference/src/SB03SX.f +src/SLICOT-Reference/src/SB03SY.f +src/SLICOT-Reference/src/SB03TD.f +src/SLICOT-Reference/src/SB03UD.f +src/SLICOT-Reference/src/SB04MD.f +src/SLICOT-Reference/src/SB04MR.f +src/SLICOT-Reference/src/SB04MU.f +src/SLICOT-Reference/src/SB04MW.f +src/SLICOT-Reference/src/SB04MY.f +src/SLICOT-Reference/src/SB04ND.f +src/SLICOT-Reference/src/SB04NV.f +src/SLICOT-Reference/src/SB04NW.f +src/SLICOT-Reference/src/SB04NX.f +src/SLICOT-Reference/src/SB04NY.f +src/SLICOT-Reference/src/SB04OD.f +src/SLICOT-Reference/src/SB04OW.f +src/SLICOT-Reference/src/SB04PD.f +src/SLICOT-Reference/src/SB04PX.f +src/SLICOT-Reference/src/SB04PY.f +src/SLICOT-Reference/src/SB04QD.f +src/SLICOT-Reference/src/SB04QR.f +src/SLICOT-Reference/src/SB04QU.f +src/SLICOT-Reference/src/SB04QY.f +src/SLICOT-Reference/src/SB04RD.f +src/SLICOT-Reference/src/SB04RV.f +src/SLICOT-Reference/src/SB04RW.f +src/SLICOT-Reference/src/SB04RX.f +src/SLICOT-Reference/src/SB04RY.f +src/SLICOT-Reference/src/SB06ND.f +src/SLICOT-Reference/src/SB08CD.f +src/SLICOT-Reference/src/SB08DD.f +src/SLICOT-Reference/src/SB08ED.f +src/SLICOT-Reference/src/SB08FD.f +src/SLICOT-Reference/src/SB08GD.f +src/SLICOT-Reference/src/SB08HD.f +src/SLICOT-Reference/src/SB08MD.f +src/SLICOT-Reference/src/SB08MY.f +src/SLICOT-Reference/src/SB08ND.f +src/SLICOT-Reference/src/SB08NY.f +src/SLICOT-Reference/src/SB09MD.f +src/SLICOT-Reference/src/SB10AD.f +src/SLICOT-Reference/src/SB10DD.f +src/SLICOT-Reference/src/SB10ED.f +src/SLICOT-Reference/src/SB10FD.f +src/SLICOT-Reference/src/SB10HD.f +src/SLICOT-Reference/src/SB10ID.f +src/SLICOT-Reference/src/SB10JD.f +src/SLICOT-Reference/src/SB10KD.f +src/SLICOT-Reference/src/SB10LD.f +src/SLICOT-Reference/src/SB10MD.f +src/SLICOT-Reference/src/SB10PD.f +src/SLICOT-Reference/src/SB10QD.f +src/SLICOT-Reference/src/SB10RD.f +src/SLICOT-Reference/src/SB10SD.f +src/SLICOT-Reference/src/SB10TD.f +src/SLICOT-Reference/src/SB10UD.f +src/SLICOT-Reference/src/SB10VD.f +src/SLICOT-Reference/src/SB10WD.f +src/SLICOT-Reference/src/SB10YD.f +src/SLICOT-Reference/src/SB10ZD.f +src/SLICOT-Reference/src/SB10ZP.f +src/SLICOT-Reference/src/SB16AD.f +src/SLICOT-Reference/src/SB16AY.f +src/SLICOT-Reference/src/SB16BD.f +src/SLICOT-Reference/src/SB16CD.f +src/SLICOT-Reference/src/SB16CY.f +src/SLICOT-Reference/src/SG02AD.f +src/SLICOT-Reference/src/SG02CV.f +src/SLICOT-Reference/src/SG02CW.f +src/SLICOT-Reference/src/SG02CX.f +src/SLICOT-Reference/src/SG02ND.f +src/SLICOT-Reference/src/SG03AD.f +src/SLICOT-Reference/src/SG03AX.f +src/SLICOT-Reference/src/SG03AY.f +src/SLICOT-Reference/src/SG03BD.f +src/SLICOT-Reference/src/SG03BU.f +src/SLICOT-Reference/src/SG03BV.f +src/SLICOT-Reference/src/SG03BW.f +src/SLICOT-Reference/src/SG03BX.f +src/SLICOT-Reference/src/SG03BY.f +src/SLICOT-Reference/src/TB01ID.f +src/SLICOT-Reference/src/TB01IZ.f +src/SLICOT-Reference/src/TB01KD.f +src/SLICOT-Reference/src/TB01KX.f +src/SLICOT-Reference/src/TB01LD.f +src/SLICOT-Reference/src/TB01MD.f +src/SLICOT-Reference/src/TB01ND.f +src/SLICOT-Reference/src/TB01PD.f +src/SLICOT-Reference/src/TB01PX.f +src/SLICOT-Reference/src/TB01TD.f +src/SLICOT-Reference/src/TB01TY.f +src/SLICOT-Reference/src/TB01UD.f +src/SLICOT-Reference/src/TB01UX.f +src/SLICOT-Reference/src/TB01UY.f +src/SLICOT-Reference/src/TB01VD.f +src/SLICOT-Reference/src/TB01VY.f +src/SLICOT-Reference/src/TB01WD.f +src/SLICOT-Reference/src/TB01WX.f +src/SLICOT-Reference/src/TB01XD.f +src/SLICOT-Reference/src/TB01XZ.f +src/SLICOT-Reference/src/TB01YD.f +src/SLICOT-Reference/src/TB01ZD.f +src/SLICOT-Reference/src/TB03AD.f +src/SLICOT-Reference/src/TB03AY.f +src/SLICOT-Reference/src/TB04AD.f +src/SLICOT-Reference/src/TB04AY.f +src/SLICOT-Reference/src/TB04BD.f +src/SLICOT-Reference/src/TB04BV.f +src/SLICOT-Reference/src/TB04BW.f +src/SLICOT-Reference/src/TB04BX.f +src/SLICOT-Reference/src/TB04CD.f +src/SLICOT-Reference/src/TB05AD.f +src/SLICOT-Reference/src/TC01OD.f +src/SLICOT-Reference/src/TC04AD.f +src/SLICOT-Reference/src/TC05AD.f +src/SLICOT-Reference/src/TD03AD.f +src/SLICOT-Reference/src/TD03AY.f +src/SLICOT-Reference/src/TD04AD.f +src/SLICOT-Reference/src/TD05AD.f +src/SLICOT-Reference/src/TF01MD.f +src/SLICOT-Reference/src/TF01MX.f +src/SLICOT-Reference/src/TF01MY.f +src/SLICOT-Reference/src/TF01ND.f +src/SLICOT-Reference/src/TF01OD.f +src/SLICOT-Reference/src/TF01PD.f +src/SLICOT-Reference/src/TF01QD.f +src/SLICOT-Reference/src/TF01RD.f +src/SLICOT-Reference/src/TG01AD.f +src/SLICOT-Reference/src/TG01AZ.f +src/SLICOT-Reference/src/TG01BD.f +src/SLICOT-Reference/src/TG01CD.f +src/SLICOT-Reference/src/TG01DD.f +src/SLICOT-Reference/src/TG01ED.f +src/SLICOT-Reference/src/TG01FD.f +src/SLICOT-Reference/src/TG01FZ.f +src/SLICOT-Reference/src/TG01GD.f +src/SLICOT-Reference/src/TG01HD.f +src/SLICOT-Reference/src/TG01HU.f +src/SLICOT-Reference/src/TG01HX.f +src/SLICOT-Reference/src/TG01HY.f +src/SLICOT-Reference/src/TG01ID.f +src/SLICOT-Reference/src/TG01JD.f +src/SLICOT-Reference/src/TG01JY.f +src/SLICOT-Reference/src/TG01LD.f +src/SLICOT-Reference/src/TG01LY.f +src/SLICOT-Reference/src/TG01MD.f +src/SLICOT-Reference/src/TG01ND.f +src/SLICOT-Reference/src/TG01NX.f +src/SLICOT-Reference/src/TG01PD.f +src/SLICOT-Reference/src/TG01QD.f +src/SLICOT-Reference/src/TG01WD.f +src/SLICOT-Reference/src/UD01BD.f +src/SLICOT-Reference/src/UD01CD.f +src/SLICOT-Reference/src/UD01DD.f +src/SLICOT-Reference/src/UD01MD.f +src/SLICOT-Reference/src/UD01MZ.f +src/SLICOT-Reference/src/UD01ND.f +src/SLICOT-Reference/src/UE01MD.f -src/SLICOT-reference/src/delctg.f -src/SLICOT-reference/src/select.f +src/SLICOT-Reference/src/delctg.f +src/SLICOT-Reference/src/select.f -src/SLICOT-reference/src/SLCT_DLATZM.f -src/SLICOT-reference/src/SLCT_ZLATZM.f +src/SLICOT-Reference/src/SLCT_DLATZM.f +src/SLICOT-Reference/src/SLCT_ZLATZM.f ) diff --git a/slycot/src/Readme.md b/slycot/src/Readme.md index a1f3a580..74af8ff3 100644 --- a/slycot/src/Readme.md +++ b/slycot/src/Readme.md @@ -3,7 +3,7 @@ Fortran sources This directory contains the f2py wrappers and some helper functions to work with the SLICOT Library routines. SLICOT-reference is a git submodule -forked from [SLICOT-reference](https://github.com/SLICOT/SLICOT-reference) +forked from [SLICOT-Reference](https://github.com/SLICOT/SLICOT-Reference) plus some backported improvements. The codes follow the Fortran 77 language conventions. SLICOT routines make diff --git a/slycot/src/SLICOT-reference b/slycot/src/SLICOT-Reference similarity index 100% rename from slycot/src/SLICOT-reference rename to slycot/src/SLICOT-Reference From 63a7d379c90be9792f0b81ec30241aeed026e518 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 21:55:31 +0100 Subject: [PATCH 260/405] Test the sdist --- .github/workflows/slycot-build-and-test.yml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 4fc29167..d8048896 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -14,7 +14,7 @@ jobs: build-setup: # Super fast sniff build. If this fails, don't start the other jobs - name: Build setup.py on Ubuntu + name: Build sdist on Ubuntu runs-on: ubuntu-latest steps: - name: Checkout Slycot @@ -29,8 +29,16 @@ jobs: sudo apt-get -y install gfortran cmake --fix-missing sudo apt-get -y install libblas-dev liblapack-dev pip install scikit-build numpy scipy pytest - - name: Install Slycot - run: python setup.py install + - name: Create Slycot sdist + run: python setup.py sdist + + - name: Install Slycot sdist + run: | + mkdir cleancwd + cd cleancwd + tar xfz ../dist/slycot-*.tar.gz + cd slycot-* + python setup.py install - name: Run tests run: pytest From 1177373e5b3ebabce7572cea3ac95dea3ce53945 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Feb 2021 23:48:38 +0100 Subject: [PATCH 261/405] new call signature for sb03md --- slycot/src/synthesis.pyf | 6 ++--- slycot/synthesis.py | 48 +++++++++++++++++++++++++++------------- 2 files changed, 36 insertions(+), 18 deletions(-) diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index 3dc0a28b..27eb6e39 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -325,16 +325,16 @@ subroutine sb02mt_cl(jobg,jobl,fact,uplo,n,m,a,lda,b,ldb,q,ldq,r,ldr,l,ldl,ipiv, integer intent(hide) :: ldwork = 1 integer intent(out) :: info end subroutine sb02mt_cl -subroutine sb03md(dico,job,fact,trana,n,c,ldc,a,lda,u,ldu,scale,sep,ferr,wr,wi,iwork,dwork,ldwork,info) ! in :new:SB03MD.f +subroutine sb03md(dico,job,fact,trana,n,a,lda,u,ldu,c,ldc,scale,sep,ferr,wr,wi,iwork,dwork,ldwork,info) ! in :new:SB03MD.f fortranname sb03md character :: dico character :: job='X' character :: fact='N' character :: trana='N' integer check(n>0) :: n - double precision dimension(n,n),depend(n) :: a + double precision intent(in,out,copy),dimension(n,n),depend(n) :: a integer intent(hide),depend(a) :: lda=shape(a,0) - double precision dimension(n,n),depend(n) :: u + double precision intent(in,out,copy),dimension(n,n),depend(n) :: u integer intent(hide),depend(u) :: ldu=shape(u,0) double precision intent(in,out,copy),dimension(n,n),depend(n) :: c integer intent(hide),depend(c) :: ldc=shape(c,0) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 8e1c0011..67efe356 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -18,12 +18,13 @@ # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, # MA 02110-1301, USA. +from warnings import warn + +import numpy as _np from . import _wrapper from .exceptions import raise_if_slycot_error, SlycotParameterError -import numpy as _np - def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): """ A_z,w,nfp,nap,nup,F,Z = sb01bd(n,m,np,alpha,A,B,w,dico,[tol,ldwork]) @@ -674,10 +675,10 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw w.imag = alphai[0:2*n]/beta[0:2*n] return X,rcond,w,S,T -def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): - """ X,scale,sep,ferr,w = sb03md(dico,n,C,A,U,[job,fact,trana,ldwork]) - To solve for X either the real continuous-time Lyapunov equation +def sb03md57(A, U=None, C=None, + dico='C', job='X',fact='N',trana='N',ldwork=None): + """To solve for X either the real continuous-time Lyapunov equation :: @@ -699,9 +700,6 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): ---------- n : int The order of the matrices A, X, and C. n > 0. - C : (n, n) array_like - If job = 'X' or 'B', the leading n-by-n part of this array must - contain the symmetric matrix C. If job = 'S', C is not referenced. A : (n, n) array_like On entry, the leading n-by-n part of this array must contain the matrix A. If fact = 'F', then A contains an upper quasi-triangular @@ -717,6 +715,9 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): the real Schur factorization of A. If fact = 'N', then U is an output argument and on exit, it contains the orthogonal n-by-n matrix from the real Schur factorization of A. + C : (n, n) array_like + If job = 'X' or 'B', the leading n-by-n part of this array must + contain the symmetric matrix C. If job = 'S', C is not referenced. dico : {'C', 'D'} Specifies the equation from which X is to be determined as follows: := 'C': Equation (1), continuous-time case; @@ -779,23 +780,40 @@ def sb03md(n,C,A,U,dico,job='X',fact='N',trana='N',ldwork=None): eigenvalues of `A` and ``i != j``); perturbed values were used to solve the equation (but the matrix A is unchanged). """ - - hidden = ' (hidden by the wrapper)' arg_list = ['dico', 'job', 'fact', 'trana', 'n', 'A', 'LDA'+hidden, 'U', 'LDU'+hidden, 'C', 'LDC'+hidden, 'scale', 'sep', 'ferr', 'wr'+hidden, 'wi'+hidden, 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'INFO'+hidden] + n = A.shape[0] + if U is None: + U = _np.zeros((n, n)) + if C is None: + C = _np.zeros((n, n)) if ldwork is None: - ldwork = max(2*n*n,3*n) + ldwork = max(2*n*n, 3*n) if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) - out = _wrapper.sb03md(dico,n,C,A,U,job=job,fact=fact,trana=trana,ldwork=ldwork) + out = _wrapper.sb03md(dico, n, A, U, C, + job=job, fact=fact, trana=trana, ldwork=ldwork) raise_if_slycot_error(out[-1], arg_list, sb03md.__doc__, locals()) - X,scale,sep,ferr,wr,wi = out[:-1] - w = _np.zeros(n,'complex64') + Ar, Ur, X, scale, sep, ferr, wr, wi = out[:-1] + w = _np.zeros(n, 'complex64') w.real = wr[0:n] w.imag = wi[0:n] - return X,scale,sep,ferr,w + return Ar, Ur, X, scale, sep, ferr, w + +def sb03md(n, C, A, U, dico, job='X',fact='N',trana='N',ldwork=None): + """ X,scale,sep,ferr,w = sb03md(n,C,A,U,dico,[job,fact,trana,ldwork]) + + .. deprecated:: 0.5 + This function uses a call signature of SB03MD prior to SLICOT version + 5.7. Use `sb03md57` instead. + """ + warn("sb03md uses a call signature of SB03MD prior to SLICOT version 5.7." + " Use sb03md57 for the new call signature", + DeprecationWarning, stacklevel=2) + ret = sb03md57(A, U, C, dico, job, fact, trana, ldwork) + return ret[2:] def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): """ U,scale,w = sb03od(dico,n,m,A,Q,B,[fact,trans,ldwork]) From e6a94ccc3572ccbe19dae6ed70c7b349f9add6d8 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 8 Feb 2021 00:06:23 +0100 Subject: [PATCH 262/405] import, test, and example for new signature --- slycot/__init__.py | 11 ++++++++--- slycot/examples.py | 7 +++---- slycot/tests/test_sb.py | 4 ++-- 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index cf777c38..0fcbd3fd 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -29,9 +29,14 @@ # Synthesis routines (15/50 wrapped) - from .synthesis import sb01bd,sb02md,sb02mt,sb02od,sb03md,sb03od - from .synthesis import sb04md,sb04qd,sb10ad,sb10dd,sb10hd,sg03ad - from .synthesis import sg02ad, sg03bd, sb10fd + from .synthesis import (sb01bd, + sb02md, sb02mt, sb02od, + sb03md, sb03md57, sb03od, + sb04md, sb04qd, + sb10ad, sb10dd, sb10fd, sb10hd, + sg02ad, + sg03ad, sg03bd) + # Transformation routines (9/40 wrapped) from .transform import tb01id, tb03ad, tb04ad diff --git a/slycot/examples.py b/slycot/examples.py index 0207fb39..cf306913 100644 --- a/slycot/examples.py +++ b/slycot/examples.py @@ -40,12 +40,11 @@ def sb03md_example(): C = array([ [25, 24, 15], [24, 32, 8], [15, 8, 40]]) - U = zeros((3,3)) - out = slycot.sb03md(3,C,A,U,'D') + out = slycot.sb03md57(A, C=C, dico='D') print('--- Example for sb03md ---') print('The solution X is') - print(out[0]) - print('scaling factor:', out[1]) + print(out[2]) + print('scaling factor:', out[3]) def ab08nd_example(): from numpy import zeros, size diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 556a09d3..2446405d 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -186,9 +186,9 @@ def test_sb10fd_2(): (synthesis.sb01bd, SlycotResultWarning, [3, 4, [1, 0]], {'nap': '1'}), (synthesis.sb02md, SlycotArithmeticError, 5, {}), (synthesis.sb02od, SlycotArithmeticError, 6, {}), - (synthesis.sb03md, SlycotResultWarning, 3, {'n': 2, + (synthesis.sb03md57, SlycotResultWarning, 3, {'n': 2, 'dico': 'D'}), - (synthesis.sb03md, SlycotResultWarning, 3, {'n': 2, + (synthesis.sb03md57, SlycotResultWarning, 3, {'n': 2, 'dico': 'C'}), (synthesis.sb03od, SlycotResultWarning, [1, 2], {'dico': 'C', 'fact': 'N'}), From fc71152b6ef65029bb6cc937da7863a409f3c5f3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 8 Feb 2021 21:35:15 +0100 Subject: [PATCH 263/405] update SLICOT-Reference ref --- slycot/src/SLICOT-Reference | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/SLICOT-Reference b/slycot/src/SLICOT-Reference index bb4b0253..545f32ce 160000 --- a/slycot/src/SLICOT-Reference +++ b/slycot/src/SLICOT-Reference @@ -1 +1 @@ -Subproject commit bb4b02538b769b0b0fcc085799b58522d897af48 +Subproject commit 545f32ce70ce4ef5556c5336b39db93893bb581c From 02e49a4f85a6a0c34335e492c3a5c582d6a231c6 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 8 Feb 2021 21:57:17 +0100 Subject: [PATCH 264/405] s/SLICOT-reference/SLICOT-Reference/ --- slycot/src/Readme.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/Readme.md b/slycot/src/Readme.md index 74af8ff3..f2cd884a 100644 --- a/slycot/src/Readme.md +++ b/slycot/src/Readme.md @@ -2,7 +2,7 @@ Fortran sources --------------- This directory contains the f2py wrappers and some helper functions to work -with the SLICOT Library routines. SLICOT-reference is a git submodule +with the SLICOT Library routines. SLICOT-Reference is a git submodule forked from [SLICOT-Reference](https://github.com/SLICOT/SLICOT-Reference) plus some backported improvements. From ef3d67da9de2c19bdba4493b1b05a528f18cbc36 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 20 Feb 2021 11:34:34 +0100 Subject: [PATCH 265/405] Apply suggestions from code review Co-authored-by: Rory Yorke --- README.rst | 6 +++--- setup.py | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/README.rst b/README.rst index 2b80b0e4..829d1330 100644 --- a/README.rst +++ b/README.rst @@ -197,9 +197,9 @@ in ``setup.cfg`` enforces the ``--pyargs slycot`` argument by default. License ------- -Up until version 0.4, Slycot used a version of SLICOT, which was released under -the GPLv2 license. This mandates to release Slycot under the same license. In +Up until version 0.4, Slycot used a version of SLICOT that was released under +the GPLv2 license. This requires Slycot to be released under the same license. In December 2020, SLICOT 5.7 was released under BSD-3-Clause. However, as the existing Slycot wrappers have been submitted by many contributors, we cannot move away from GPLv2 unless we get the permission to do so by all authors. -Thus, Slycot remains licensed under GPLv2 until further notice. \ No newline at end of file +Thus, Slycot remains licensed under GPLv2 until further notice. diff --git a/setup.py b/setup.py index 10f5e166..88937979 100644 --- a/setup.py +++ b/setup.py @@ -213,7 +213,7 @@ class sdist_checked(sdist): """ check submodules on sdist to prevent incomplete tarballs """ def run(self): # slycot had no submodules currently - # check_submodules() + check_submodules() sdist.run(self) def setup_package(): From 1f0a4f3b8f22ab118400a1882701c924f92852ae Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 20 Feb 2021 11:48:50 +0100 Subject: [PATCH 266/405] Adjust sb03md docstring --- slycot/synthesis.py | 42 ++++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 67efe356..c232c5ce 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -698,26 +698,16 @@ def sb03md57(A, U=None, C=None, Parameters ---------- - n : int - The order of the matrices A, X, and C. n > 0. A : (n, n) array_like - On entry, the leading n-by-n part of this array must contain the - matrix A. If fact = 'F', then A contains an upper quasi-triangular + If fact = 'F', then A contains an upper quasi-triangular matrix in Schur canonical form; the elements below the upper Hessenberg part of the array A are not referenced. - On exit, the leading n-by-n upper Hessenberg part of this array - contains the upper quasi-triangular matrix in Schur canonical form - from the Schur factorization of A. The contents of array A is not - modified if fact = 'F'. U : (n, n) array_like - If fact = 'F', then U is an input argument and on entry the leading - n-by-n part of this array must contain the orthogonal matrix U of + If fact = 'F', then this array must contain the orthogonal matrix U of the real Schur factorization of A. - If fact = 'N', then U is an output argument and on exit, it contains - the orthogonal n-by-n matrix from the real Schur factorization of A. C : (n, n) array_like - If job = 'X' or 'B', the leading n-by-n part of this array must - contain the symmetric matrix C. If job = 'S', C is not referenced. + If job = 'X' or 'B', this array must contain the symmetric matrix C. + If job = 'S', C is not referenced. dico : {'C', 'D'} Specifies the equation from which X is to be determined as follows: := 'C': Equation (1), continuous-time case; @@ -745,6 +735,14 @@ def sb03md57(A, U=None, C=None, Returns ------- + Ar : (n, n) ndarray + The leading n-by-n upper Hessenberg part of this array + contains the upper quasi-triangular matrix in Schur canonical form + from the Schur factorization of A. The content of array A is not + modified if fact = 'F'. + Ur : (n, n) ndarray + If fact = 'N', this arrray contains the orthogonal n-by-n matrix + from the real Schur factorization of A. X : (n, n) ndarray If job = 'X' or 'B', the leading n-by-n part contains the symmetric solution matrix. @@ -761,7 +759,7 @@ def sb03md57(A, U=None, C=None, relative error in the computed solution, measured in the Frobenius norm: norm(X - X_true)/norm(X_true). w : (n, ) complex ndarray - If fact = 'N', this array contain the eigenvalues of A. + If fact = 'N', this array contains the eigenvalues of A. Warns ----- @@ -804,7 +802,7 @@ def sb03md57(A, U=None, C=None, def sb03md(n, C, A, U, dico, job='X',fact='N',trana='N',ldwork=None): """ X,scale,sep,ferr,w = sb03md(n,C,A,U,dico,[job,fact,trana,ldwork]) - + .. deprecated:: 0.5 This function uses a call signature of SB03MD prior to SLICOT version 5.7. Use `sb03md57` instead. @@ -2474,7 +2472,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): To compute the matrices of an H-infinity (sub)optimal n-state controller - + :: | AK | BK | @@ -2482,7 +2480,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): | CK | DK | using modified Glover's and Doyle's 1988 formulas, for the system - + :: | A | B1 B2 | | A | B | @@ -2495,7 +2493,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): of measurements (nmeas) being provided to the controller. It is assumed that - + :: (A1) (A,B2) is stabilizable and (C2,A) is detectable, @@ -2614,7 +2612,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): :: - | A-j*omega*I B2 | + | A-j*omega*I B2 | | C1 D12 | had no full column rank in respect to the tolerance eps @@ -2642,7 +2640,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): |A B2 |, |A B1 |, D12 or D21). |C1 D12| |C2 D21| - + :info = 6: The controller is not admissible (too small value of gamma) @@ -2657,7 +2655,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): :info = 9: The determinant of ``Im2 + Tu*D11HAT*Ty*D22`` is zero [3]_. - + Notes ----- Method From 996e86f77ff0e1c9c6a8468ff910c548ef2fe711 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 20 Feb 2021 15:49:32 +0100 Subject: [PATCH 267/405] remove outdated submodule comment --- setup.py | 1 - 1 file changed, 1 deletion(-) diff --git a/setup.py b/setup.py index 88937979..a3ba7109 100644 --- a/setup.py +++ b/setup.py @@ -212,7 +212,6 @@ def check_submodules(): class sdist_checked(sdist): """ check submodules on sdist to prevent incomplete tarballs """ def run(self): - # slycot had no submodules currently check_submodules() sdist.run(self) From 090678247e3f2e3530e7515f40aa722f75e31dcf Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 21 Feb 2021 12:42:08 +0100 Subject: [PATCH 268/405] switch submodule to python-control/SLICOT-Reference repo --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 95ba6522..19b9d23c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "slycot/src/SLICOT-Reference"] path = slycot/src/SLICOT-Reference - url = https://github.com/bnavigator/SLICOT-Reference + url = https://github.com/python-control/SLICOT-Reference From ac6712fce54c0db72a121b80547f7b2cba479abe Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 21 Feb 2021 13:10:10 +0100 Subject: [PATCH 269/405] Add source code download and submodule init instructions to README --- README.rst | 60 ++++++++++++++++++++++++++++++++++++-------- slycot/src/Readme.md | 4 +++ 2 files changed, 54 insertions(+), 10 deletions(-) diff --git a/README.rst b/README.rst index 829d1330..2f037074 100644 --- a/README.rst +++ b/README.rst @@ -65,6 +65,7 @@ from the conda-forge channel with the following command:: conda install -c conda-forge slycot + Compiling from source --------------------- @@ -77,12 +78,53 @@ the correct header files are installed, and specify the environment variable .. _BLA_VENDOR: https://cmake.org/cmake/help/latest/module/FindBLAS.html#input-variables +Getting the full source code +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From source without conda (Linux, macOS, Windows) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Get it from PyPI +^^^^^^^^^^^^^^^^ + +Get the source code of the latest release is available from `PyPI`_. It +contains both the Python to Fortran wrappers as well as the SLICOT-Reference +Fortran sources. + +.. _PyPI: https://pypi.org/project/slycot + +Get it from GitHub archives +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +If you decide to download a source code archive from GitHub (tagged release or +a specific branch), you also have to get the correct version of our +SLICOT-Reference fork and place it into ``slycot/src/SLICOT-Reference``: + +1. Download and unpack https://github.com/python-control/Slycot/archive/master.zip +2. Go to https://github.com/python-control/Slycot/master/slycot/src +3. Follow the link of ``SLICOT-Reference @ `` +4. Download the archive of SLICOT-Reference from the Code download button + (``https://github.com/python-control/SLICOT-Reference/archive/.zip``) +5. Unpack the contents of the SLICOT-Reference archive into + ``slycot/src/SLICOT-Reference`` + +Replace ``master`` with the release tag or branch name, which you want to build. + +Clone the git repository +^^^^^^^^^^^^^^^^^^^^^^^^ -Unpack the source code (or clone the git repository) to a directory of your choice, -e.g. ``/path/to/slycot_src/`` +Directly checkout the submodule, when cloning the git repository:: + + git clone --recurse-submodules https://github.com/python-control/Slycot.git + +or if you forked the repository:: + + git clone --recurse-submodules https://github.com//Slycot.git + +If you already have a local checkout, but still need to init the submodule:: + + git submodule init + git submodule update + +Compiling with setuptools (Linux, macOS, Windows) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you need to specify a specific compiler, set the environment variable FC before running the install:: @@ -98,8 +140,8 @@ To build and install, execute:: cd /path/to/slycot_src/ python setup.py install -From source using the conda recipe -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Using the conda recipe +~~~~~~~~~~~~~~~~~~~~~~ You can use conda to compile and install Slycot from source. The recipe is located in the folder ``conda-recipe`` and is intended to work for all @@ -127,8 +169,8 @@ To build and install:: conda build -c conda-forge conda-recipe conda install -c conda-forge --use-local slycot -From source in a conda environment (Windows) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With setuptools in a conda environment (Windows) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A similar method can be used for Linux and macOS, but is detailed here for Windows. This method uses conda and conda-forge to get most build @@ -164,8 +206,6 @@ will download the latest release of the source code from `PyPI`_, compile, and install Slycot into the currently configured location (virtual environment or user site-packages). -.. _PyPI: https://pypi.org/project/slycot - Additional hints ~~~~~~~~~~~~~~~~ diff --git a/slycot/src/Readme.md b/slycot/src/Readme.md index f2cd884a..26d944b2 100644 --- a/slycot/src/Readme.md +++ b/slycot/src/Readme.md @@ -6,6 +6,10 @@ with the SLICOT Library routines. SLICOT-Reference is a git submodule forked from [SLICOT-Reference](https://github.com/SLICOT/SLICOT-Reference) plus some backported improvements. +If your local copy of the SLICOT-Reference directory is empty, get the correct +version from python-control/SLICOT-Reference (see the Slycot toplevel directory +README for instructions). + The codes follow the Fortran 77 language conventions. SLICOT routines make calls to the state-of-the-art packages LAPACK (Linear Algebra Package) and BLAS (Basic Linear Algebra Subprograms). From c9ebc70134c798ec44ef2997e9c48047b65ee49b Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 31 Oct 2021 22:23:37 +0100 Subject: [PATCH 270/405] test ag08bd agnostic of Af-lambda*Ef scaling --- slycot/tests/test_ag08bd.py | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/slycot/tests/test_ag08bd.py b/slycot/tests/test_ag08bd.py index b8d23174..7c0706aa 100644 --- a/slycot/tests/test_ag08bd.py +++ b/slycot/tests/test_ag08bd.py @@ -47,8 +47,8 @@ [ 0, 0, 0]]) -class test_tg01fd(unittest.TestCase): - """ Verify ag08bd with input parameters according to example in documentation """ +class test_ag08bd(unittest.TestCase): + """Verify ag08bd with input parameters according to example in documentation.""" def test1_ag08bd(self): """test [A-lambda*E] @@ -108,8 +108,9 @@ def test4_ag08bd(self): Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,D=test1_D,equil=test1_equil, tol=test1_tol) - assert_almost_equal(Af, [[0.77045021]]) - assert_almost_equal(Ef, [[0.77045021]]) + # Af-lambda*Ef==0. => lambda==1. => Finite Smith zero of S(lambda) == 1. + assert Af.shape == (1, 1) + assert_almost_equal(Af, Ef) assert_equal(nrank, 11) assert_equal(niz, 2) assert_equal(infz, [0,1]) From c777bc8eadc0b7e414a328cd97aa080d47a18276 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 31 Oct 2021 23:04:09 +0100 Subject: [PATCH 271/405] limit sniff-build to Python 3.9 --- .github/workflows/slycot-build-and-test.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 38ce7ec4..f9b5b260 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -24,6 +24,8 @@ jobs: submodules: 'recursive' - name: Set up Python uses: actions/setup-python@v2 + with: + python-version: 3.9 - name: Setup Ubuntu run: | sudo apt-get -y install gfortran cmake --fix-missing From 1783de974232dadf2639fd7b5f685399b244cecb Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 10 Nov 2021 00:23:41 +0100 Subject: [PATCH 272/405] sunset py 3.6, test 3.10 --- .github/workflows/slycot-build-and-test.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index f9b5b260..ef92ddcd 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -55,10 +55,9 @@ jobs: - 'ubuntu' - 'macos' python: - - '3.6' - '3.7' - - '3.8' - '3.9' + - '3.10' bla_vendor: [ 'unset' ] include: - os: 'ubuntu' @@ -143,8 +142,8 @@ jobs: - 'macos' - 'windows' python: - - '3.6' - '3.9' + - '3.10' steps: - name: Checkout Slycot From 94465103f6768d8c6ac659e32760559ccbd67a5f Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 10 Nov 2021 00:31:03 +0100 Subject: [PATCH 273/405] update setup.py: remove Py 3.6, add 3.10 --- setup.py | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/setup.py b/setup.py index 652ae691..1f7f6707 100644 --- a/setup.py +++ b/setup.py @@ -23,9 +23,6 @@ except ImportError: raise ImportError('scikit-build must be installed before running setup.py') -if sys.version_info[0:2] < (3, 6): - raise RuntimeError("Python version >= 3.6 required.") - DOCLINES = __doc__.split("\n") CLASSIFIERS = """\ @@ -37,10 +34,10 @@ Programming Language :: C Programming Language :: Fortran Programming Language :: Python -Programming Language :: Python :: 3.6 Programming Language :: Python :: 3.7 Programming Language :: Python :: 3.8 Programming Language :: Python :: 3.9 +Programming Language :: Python :: 3.10 Topic :: Software Development Topic :: Scientific/Engineering Operating System :: Microsoft :: Windows @@ -243,6 +240,7 @@ def setup_package(): '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7]], zip_safe=False, install_requires=['numpy'], + python_requires=">=3.7" ) try: From 6ca219d7a5da00557519882dcb148273d38bd621 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Fri, 19 Nov 2021 13:48:02 +0100 Subject: [PATCH 274/405] mirror conda-forge: require flang >= 11 due to conda packaging errors --- conda-recipe/meta.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 832dffed..9ae18828 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -14,7 +14,7 @@ requirements: - {{ compiler('fortran') }} # [not win] - {{ compiler('c') }} - cmake - - flang # [win] + - flang >=11 # [win] host: # Always build against NETLIB ('Generic') LAPACK/Blas From f239c5681c98a4fd444a1d6f79bb0643b89524fa Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 10 Nov 2021 00:52:40 +0100 Subject: [PATCH 275/405] conda is not ready for py 3.10 yet --- .github/workflows/slycot-build-and-test.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index ef92ddcd..65cbb1b0 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -143,7 +143,6 @@ jobs: - 'windows' python: - '3.9' - - '3.10' steps: - name: Checkout Slycot From 364a54483307a71e11e59bc2eee324e8ac56217e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Fri, 19 Nov 2021 15:43:20 +0100 Subject: [PATCH 276/405] enable python3.10 for conda testing --- .github/workflows/slycot-build-and-test.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 65cbb1b0..ef92ddcd 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -143,6 +143,7 @@ jobs: - 'windows' python: - '3.9' + - '3.10' steps: - name: Checkout Slycot From 3ac264c5e0428521d3b3d7a214722db29bf92f9b Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 29 Dec 2021 23:30:50 +0100 Subject: [PATCH 277/405] Mirror conda-forge feedstock: require make --- conda-recipe/meta.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 9ae18828..ada3382d 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -14,6 +14,7 @@ requirements: - {{ compiler('fortran') }} # [not win] - {{ compiler('c') }} - cmake + - make # [linux] - flang >=11 # [win] host: From ebf243e3e80f5446a583c84ba504ffb37c2cdd4b Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 6 Jan 2022 00:37:52 +0100 Subject: [PATCH 278/405] add depend --- slycot/src/math.pyf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index 8cc06ace..34eeedfe 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -18,9 +18,9 @@ subroutine mb03rd(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,inf integer intent(in),required,check(n>=0) :: n double precision intent(in),required,check(pmax>=1.0) :: pmax double precision intent(in,out,copy),dimension(lda,n),depend(n) :: a - integer intent(hide),check(lda>=max(1,n)) :: lda=shape(a,0) + integer intent(hide),check(lda>=max(1,n)),depend(a) :: lda=shape(a,0) double precision intent(in,out,copy),dimension(ldx,n),depend(n) :: x - integer intent(hide),check((*jobx == 'N' && ldx>=1) || (*jobx == 'U' && ldx >= max(1,n))) :: ldx=shape(x,0) + integer intent(hide),check((*jobx == 'N' && ldx>=1) || (*jobx == 'U' && ldx >= max(1,n))),depend(x) :: ldx=shape(x,0) integer intent(out) :: nblcks integer intent(out),dimension(n) :: blsize double precision intent(out),dimension(n) :: wr From ed171ccf670a260b82ecf0d47bb1c9e46015cc46 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 6 Jan 2022 01:02:30 +0100 Subject: [PATCH 279/405] more shapes --- slycot/src/analysis.pyf | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 3b36aeb3..44afec27 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -116,13 +116,13 @@ subroutine ab08nd(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkr integer intent(in),check(m>=0),required :: m integer intent(in),check(p>=0),required :: p double precision intent(in),dimension(lda,*),check(shape(a,1)>=n) :: a - integer intent(hide),check(lda>=max(1,n)) :: lda=shape(a,0) + integer intent(hide),check(lda>=max(1,n)),depend(n,a) :: lda=shape(a,0) double precision intent(in),dimension(ldb,*),check(shape(b,1)>=m) :: b - integer intent(hide),check(ldb>=max(1,n)) :: ldb=shape(b,0) + integer intent(hide),check(ldb>=max(1,n)),depend(n,b) :: ldb=shape(b,0) double precision intent(in),dimension(ldc,*),check(shape(c,1)>=n) :: c - integer intent(hide),check(ldc>=max(1,p)) :: ldc=shape(c,0) + integer intent(hide),check(ldc>=max(1,p)),depend(p,c) :: ldc=shape(c,0) double precision intent(in),dimension(ldd,*),check(shape(d,1)>=m) :: d - integer intent(hide),check(ldd>=max(1,p)) :: ldd=shape(d,0) + integer intent(hide),check(ldd>=max(1,p)),depend(p,d) :: ldd=shape(d,0) integer intent(out) :: nu integer intent(out) :: rank_bn integer intent(out) :: dinfz @@ -147,13 +147,13 @@ subroutine ab08nz(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkr integer intent(in),check(m>=0),required :: m integer intent(in),check(p>=0),required :: p complex*16 intent(in),dimension(lda,*),check(shape(a,1)>=n) :: a - integer intent(hide),check(lda>=max(1,n)) :: lda=shape(a,0) + integer intent(hide),check(lda>=max(1,n)),depend(n,a) :: lda=shape(a,0) complex*16 intent(in),dimension(ldb,*),check(shape(b,1)>=m) :: b - integer intent(hide),check(ldb>=max(1,n)) :: ldb=shape(b,0) + integer intent(hide),check(ldb>=max(1,n)),depend(n,b) :: ldb=shape(b,0) complex*16 intent(in),dimension(ldc,*),check(shape(c,1)>=n) :: c - integer intent(hide),check(ldc>=max(1,p)) :: ldc=shape(c,0) + integer intent(hide),check(ldc>=max(1,p)),depend(p,c) :: ldc=shape(c,0) complex*16 intent(in),dimension(ldd,*),check(shape(d,1)>=m) :: d - integer intent(hide),check(ldd>=max(1,p)) :: ldd=shape(d,0) + integer intent(hide),check(ldd>=max(1,p)),depend(p,d) :: ldd=shape(d,0) integer intent(out) :: nu integer intent(out) :: rank_bn integer intent(out) :: dinfz @@ -163,9 +163,9 @@ subroutine ab08nz(equil,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nu,rank_bn,dinfz,nkror,nkr integer intent(out),dimension(max(n,m)+1) :: kronr integer intent(out),dimension(max(n,p)+1) :: kronl complex*16 intent(out),dimension(max(1,n+m),n+min(p,m)) :: af - integer intent(hide),check(ldaf>=max(1,n+m)) :: ldaf=shape(af,0) + integer intent(hide),check(ldaf>=max(1,n+m)),depend(n,p,af) :: ldaf=shape(af,0) complex*16 intent(out),dimension(max(1,n+p),n+m) :: bf - integer intent(hide),check(ldbf>=max(1,n+p)) :: ldbf=shape(bf,0) + integer intent(hide),check(ldbf>=max(1,n+p)),depend(n,p,bf) :: ldbf=shape(bf,0) double precision intent(in) :: tol = 0.0 integer intent(hide),cache,dimension(max(m,p)) :: iwork double precision intent(hide),cache,dimension(max(n,2*max(p,m))) :: dwork From c1dc25ac69f4a7f3c84e9dd9540800031b53e8ee Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 6 Jan 2022 01:02:43 +0100 Subject: [PATCH 280/405] more shapes in math --- slycot/src/math.pyf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index 34eeedfe..7dc53ff9 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -18,9 +18,9 @@ subroutine mb03rd(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,inf integer intent(in),required,check(n>=0) :: n double precision intent(in),required,check(pmax>=1.0) :: pmax double precision intent(in,out,copy),dimension(lda,n),depend(n) :: a - integer intent(hide),check(lda>=max(1,n)),depend(a) :: lda=shape(a,0) + integer intent(hide),check(lda>=max(1,n)),depend(a,n) :: lda=shape(a,0) double precision intent(in,out,copy),dimension(ldx,n),depend(n) :: x - integer intent(hide),check((*jobx == 'N' && ldx>=1) || (*jobx == 'U' && ldx >= max(1,n))),depend(x) :: ldx=shape(x,0) + integer intent(hide),check((*jobx == 'N' && ldx>=1) || (*jobx == 'U' && ldx >= max(1,n))),depend(x,n,jobx) :: ldx=shape(x,0) integer intent(out) :: nblcks integer intent(out),dimension(n) :: blsize double precision intent(out),dimension(n) :: wr From f78257eeb19b6585daa6470ba124516fedec26cc Mon Sep 17 00:00:00 2001 From: "Art J. R. Pelling" Date: Wed, 5 Jan 2022 15:46:30 +0100 Subject: [PATCH 281/405] increase ldwork for dico=='D' --- slycot/synthesis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index c232c5ce..f2117bb3 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -788,7 +788,7 @@ def sb03md57(A, U=None, C=None, if C is None: C = _np.zeros((n, n)) if ldwork is None: - ldwork = max(2*n*n, 3*n) + ldwork = max(2*n*n, 3*n) if dico == 'C' else 2*n*n + 2*n if dico != 'C' and dico != 'D': raise SlycotParameterError('dico must be either D or C', -1) out = _wrapper.sb03md(dico, n, A, U, C, From 76f76a4cd4d6e1a2ed04fb434a027f1c8bed18c6 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 30 Apr 2022 12:47:37 +0200 Subject: [PATCH 282/405] Change mode of slycot/tests/test_ab01.py (-x) --- slycot/tests/test_ab01.py | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 slycot/tests/test_ab01.py diff --git a/slycot/tests/test_ab01.py b/slycot/tests/test_ab01.py old mode 100755 new mode 100644 From 14ae201a3b6f150190c7bbf19852ddae018abd0b Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 10:16:31 +0200 Subject: [PATCH 283/405] ENH: add wrapper for AB13MD, structured singular value upper bound --- slycot/analysis.py | 113 +++++++++++++++++++++++++++++ slycot/src/analysis.pyf | 19 +++++ slycot/tests/test_ab13md.py | 139 ++++++++++++++++++++++++++++++++++++ 3 files changed, 271 insertions(+) create mode 100644 slycot/tests/test_ab13md.py diff --git a/slycot/analysis.py b/slycot/analysis.py index 6073c013..077d3c39 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -17,6 +17,8 @@ # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, # MA 02110-1301, USA. +import numpy as np + from . import _wrapper from .exceptions import raise_if_slycot_error, SlycotParameterError @@ -1628,7 +1630,118 @@ def ab13fd(n, A, tol = 0.0): raise_if_slycot_error(out[-1], arg_list, ab13fd.__doc__) return out[0], out[1] + +def ab13md(n, Z, nblock, itype, x=None): + """mubound, d, g, xout = ab13md(n, Z, nblock, itype, [x]) + + Find an upper bound for the structured singular value of complex + matrix Z and given block diagonal structure. + + Parameters + ---------- + n : integer + Order of Z; n=Z.shape[0]. + + Z : (n,n) complex array + Matrix to find structured singular value upper bound of + + nblock : (m,) integer array + The size of the block diagonals of the uncertainty structure; + i.e., nblock(i)=p means that the ith block is pxp. + + itype : (m,) integer array + The type of each block diagonal uncertainty defined in nblock. + itype(i)==1 means that the ith block is real, while itype(i)==2 + means the the ith block is complex. Real blocks must be 1x1, + i.e., if itype(i)==1, ntype(i) must be 1. + + x : (q,) real array or None + If not None, must be the output of a previous call to ab13md. + The previous call must have been with the same values of n, + nblock, and itype; and the previous call's Z should be "close" + to the current call's Z. + + q is determined by the block structure; see SLICOT AB13MD for + details. + + Returns + ------- + mubound : non-negative real scalar + Upper bound on structure singular value for given arguments + + d, g : (n,) real arrays + Real arrays such that if D=np.diag(g), G=np.diag(G), and ZH = Z.T.conj(), then + ZH @ D**2 @ Z + 1j * (G@Z - ZH@G) - mu**2 * D**2 + will be negative semi-definite. + + xout : (q,) real array + For use as ``x`` argument in subsequent call to ``ab13md``. + + For scalar Z and real uncertainty (ntype=1, itype=1), returns 0 + instead of abs(Z). + + Raises + ------ + SlycotArithmeticError + :info = 1: Block sizes must be positive + :info = 2: Block sizes must sum to n + :info = 3: Real blocks must be of size 1 + :info = 4: Block types must be 1 or 2 + :info = 5: Error in linear equation solution + :info = 6: Error in eigenvalue or singular value computation + + Notes + ----- + This wraps SLICOT routine AB13MD, which implements the upper bound + of [1]. + + References + ---------- + .. [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C., "Robustness in + the presence of mixed parametric uncertainty and unmodeled + dynamics," IEEE Trans. Automatic Control, vol. AC-36, 1991, + pp. 25-38. + + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['fact' + hidden, 'n' + hidden, 'z', 'ldz' + hidden, + 'm' + hidden, 'nblock', 'itype', 'x', 'bound', 'd', 'g', + 'iwork' + hidden, 'dwork' + hidden, 'ldwork' + hidden, + 'zwork' + hidden, 'lzwork' + hidden, 'info' + hidden] + + # prepare the "x" input and output + + # x, in SLICOT, needs to be length m+mr-1. m is the length of + # nblock (and itype), and mr is the number of real blocks. + + # In analysis.pyf x is specified as length 2*m-1, since I couldn't + # figure out how to express the m+mr-1 constraint there. + + # The code here is to arrange for the user-visible part of x, + # which is length m+mr-1, to be packed into the 2*m-1-length array + # to pass the SLICOT routine. + + m = len(nblock) + mr = np.count_nonzero(1==itype) + + if x is None: + fact='N' + x = np.empty(2*m-1) + else: + fact='F' + if len(x) != m+mr-1: + raise ValueError(f'Require len(x)==m+mr-1, but {len(x)=}, {m=}, {mr=}') + x = np.concatenate([x,np.zeros(2*m-1-len(x))]) + + x, bound, d, g, info = _wrapper.ab13md(fact, n, Z, nblock, itype, x) + + raise_if_slycot_error(info, arg_list, ab13md.__doc__) + + return bound, d, g, x[:m+mr-1] + + def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): + """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) To extract from the system pencil diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 44afec27..c1a8774c 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -351,6 +351,25 @@ subroutine ab13dd(dico,jobe,equil,jobd,n,m,p,fpeak,a,lda,e,lde,b,ldb,c,ldc,d,ldd integer intent(hide),depend(n,m,p) :: lcwork = max(1,(n+m)*(n+p)+2*min(p,m)+max(p,m)) integer intent(out) :: info end subroutine ab13dd +subroutine ab13md(fact, n, z, ldz, m, nblock, itype, x, bound, d, g, iwork, dwork, ldwork, zwork, lzwork, info ) ! in AB13MD.f + character intent(in) :: fact + integer check(n>=0) :: n + complex*16 intent(in),dimension(n,n),depend(n) :: z + integer intent(hide),depend(z) :: ldz = shape(z,0) + integer intent(required, in) :: m + integer intent(in),dimension(m),depend(m) :: nblock + integer intent(in),dimension(m),depend(m) :: itype + double precision intent(in,out),dimension(2*m-1) :: x ! dim m+mr-1; mr<=m + double precision intent(out) :: bound + double precision intent(out),dimension(n),depend(n) :: d + double precision intent(out),dimension(n),depend(n) :: g + integer intent(hide,cache),dimension(max(4*m-2,n)),depend(m,n) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork + integer intent(hide,in) :: ldwork=2*n*n*m - n*n + 9*m*m + n*m + 11*n + 33*m - 11 + complex*16 intent(hide,cache),dimension(lzwork) :: zwork + integer intent(hide,in),depend(n,m) :: lzwork=6*n*n*m + 12*n*n + 6*m + 6*n - 3 + integer intent(out) :: info +end subroutine ab13dd subroutine ab13ed(n,a,lda,low,high,tol,dwork,ldwork,info) ! in AB13ED.f integer check(n>=0) :: n double precision dimension(n,n),depend(n) :: a diff --git a/slycot/tests/test_ab13md.py b/slycot/tests/test_ab13md.py new file mode 100644 index 00000000..0a98a8bc --- /dev/null +++ b/slycot/tests/test_ab13md.py @@ -0,0 +1,139 @@ +import numpy as np +from numpy.testing import assert_allclose, assert_array_less + +import pytest + +from slycot.analysis import ab13md + +# References: +# [1] Skogestand & Postlethwaite, Multivariable Feedback Control, 1996 +# [2] slycot/src/SLICOT-Reference/examples + +def slicot_example(): + # [2] AB13MD.dat & TAB13MD.f + n = 6 + nblock = np.array([1, 1, 2, 1, 1]) + itype = np.array([1, 1, 2, 2, 2]) + # this unpleasant looking array is the result of text editor + # search-and-replace on the Z array in AB13MD.dat + Z = np.array([ + complex(-1.0e0,6.0e0), complex(2.0e0,-3.0e0), complex(3.0e0,8.0e0), + complex(3.0e0,8.0e0), complex(-5.0e0,-9.0e0), complex(-6.0e0,2.0e0), + complex(4.0e0,2.0e0), complex(-2.0e0,5.0e0), complex(-6.0e0,-7.0e0), + complex(-4.0e0,11.0e0), complex(8.0e0,-7.0e0), complex(12.0e0,-1.0e0), + complex(5.0e0,-4.0e0), complex(-4.0e0,-8.0e0), complex(1.0e0,-3.0e0), + complex(-6.0e0,14.0e0), complex(2.0e0,-5.0e0), complex(4.0e0,16.0e0), + complex(-1.0e0,6.0e0), complex(2.0e0,-3.0e0), complex(3.0e0,8.0e0), + complex(3.0e0,8.0e0), complex(-5.0e0,-9.0e0), complex(-6.0e0,2.0e0), + complex(4.0e0,2.0e0), complex(-2.0e0,5.0e0), complex(-6.0e0,-7.0e0), + complex(-4.0e0,11.0e0), complex(8.0e0,-7.0e0), complex(12.0e0,-1.0e0), + complex(5.0e0,-4.0e0), complex(-4.0e0,-8.0e0), complex(1.0e0,-3.0e0), + complex(-6.0e0,14.0e0), complex(2.0e0,-5.0e0), complex(4.0e0,16.0e0), + ]) + Z = np.reshape(Z, (n, n)) + return n, Z, nblock, itype + + +def test_cached_inputoutput(): + # check x, cached working area, input and output, and error + n, Z, nblock, itype = slicot_example() + + m = len(nblock) + mr = np.count_nonzero(1==itype) + + mu0, d0, g0, x0 = ab13md(n, Z, nblock, itype) + assert m+mr-1 == len(x0) + + mu1, d1, g1, x1 = ab13md(n, Z, nblock, itype, x0) + + assert_allclose(mu1, mu0) + + with pytest.raises(ValueError): + mu0, d, g, x = ab13md(n, Z, nblock, itype, np.ones(mr+mr)) + + +class TestReference: + # check a few reference cases + def test_complex_scalar(self): + # [1] (8.74) + n = 1 + nblock = np.array([1]) + itype = np.array([2]) # complex + + z = np.array([[1+2j]]) + mu = ab13md(n,z,nblock,itype)[0] + assert_allclose(mu, abs(z)) + + + @pytest.mark.xfail(reason="https://github.com/SLICOT/SLICOT-Reference/issues/4") + def test_real_scalar_real_uncertainty(self): + # [1] (8.75) + n=1 + nblock=np.array([1]) + itype=np.array([1]) # real + z = np.array([[5.34]]) + mu = ab13md(n,z,nblock,itype)[0] + assert_allclose(mu, abs(z)) + + + def test_complex_scalar_real_uncertainty(self): + # [1] (8.75) + n=1 + nblock=np.array([1]) + itype=np.array([1]) # real + + z = np.array([[6.78j]]) + mu = ab13md(n,z,nblock,itype)[0] + assert_allclose(mu, 0) + + + def test_sp85_part1(self): + # [1] Example 8.5 part 1, unstructured uncertainty + M = np.array([[2, 2], [-1, -1]]) + muref = 3.162 + + n = M.shape[0] + nblock=np.array([2]) + itype=np.array([2]) + + mu = ab13md(n, M, nblock, itype)[0] + assert_allclose(mu, muref, rtol=5e-4) + + + def test_sp85_part2(self): + # [1] Example 8.5 part 2, structured uncertainty + M = np.array([[2, 2], [-1, -1]]) + muref = 3.000 + + n = M.shape[0] + nblock=np.array([1, 1]) + itype=np.array([2, 2]) + + mu = ab13md(n, M, nblock, itype)[0] + assert_allclose(mu, muref, rtol=5e-4) + + def test_slicot(self): + # besides muref, check that we've output d and g correctly + + muref = 0.4174753408e+02 # [2] AB13MD.res + + n, Z, nblock, itype = slicot_example() + + mu, d, g, x = ab13md(n, Z, nblock, itype) + + assert_allclose(mu, muref) + + ZH = Z.T.conj() + D = np.diag(d) + G = np.diag(g) + + # this matrix should be negative semi-definite + negsemidef = (ZH @ D**2 @ Z + + 1j * (G@Z - ZH@G) + - mu**2 * D**2) + + # a check on the algebra, not ab13md! + assert_allclose(negsemidef, negsemidef.T.conj()) + + evals = np.linalg.eigvalsh(negsemidef) + assert max(evals) < np.finfo(float).eps**0.5 From dd8c738d0544ccd736d2bf51d3436ade88a67326 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 11:44:11 +0200 Subject: [PATCH 284/405] Import ab13md into top-level Slycot namespace --- slycot/__init__.py | 2 +- slycot/tests/test_ab13md.py | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 0fcbd3fd..836c8a51 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -15,7 +15,7 @@ # Analysis routines (15/40 wrapped) from .analysis import ab01nd, ab05md, ab05nd, ab07nd, ab08nd, ab08nz from .analysis import ab09ad, ab09ax, ab09bd, ab09md, ab09nd - from .analysis import ab13bd, ab13dd, ab13ed, ab13fd + from .analysis import ab13bd, ab13dd, ab13ed, ab13fd, ab13md # Data analysis routines (0/7 wrapped) diff --git a/slycot/tests/test_ab13md.py b/slycot/tests/test_ab13md.py index 0a98a8bc..86a9eadf 100644 --- a/slycot/tests/test_ab13md.py +++ b/slycot/tests/test_ab13md.py @@ -3,7 +3,7 @@ import pytest -from slycot.analysis import ab13md +from slycot import ab13md # References: # [1] Skogestand & Postlethwaite, Multivariable Feedback Control, 1996 From 05849a09e07ce90c0d3de978df1c1c4cb950245c Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 11:44:58 +0200 Subject: [PATCH 285/405] Make f-string Python 3.7 compatible --- slycot/analysis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 077d3c39..7e898cec 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1730,7 +1730,7 @@ def ab13md(n, Z, nblock, itype, x=None): else: fact='F' if len(x) != m+mr-1: - raise ValueError(f'Require len(x)==m+mr-1, but {len(x)=}, {m=}, {mr=}') + raise ValueError(f'Require len(x)==m+mr-1, but len(x)={len(x)}, m={m}, mr={mr}') x = np.concatenate([x,np.zeros(2*m-1-len(x))]) x, bound, d, g, info = _wrapper.ab13md(fact, n, Z, nblock, itype, x) From 619cfc4aa9ebf0a6ed2ac5a758b967b0173c2bdd Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 13:43:10 +0200 Subject: [PATCH 286/405] In ab13md: infer value of `n`; fix hidden qualifier Make n a hidden argument for ab13md in analysis.pyf. Remove hidden qualifier for fact, m, and info. --- slycot/analysis.py | 19 +++++++++---------- slycot/src/analysis.pyf | 4 ++-- slycot/tests/test_ab13md.py | 29 ++++++++++++----------------- 3 files changed, 23 insertions(+), 29 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 7e898cec..125a5e24 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1631,17 +1631,14 @@ def ab13fd(n, A, tol = 0.0): return out[0], out[1] -def ab13md(n, Z, nblock, itype, x=None): - """mubound, d, g, xout = ab13md(n, Z, nblock, itype, [x]) +def ab13md(Z, nblock, itype, x=None): + """mubound, d, g, xout = ab13md(Z, nblock, itype, [x]) Find an upper bound for the structured singular value of complex matrix Z and given block diagonal structure. Parameters ---------- - n : integer - Order of Z; n=Z.shape[0]. - Z : (n,n) complex array Matrix to find structured singular value upper bound of @@ -1704,10 +1701,11 @@ def ab13md(n, Z, nblock, itype, x=None): """ hidden = ' (hidden by the wrapper)' - arg_list = ['fact' + hidden, 'n' + hidden, 'z', 'ldz' + hidden, - 'm' + hidden, 'nblock', 'itype', 'x', 'bound', 'd', 'g', + + arg_list = ['fact', 'n' + hidden, 'z', 'ldz' + hidden, 'm', + 'nblock', 'itype', 'x', 'bound', 'd', 'g', 'iwork' + hidden, 'dwork' + hidden, 'ldwork' + hidden, - 'zwork' + hidden, 'lzwork' + hidden, 'info' + hidden] + 'zwork' + hidden, 'lzwork' + hidden, 'info'] # prepare the "x" input and output @@ -1730,10 +1728,11 @@ def ab13md(n, Z, nblock, itype, x=None): else: fact='F' if len(x) != m+mr-1: - raise ValueError(f'Require len(x)==m+mr-1, but len(x)={len(x)}, m={m}, mr={mr}') + raise ValueError(f'Require len(x)==m+mr-1, but' + + f' len(x)={len(x)}, m={m}, mr={mr}') x = np.concatenate([x,np.zeros(2*m-1-len(x))]) - x, bound, d, g, info = _wrapper.ab13md(fact, n, Z, nblock, itype, x) + x, bound, d, g, info = _wrapper.ab13md(fact, Z, nblock, itype, x) raise_if_slycot_error(info, arg_list, ab13md.__doc__) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index c1a8774c..338fe8e7 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -353,8 +353,8 @@ subroutine ab13dd(dico,jobe,equil,jobd,n,m,p,fpeak,a,lda,e,lde,b,ldb,c,ldc,d,ldd end subroutine ab13dd subroutine ab13md(fact, n, z, ldz, m, nblock, itype, x, bound, d, g, iwork, dwork, ldwork, zwork, lzwork, info ) ! in AB13MD.f character intent(in) :: fact - integer check(n>=0) :: n - complex*16 intent(in),dimension(n,n),depend(n) :: z + integer intent(in,hide),check(n>=0) :: n = shape(z,0) + complex*16 intent(in),dimension(n,n) :: z integer intent(hide),depend(z) :: ldz = shape(z,0) integer intent(required, in) :: m integer intent(in),dimension(m),depend(m) :: nblock diff --git a/slycot/tests/test_ab13md.py b/slycot/tests/test_ab13md.py index 86a9eadf..48f71388 100644 --- a/slycot/tests/test_ab13md.py +++ b/slycot/tests/test_ab13md.py @@ -31,59 +31,56 @@ def slicot_example(): complex(-6.0e0,14.0e0), complex(2.0e0,-5.0e0), complex(4.0e0,16.0e0), ]) Z = np.reshape(Z, (n, n)) - return n, Z, nblock, itype + return Z, nblock, itype def test_cached_inputoutput(): # check x, cached working area, input and output, and error - n, Z, nblock, itype = slicot_example() + Z, nblock, itype = slicot_example() m = len(nblock) mr = np.count_nonzero(1==itype) - mu0, d0, g0, x0 = ab13md(n, Z, nblock, itype) + mu0, d0, g0, x0 = ab13md(Z, nblock, itype) assert m+mr-1 == len(x0) - mu1, d1, g1, x1 = ab13md(n, Z, nblock, itype, x0) + mu1, d1, g1, x1 = ab13md(Z, nblock, itype, x0) assert_allclose(mu1, mu0) with pytest.raises(ValueError): - mu0, d, g, x = ab13md(n, Z, nblock, itype, np.ones(mr+mr)) + mu0, d, g, x = ab13md(Z, nblock, itype, np.ones(mr+mr)) class TestReference: # check a few reference cases def test_complex_scalar(self): # [1] (8.74) - n = 1 nblock = np.array([1]) itype = np.array([2]) # complex z = np.array([[1+2j]]) - mu = ab13md(n,z,nblock,itype)[0] + mu = ab13md(z,nblock,itype)[0] assert_allclose(mu, abs(z)) @pytest.mark.xfail(reason="https://github.com/SLICOT/SLICOT-Reference/issues/4") def test_real_scalar_real_uncertainty(self): # [1] (8.75) - n=1 nblock=np.array([1]) itype=np.array([1]) # real z = np.array([[5.34]]) - mu = ab13md(n,z,nblock,itype)[0] + mu = ab13md(z,nblock,itype)[0] assert_allclose(mu, abs(z)) def test_complex_scalar_real_uncertainty(self): # [1] (8.75) - n=1 nblock=np.array([1]) itype=np.array([1]) # real z = np.array([[6.78j]]) - mu = ab13md(n,z,nblock,itype)[0] + mu = ab13md(z,nblock,itype)[0] assert_allclose(mu, 0) @@ -92,11 +89,10 @@ def test_sp85_part1(self): M = np.array([[2, 2], [-1, -1]]) muref = 3.162 - n = M.shape[0] nblock=np.array([2]) itype=np.array([2]) - mu = ab13md(n, M, nblock, itype)[0] + mu = ab13md(M, nblock, itype)[0] assert_allclose(mu, muref, rtol=5e-4) @@ -105,11 +101,10 @@ def test_sp85_part2(self): M = np.array([[2, 2], [-1, -1]]) muref = 3.000 - n = M.shape[0] nblock=np.array([1, 1]) itype=np.array([2, 2]) - mu = ab13md(n, M, nblock, itype)[0] + mu = ab13md(M, nblock, itype)[0] assert_allclose(mu, muref, rtol=5e-4) def test_slicot(self): @@ -117,9 +112,9 @@ def test_slicot(self): muref = 0.4174753408e+02 # [2] AB13MD.res - n, Z, nblock, itype = slicot_example() + Z, nblock, itype = slicot_example() - mu, d, g, x = ab13md(n, Z, nblock, itype) + mu, d, g, x = ab13md(Z, nblock, itype) assert_allclose(mu, muref) From f0b134ee362f895d817779d912ea51f66af92de0 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 15:49:09 +0200 Subject: [PATCH 287/405] Remove erroneously added newline Co-authored-by: Ben Greiner --- slycot/analysis.py | 1 - 1 file changed, 1 deletion(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 125a5e24..6ce40722 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1740,7 +1740,6 @@ def ab13md(Z, nblock, itype, x=None): def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): - """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) To extract from the system pencil From 6c3b70015da7af331c3cceb4d1112e6d35aaf7c4 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 15:49:38 +0200 Subject: [PATCH 288/405] Correct ab13md docstring for itype and nblock Co-authored-by: Ben Greiner --- slycot/analysis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 6ce40722..c466537f 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1650,7 +1650,7 @@ def ab13md(Z, nblock, itype, x=None): The type of each block diagonal uncertainty defined in nblock. itype(i)==1 means that the ith block is real, while itype(i)==2 means the the ith block is complex. Real blocks must be 1x1, - i.e., if itype(i)==1, ntype(i) must be 1. + i.e., if itype(i)==1, nblock(i) must be 1. x : (q,) real array or None If not None, must be the output of a previous call to ab13md. From a1d4ee56e817c010f1707dd1886be9c5dc18cd7f Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 1 May 2022 16:48:36 +0200 Subject: [PATCH 289/405] Hide ab13md parameter m --- slycot/analysis.py | 2 +- slycot/src/analysis.pyf | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index c466537f..32050236 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1702,7 +1702,7 @@ def ab13md(Z, nblock, itype, x=None): """ hidden = ' (hidden by the wrapper)' - arg_list = ['fact', 'n' + hidden, 'z', 'ldz' + hidden, 'm', + arg_list = ['fact', 'n' + hidden, 'z', 'ldz' + hidden, 'm' + hidden, 'nblock', 'itype', 'x', 'bound', 'd', 'g', 'iwork' + hidden, 'dwork' + hidden, 'ldwork' + hidden, 'zwork' + hidden, 'lzwork' + hidden, 'info'] diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 338fe8e7..633ff6ec 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -356,9 +356,9 @@ subroutine ab13md(fact, n, z, ldz, m, nblock, itype, x, bound, d, g, iwork, dwor integer intent(in,hide),check(n>=0) :: n = shape(z,0) complex*16 intent(in),dimension(n,n) :: z integer intent(hide),depend(z) :: ldz = shape(z,0) - integer intent(required, in) :: m - integer intent(in),dimension(m),depend(m) :: nblock - integer intent(in),dimension(m),depend(m) :: itype + integer intent(hide, in), depend(nblock) :: m = len(nblock) + integer intent(in),dimension(m) :: nblock + integer intent(in),dimension(m), depend(m) :: itype double precision intent(in,out),dimension(2*m-1) :: x ! dim m+mr-1; mr<=m double precision intent(out) :: bound double precision intent(out),dimension(n),depend(n) :: d From 0e7387bb45c554553d59abbb850744efbddb377b Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 3 May 2022 17:21:10 +0200 Subject: [PATCH 290/405] Replace setup.py calls with pip (except Windows) --- .github/workflows/slycot-build-and-test.yml | 18 ++++---- README.rst | 49 +++++++++++---------- conda-recipe/bld.bat | 1 + conda-recipe/build.sh | 12 +---- conda-recipe/meta.yaml | 3 +- pyproject.toml | 8 +++- 6 files changed, 47 insertions(+), 44 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index ef92ddcd..b5a0a19d 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -12,7 +12,7 @@ on: jobs: - build-setup: + build-sdist: # Super fast sniff build. If this fails, don't start the other jobs name: Build sdist on Ubuntu runs-on: ubuntu-latest @@ -30,24 +30,26 @@ jobs: run: | sudo apt-get -y install gfortran cmake --fix-missing sudo apt-get -y install libblas-dev liblapack-dev - pip install scikit-build numpy scipy pytest - name: Create Slycot sdist - run: python setup.py sdist - + run: | + pip install build + python -m build --sdist - name: Install Slycot sdist run: | mkdir cleancwd cd cleancwd tar xfz ../dist/slycot-*.tar.gz cd slycot-* - python setup.py install + pip install -v . - name: Run tests - run: pytest + run: | + pip install scipy pytest + pytest build-pip: name: Build pip Py${{ matrix.python }}, ${{ matrix.os }}, ${{ matrix.bla_vendor}} BLA_VENDOR runs-on: ${{ matrix.os }}-latest - needs: build-setup + needs: build-sdist strategy: fail-fast: false matrix: @@ -133,7 +135,7 @@ jobs: build-conda: name: Build conda Py${{ matrix.python }}, ${{ matrix.os }} runs-on: ${{ matrix.os }}-latest - needs: build-setup + needs: build-sdist strategy: fail-fast: false matrix: diff --git a/README.rst b/README.rst index 6003eaed..1dcde8bc 100644 --- a/README.rst +++ b/README.rst @@ -32,7 +32,7 @@ following dependencies: - 3.6+ - NumPy -- scikit-build >= 0.10.0 +- scikit-build - CMake - C compiler (e.g. gcc, MS Visual C++, clang) - FORTRAN compiler (e.g. gfortran, ifort, flang) @@ -70,11 +70,27 @@ The hardest part about installing from source is getting a working version of FORTRAN and LAPACK (provided by OpenBLAS, MKL, etc.) installed on your system. Depending on where you get your NumPy and SciPy from, you will need to use a compatible LAPACK implementation. Make sure that -the correct header files are installed, and specify the environment variable -`BLA_VENDOR`_, if necessary. +the correct header files are installed, and specify the CMake variable +`BLA_VENDOR`_, if necessary. We recommend to use `BLA_VENDOR=Generic` in order +to produce a Slycot module, which is binary compatible with all implementations. .. _BLA_VENDOR: https://cmake.org/cmake/help/latest/module/FindBLAS.html#input-variables +Compiling the PyPI source with pip +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We publish Slycot to the Python package index, but only as a source +package, so to install using pip you'll first need to install the +build prerequisites (compilers, libraries, etc.) + +If you have these build prerequisites, the command:: + + pip install slycot + +will download the latest release of the source code from `PyPI`_, compile, and +install Slycot into the currently configured location (virtual environment or +user site-packages). + Getting the full source code ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -120,8 +136,8 @@ If you already have a local checkout, but still need to init the submodule:: git submodule init git submodule update -Compiling with setuptools (Linux, macOS, Windows) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Compiling the source (Linux, macOS, Windows) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you need to specify a specific compiler, set the environment variable FC before running the install:: @@ -135,7 +151,7 @@ before running the install:: To build and install, execute:: cd /path/to/slycot_src/ - python setup.py install + pip install -v . Using the conda recipe ~~~~~~~~~~~~~~~~~~~~~~ @@ -166,8 +182,8 @@ To build and install:: conda build -c conda-forge conda-recipe conda install -c conda-forge --use-local slycot -With setuptools in a conda environment (Windows) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Building from source manually in a conda environment (Windows) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A similar method can be used for Linux and macOS, but is detailed here for Windows. This method uses conda and conda-forge to get most build @@ -186,22 +202,7 @@ This procedure has been tested on Python 3.7 and 3.8. conda create --channel conda-forge --name build-slycot python=3.8 numpy scipy libblas=*=*netlib liblapack=*=*netlib scikit-build flang pytest conda activate build-slycot - python setup.py install - -Using pip -~~~~~~~~~ - -We publish Slycot to the Python package index, but only as a source -package, so to install using pip you'll first need to install the -build prerequisites (compilers, libraries, etc.) - -If you have these build prerequisites, the command:: - - pip install slycot - -will download the latest release of the source code from `PyPI`_, compile, and -install Slycot into the currently configured location (virtual environment or -user site-packages). + pip install -v . Additional hints ~~~~~~~~~~~~~~~~ diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 6f2397c6..23ccedcc 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -1,6 +1,7 @@ set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% +# Keep deprecated setup.py install for now https://github.com/scikit-build/scikit-build/issues/705 "%PYTHON%" setup.py install -G "NMake Makefiles" -DBLA_VENDOR=Generic if errorlevel 1 exit 1 diff --git a/conda-recipe/build.sh b/conda-recipe/build.sh index 1e72fa01..fbc8a26e 100644 --- a/conda-recipe/build.sh +++ b/conda-recipe/build.sh @@ -2,13 +2,5 @@ rm -rf _skbuild rm -rf _cmake_test_compile -export LDFLAGS="$LDFLAGS -v" -if [[ "$target_platform" == osx-64 ]]; then - export LDFLAGS="${LDFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" - export CFLAGS="${CFLAGS} -isysroot ${CONDA_BUILD_SYSROOT}" - export CMAKE_OSX_SYSROOT=${CONDA_BUILD_SYSROOT} -fi - -# Always build against netlib implementation -# https://conda-forge.org/docs/maintainer/knowledge_base.html#blas -$PYTHON setup.py build_ext install -DBLA_VENDOR=Generic +export SKBUILD_CONFIGURE_OPTIONS="-DBLA_VENDOR=Generic" +$PYTHON -m pip install -v . diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index ada3382d..55314c06 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -28,7 +28,8 @@ requirements: - liblapack * *netlib - python - numpy - - scikit-build >=0.10.0 + - pip + - scikit-build >=0.14.1 run: - python {{ PY_VER }} diff --git a/pyproject.toml b/pyproject.toml index 3df57213..206a1e60 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -1,2 +1,8 @@ [build-system] -requires = ["setuptools", "wheel", "scikit-build", "cmake", "numpy"] +requires = [ + "setuptools", + "wheel", + "scikit-build>=0.14.1", + "cmake", + "numpy"] +build-backend = "setuptools.build_meta" From 60bc054778da3e73e03a4c6089ab8fa02db837ff Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 3 May 2022 17:21:47 +0200 Subject: [PATCH 291/405] Test pip extra matrix on Py3.10 --- .github/workflows/slycot-build-and-test.yml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index b5a0a19d..400aae6c 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -58,24 +58,23 @@ jobs: - 'macos' python: - '3.7' - - '3.9' - '3.10' bla_vendor: [ 'unset' ] include: - os: 'ubuntu' - python: '3.9' + python: '3.10' bla_vendor: 'Generic' - os: 'ubuntu' - python: '3.9' + python: '3.10' bla_vendor: 'OpenBLAS' - os: 'macos' - python: '3.9' + python: '3.10' bla_vendor: 'Apple' - os: 'macos' - python: '3.9' + python: '3.10' bla_vendor: 'Generic' - os: 'macos' - python: '3.9' + python: '3.10' bla_vendor: 'OpenBLAS' steps: From c23ac277c084055b8a6542d160ed34ff4211fd3d Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 3 May 2022 17:22:05 +0200 Subject: [PATCH 292/405] Use mambaforge --- .github/conda-env/build-env.yml | 4 ++++ .github/workflows/slycot-build-and-test.yml | 21 ++++++++++++--------- 2 files changed, 16 insertions(+), 9 deletions(-) create mode 100644 .github/conda-env/build-env.yml diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml new file mode 100644 index 00000000..f747a77e --- /dev/null +++ b/.github/conda-env/build-env.yml @@ -0,0 +1,4 @@ +name: build-env +dependencies: + - boa + - numpy diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 400aae6c..54367ed2 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -157,7 +157,9 @@ jobs: with: python-version: ${{ matrix.python }} activate-environment: build-env - channels: conda-forge + environment-file: .github/conda-env/build-env.yml + miniforge-version: latest + miniforge-variant: Mambaforge channel-priority: strict auto-update-conda: false auto-activate-base: false @@ -165,9 +167,9 @@ jobs: shell: bash -l {0} run: | set -e - conda install conda-build conda-verify numpy + mamba install boa numpy numpyversion=$(python -c 'import numpy; print(numpy.version.version)') - conda-build --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe + conda mambabuild --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe # preserve directory structure for custom conda channel find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do conda_platform=$(basename $(dirname "${conda_pkg}")) @@ -327,9 +329,10 @@ jobs: uses: conda-incubator/setup-miniconda@v2 with: python-version: ${{ matrix.python }} + miniforge-version: latest + miniforge-variant: Mambaforge activate-environment: test-env environment-file: slycot-src/.github/conda-env/test-env.yml - channels: conda-forge channel-priority: strict auto-activate-base: false - name: Download conda packages @@ -342,23 +345,23 @@ jobs: set -e case ${{ matrix.blas_lib }} in unset ) # the conda-forge default (os dependent) - conda install libblas libcblas liblapack + mamba install libblas libcblas liblapack ;; Generic ) - conda install 'libblas=*=*netlib' 'libcblas=*=*netlib' 'liblapack=*=*netlib' + mamba install 'libblas=*=*netlib' 'libcblas=*=*netlib' 'liblapack=*=*netlib' echo "libblas * *netlib" >> $CONDA_PREFIX/conda-meta/pinned ;; OpenBLAS ) - conda install 'libblas=*=*openblas' openblas + mamba install 'libblas=*=*openblas' openblas echo "libblas * *openblas" >> $CONDA_PREFIX/conda-meta/pinned ;; Intel10_64lp ) - conda install 'libblas=*=*mkl' mkl + mamba install 'libblas=*=*mkl' mkl echo "libblas * *mkl" >> $CONDA_PREFIX/conda-meta/pinned ;; esac conda index --no-progress ./slycot-conda-pkgs - conda install -c ./slycot-conda-pkgs slycot + mamba install -c ./slycot-conda-pkgs slycot conda list - name: Slycot and python-control tests run: bash slycot-src/.github/scripts/run-tests.sh From 7dbcfa65c7d61f692a131e992c0918cdfe4b2d17 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 3 May 2022 20:24:44 +0200 Subject: [PATCH 293/405] windows conda with pip: use CMAKE_GENERATOR --- conda-recipe/bld.bat | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 23ccedcc..4b2811d0 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -1,7 +1,8 @@ set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% -# Keep deprecated setup.py install for now https://github.com/scikit-build/scikit-build/issues/705 -"%PYTHON%" setup.py install -G "NMake Makefiles" -DBLA_VENDOR=Generic +set "SKBUILD_CONFIGURE_OPTIONS=-DBLA_VENDOR=Generic" +set "CMAKE_GENERATOR=NMake Makefiles" +"%PYTHON%" -m pip install -v . if errorlevel 1 exit 1 From 3518e68fdce803e91d8a56069431bb57ead2bc98 Mon Sep 17 00:00:00 2001 From: Benjamin Greiner Date: Sun, 22 May 2022 20:35:45 +0200 Subject: [PATCH 294/405] update SLICOT-Reference submodule to 5.7 plus AB13MD fixes --- slycot/src/SLICOT-Reference | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/SLICOT-Reference b/slycot/src/SLICOT-Reference index 545f32ce..162552c8 160000 --- a/slycot/src/SLICOT-Reference +++ b/slycot/src/SLICOT-Reference @@ -1 +1 @@ -Subproject commit 545f32ce70ce4ef5556c5336b39db93893bb581c +Subproject commit 162552c8783101b0b765b9b039efa328038f311b From 32b48b21401ce96ec7e37fc282cb66728ac56738 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 28 May 2022 10:47:46 +0200 Subject: [PATCH 295/405] Remove xfail on AB13MD scalar real test following #174 --- slycot/tests/test_ab13md.py | 1 - 1 file changed, 1 deletion(-) diff --git a/slycot/tests/test_ab13md.py b/slycot/tests/test_ab13md.py index 48f71388..df69a6b3 100644 --- a/slycot/tests/test_ab13md.py +++ b/slycot/tests/test_ab13md.py @@ -64,7 +64,6 @@ def test_complex_scalar(self): assert_allclose(mu, abs(z)) - @pytest.mark.xfail(reason="https://github.com/SLICOT/SLICOT-Reference/issues/4") def test_real_scalar_real_uncertainty(self): # [1] (8.75) nblock=np.array([1]) From f5cbf0a55d2b39326089cd5de39426d018c251dc Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 29 May 2022 13:36:36 +0200 Subject: [PATCH 296/405] update SLICOT-Reference to v5.8 --- slycot/src/SLICOT-Reference | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/SLICOT-Reference b/slycot/src/SLICOT-Reference index 162552c8..f0d40ee8 160000 --- a/slycot/src/SLICOT-Reference +++ b/slycot/src/SLICOT-Reference @@ -1 +1 @@ -Subproject commit 162552c8783101b0b765b9b039efa328038f311b +Subproject commit f0d40ee80c63e0d2ee71be1e1247be3bdfda5a84 From 08581c48a178c0d8e2756186d5752131560b4a90 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 29 May 2022 14:12:42 +0200 Subject: [PATCH 297/405] Update SLICOT-Reference .f files --- slycot/CMakeLists.txt | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 2276d8b4..f656c326 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -4,7 +4,7 @@ # RvP, 180710 # -set(SLICOT_FSOURCE +set(SLICOT_FSOURCE src/SLICOT-Reference/src/AB01MD.f src/SLICOT-Reference/src/AB01ND.f @@ -106,6 +106,7 @@ src/SLICOT-Reference/src/MA01BD.f src/SLICOT-Reference/src/MA01BZ.f src/SLICOT-Reference/src/MA01CD.f src/SLICOT-Reference/src/MA02AD.f +src/SLICOT-Reference/src/MA02AZ.f src/SLICOT-Reference/src/MA02BD.f src/SLICOT-Reference/src/MA02BZ.f src/SLICOT-Reference/src/MA02CD.f @@ -157,6 +158,8 @@ src/SLICOT-Reference/src/MB01TD.f src/SLICOT-Reference/src/MB01UD.f src/SLICOT-Reference/src/MB01UW.f src/SLICOT-Reference/src/MB01UX.f +src/SLICOT-Reference/src/MB01UY.f +src/SLICOT-Reference/src/MB01UZ.f src/SLICOT-Reference/src/MB01VD.f src/SLICOT-Reference/src/MB01WD.f src/SLICOT-Reference/src/MB01XD.f @@ -253,13 +256,16 @@ src/SLICOT-Reference/src/MB03QW.f src/SLICOT-Reference/src/MB03QX.f src/SLICOT-Reference/src/MB03QY.f src/SLICOT-Reference/src/MB03RD.f +src/SLICOT-Reference/src/MB03RW.f src/SLICOT-Reference/src/MB03RX.f src/SLICOT-Reference/src/MB03RY.f +src/SLICOT-Reference/src/MB03RZ.f src/SLICOT-Reference/src/MB03SD.f src/SLICOT-Reference/src/MB03TD.f src/SLICOT-Reference/src/MB03TS.f src/SLICOT-Reference/src/MB03UD.f src/SLICOT-Reference/src/MB03VD.f +src/SLICOT-Reference/src/MB03VW.f src/SLICOT-Reference/src/MB03VY.f src/SLICOT-Reference/src/MB03WA.f src/SLICOT-Reference/src/MB03WD.f @@ -427,10 +433,12 @@ src/SLICOT-Reference/src/SB03MX.f src/SLICOT-Reference/src/SB03MY.f src/SLICOT-Reference/src/SB03OD.f src/SLICOT-Reference/src/SB03OR.f +src/SLICOT-Reference/src/SB03OS.f src/SLICOT-Reference/src/SB03OT.f src/SLICOT-Reference/src/SB03OU.f src/SLICOT-Reference/src/SB03OV.f src/SLICOT-Reference/src/SB03OY.f +src/SLICOT-Reference/src/SB03OZ.f src/SLICOT-Reference/src/SB03PD.f src/SLICOT-Reference/src/SB03QD.f src/SLICOT-Reference/src/SB03QX.f @@ -512,11 +520,15 @@ src/SLICOT-Reference/src/SG03AD.f src/SLICOT-Reference/src/SG03AX.f src/SLICOT-Reference/src/SG03AY.f src/SLICOT-Reference/src/SG03BD.f +src/SLICOT-Reference/src/SG03BR.f +src/SLICOT-Reference/src/SG03BS.f +src/SLICOT-Reference/src/SG03BT.f src/SLICOT-Reference/src/SG03BU.f src/SLICOT-Reference/src/SG03BV.f src/SLICOT-Reference/src/SG03BW.f src/SLICOT-Reference/src/SG03BX.f src/SLICOT-Reference/src/SG03BY.f +src/SLICOT-Reference/src/SG03BZ.f src/SLICOT-Reference/src/TB01ID.f src/SLICOT-Reference/src/TB01IZ.f src/SLICOT-Reference/src/TB01KD.f @@ -580,11 +592,17 @@ src/SLICOT-Reference/src/TG01HY.f src/SLICOT-Reference/src/TG01ID.f src/SLICOT-Reference/src/TG01JD.f src/SLICOT-Reference/src/TG01JY.f +src/SLICOT-Reference/src/TG01KD.f +src/SLICOT-Reference/src/TG01KZ.f src/SLICOT-Reference/src/TG01LD.f src/SLICOT-Reference/src/TG01LY.f src/SLICOT-Reference/src/TG01MD.f src/SLICOT-Reference/src/TG01ND.f src/SLICOT-Reference/src/TG01NX.f +src/SLICOT-Reference/src/TG01OA.f +src/SLICOT-Reference/src/TG01OB.f +src/SLICOT-Reference/src/TG01OD.f +src/SLICOT-Reference/src/TG01OZ.f src/SLICOT-Reference/src/TG01PD.f src/SLICOT-Reference/src/TG01QD.f src/SLICOT-Reference/src/TG01WD.f From 0e83e44368fe14b0e13298ea5f0f55e70159299e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 29 May 2022 17:10:19 +0200 Subject: [PATCH 298/405] update docstrings for wrappers of changed methods in SLICOT v5.8 --- slycot/math.py | 2 +- slycot/synthesis.py | 25 +++++++++++-------------- 2 files changed, 12 insertions(+), 15 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index 336b4b4b..ae9aab18 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -29,7 +29,7 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): To reduce a matrix `A` in real Schur form to a block-diagonal form using well-conditioned non-orthogonal similarity transformations. The condition numbers of the transformations used for reduction - are roughly bounded by `pmax`*`pmax`, where `pmax` is a given value. + are roughly bounded by `pmax`, where `pmax` is a given value. The transformations are optionally postmultiplied in a given matrix `X`. The real Schur form is optionally ordered, so that clustered eigenvalues are grouped in the same block. diff --git a/slycot/synthesis.py b/slycot/synthesis.py index f2117bb3..323d0e9c 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -839,7 +839,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): set less than or equal to 1 to avoid overflow in X. If matrix B has full rank then the solution matrix X will be positive-definite and hence the Cholesky factor U will be nonsingular, but if B is - rank deficient then X may be only positive semi-definite and U + rank deficient, then X may be only positive semi-definite and U will be singular. In the case of equation (1) the matrix A must be stable (that @@ -850,8 +850,8 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): Parameters ---------- n : int - The order of the matrix A and the number of columns in - matrix op(B). n >= 0. + The order of the matrix A and the number of columns of + the matrix op(B). n >= 0. m : int The number of rows in matrix op(B). m >= 0. A : (n, n) array_like @@ -859,11 +859,11 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): contain the matrix A. If fact = 'F', then A contains an upper quasi-triangular matrix S in Schur canonical form; the elements below the upper Hessenberg part of the - array A are not referenced. + array A are then not referenced. On exit, the leading n-by-n upper Hessenberg part of this array contains the upper quasi-triangular matrix S in Schur canonical form from the Shur factorization of A. - The contents of array A is not modified if fact = 'F'. + The contents of the array A is not modified if fact = 'F'. Q : (n, n) array_like On entry, if fact = 'F', then the leading n-by-n part of this array must contain the orthogonal matrix Q of the @@ -871,7 +871,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): Otherwise, Q need not be set on entry. On exit, the leading n-by-n part of this array contains the orthogonal matrix Q of the Schur factorization of A. - The contents of array Q is not modified if fact = 'F'. + The contents of the array Q is not modified if fact = 'F'. B : (m, n) array_like On entry, if trans = 'N', the leading m-by-n part of this array must contain the coefficient matrix B of the @@ -915,7 +915,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): The scale factor, scale, set less than or equal to 1 to prevent the solution overflowing. w : (n, ) complex ndarray - If fact = 'N', this array contains the eigenvalues of A. + The eigenvalues of A. Raises ------ @@ -932,7 +932,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): :info = 4: FACT = 'F' and the Schur factor S supplied in the array A has two or more consecutive non-zero - elements on the first sub-diagonal, so that there is + elements on the first subdiagonal, so that there is a block larger than 2-by-2 on the diagonal :info = 5: FACT = 'F' and the Schur factor S supplied in @@ -2333,9 +2333,6 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): Hessenberg part of the array A are not referenced. If fact = 'N', then the leading n-by-n part of this array must contain the matrix A. - On exit, the leading n-by-n part of this array contains - the generalized Schur factor A_s of the matrix A. (A_s is - an upper quasitriangular matrix.) E : (n, n) array_like On entry, if fact = 'F', then the leading n-by-n upper triangular part of this array must contain the @@ -2407,9 +2404,9 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): scale : float The scale factor set to avoid overflow in U. 0 < scale <= 1. - alpha : (n, ) complex ndarray + lambda : (n, ) complex ndarray If INFO = 0, 3, 5, 6, or 7, then - (alpha(j), j=1,...,n, are the + ((j), j=1,...,n, are the eigenvalues of the matrix pencil A - lambda * E. Raises @@ -2463,7 +2460,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): alpha = _np.zeros(n,'complex64') alpha.real = alphar[0:n] alpha.imag = alphai[0:n] - return U,scale,alpha/beta + return U, scale, alpha/beta def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): From 7972869d3a11f37a245f326d80348bdf62f32d3c Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 29 May 2022 17:11:03 +0200 Subject: [PATCH 299/405] new bounds in SB03OD --- slycot/src/synthesis.pyf | 2 +- slycot/synthesis.py | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index 27eb6e39..a84cd03f 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -365,7 +365,7 @@ subroutine sb03od(dico,fact,trans,n,m,a,lda,q,ldq,b,ldb,scale,wr,wi,dwork,ldwork double precision intent(out),dimension(n),depend(n) :: wr double precision intent(out),dimension(n),depend(n) :: wi double precision intent(hide,cache),dimension(ldwork) :: dwork - integer optional,check(ldwork>=max(1,4*n + min(m,n))),depend(n,m) :: ldwork=max(1,4*n + min(m,n)) + integer optional,check(ldwork>=max(1,4*n)),depend(n,m) :: ldwork=max(1,4*n) integer intent(out) :: info end subroutine sb03od subroutine sb04md(n,m,a,lda,b,ldb,c,ldc,z,ldz,iwork,dwork,ldwork,info) ! in SB04MD.f diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 323d0e9c..5407e5e4 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -901,7 +901,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): := 'T': op(K) = K**T (Transpose). ldwork : int, optional The length of the array DWORK. - If m > 0, ldwork >= max(1, 4*n + min(m, n)); + If m > 0, ldwork >= max(1, 4*n); If m = 0, ldwork >= 1. For optimum performance ldwork should sometimes be larger. @@ -984,7 +984,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): 'wi'+hidden, 'dwork'+hidden, 'ldwork', 'info'+hidden] if ldwork is None: if m > 0: - ldwork = max(1,4*n + min(m,n)) + ldwork = max(1,4*n) elif m == 0: ldwork = 1 if dico != 'C' and dico != 'D': From 726b4750f4de825d5168f2f6e06634e5854887f3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 29 May 2022 14:17:18 +0200 Subject: [PATCH 300/405] SB03OD info=3 is a warning instead of error now --- slycot/synthesis.py | 19 ++++++++++--------- slycot/tests/test_sb.py | 4 ++-- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 5407e5e4..0ffbbd93 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -920,15 +920,6 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): Raises ------ SlycotArithmeticError - :info = 3 and fact == 'F' and dico == 'C': - The Schur factor S supplied in the array A is not - stable (that is, one or more of the eigenvalues of - S has a non-negative real part) - :info = 3 and dico == 'D': - The Schur factor S - supplied in the array A is not convergent (that is, - one or more of the eigenvalues of S lies outside the - unit circle) :info = 4: FACT = 'F' and the Schur factor S supplied in the array A has two or more consecutive non-zero @@ -977,6 +968,16 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): more of the eigenvalues of A lies outside the unit circle); however, A still has been factored and the eigenvalues of A are returned in WR and WI. + :info = 3 and fact == 'F' and dico == 'C': + The Schur factor S supplied in the array A is not + stable (that is, one or more of the eigenvalues of + S has a non-negative real part); + the eigenvalues of A are still returned in w. + :info = 3 and dico == 'D': + The Schur factor S supplied in the array A is not + convergent (that is, one or more of the eigenvalues + of S lies outside the unit circle); + the eigenvalues of A are still returned in w. """ hidden = ' (hidden by the wrapper)' arg_list = ['dico','fact', 'trans', 'n', 'm', 'a', 'lda'+hidden, 'q', diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 2446405d..00e406db 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -192,9 +192,9 @@ def test_sb10fd_2(): 'dico': 'C'}), (synthesis.sb03od, SlycotResultWarning, [1, 2], {'dico': 'C', 'fact': 'N'}), - (synthesis.sb03od, SlycotResultWarning, [1, 2], {'dico': 'D', + (synthesis.sb03od, SlycotResultWarning, [1, 2, 3], {'dico': 'D', 'fact': 'N'}), - (synthesis.sb03od, SlycotArithmeticError, [3, 4, 5, 6], {'dico': 'D', + (synthesis.sb03od, SlycotArithmeticError, [4, 5, 6], {'dico': 'D', 'fact': 'F'}), (synthesis.sb04md, SlycotArithmeticError, 2, {'m': 1}), (synthesis.sb04qd, SlycotArithmeticError, 3, {'m': 2}), From afc02947ae7aafb0132b9e7498438933f268ba91 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 1 Jun 2022 11:14:20 +0200 Subject: [PATCH 301/405] update SLICOT-Reference to latest v5.8 commit --- slycot/src/SLICOT-Reference | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/SLICOT-Reference b/slycot/src/SLICOT-Reference index f0d40ee8..c1104834 160000 --- a/slycot/src/SLICOT-Reference +++ b/slycot/src/SLICOT-Reference @@ -1 +1 @@ -Subproject commit f0d40ee80c63e0d2ee71be1e1247be3bdfda5a84 +Subproject commit c1104834c7348b3412973bd86b063faa74219003 From 9ad424287569d53597601beaddfe4d201664c95e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 30 Jun 2022 12:48:37 +0200 Subject: [PATCH 302/405] Work around numpy/numpy#21889 --- pyproject.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pyproject.toml b/pyproject.toml index 206a1e60..e55372af 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -4,5 +4,5 @@ requires = [ "wheel", "scikit-build>=0.14.1", "cmake", - "numpy"] + "numpy!=1.23.0"] build-backend = "setuptools.build_meta" From d5769a413c30860dd2bfbaf2349eb279df28dcea Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 30 Jun 2022 14:18:03 +0200 Subject: [PATCH 303/405] conflict numpy-1.23 in conda --- .github/conda-env/build-env.yml | 2 +- .github/workflows/slycot-build-and-test.yml | 1 - conda-recipe/meta.yaml | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml index f747a77e..64ef8932 100644 --- a/.github/conda-env/build-env.yml +++ b/.github/conda-env/build-env.yml @@ -1,4 +1,4 @@ name: build-env dependencies: - boa - - numpy + - numpy!=1.23.0 diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 54367ed2..b8f84ade 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -167,7 +167,6 @@ jobs: shell: bash -l {0} run: | set -e - mamba install boa numpy numpyversion=$(python -c 'import numpy; print(numpy.version.version)') conda mambabuild --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe # preserve directory structure for custom conda channel diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 55314c06..b3e846db 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -27,7 +27,7 @@ requirements: - libcblas * *netlib - liblapack * *netlib - python - - numpy + - numpy!=1.23.0 - pip - scikit-build >=0.14.1 From 598b2cf65ba2507dfdfa9fc2361d547f3664c64d Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 9 Jul 2022 14:21:42 +0200 Subject: [PATCH 304/405] use setuptools_scm --- .coveragerc | 1 - CMakeLists.txt | 3 +- MANIFEST.in | 1 - conda-recipe/meta.yaml | 4 +- pyproject.toml | 7 ++ setup.cfg.in | 10 --- setup.py | 152 +++-------------------------------------- slycot/CMakeLists.txt | 4 +- slycot/__init__.py | 7 +- slycot/version.py.in | 10 --- 10 files changed, 25 insertions(+), 174 deletions(-) delete mode 100644 setup.cfg.in delete mode 100644 slycot/version.py.in diff --git a/.coveragerc b/.coveragerc index 7f5d53d6..97122d29 100644 --- a/.coveragerc +++ b/.coveragerc @@ -2,7 +2,6 @@ source = slycot omit = */tests/* - */version.py # please do not add any sections after this block diff --git a/CMakeLists.txt b/CMakeLists.txt index b018ff83..8ebbcd69 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,7 +6,7 @@ if (CMAKE_VERSION VERSION_GREATER "3.11.99") cmake_policy(SET CMP0074 NEW) endif() -project(slycot VERSION ${SLYCOT_VERSION} LANGUAGES NONE) +project(slycot LANGUAGES NONE) enable_language(C) enable_language(Fortran) @@ -22,6 +22,5 @@ message(STATUS "NumPy included from: ${NumPy_INCLUDE_DIR}") message(STATUS "F2PY included from: ${F2PY_INCLUDE_DIR}") message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") message(STATUS "BLAS: ${BLAS_LIBRARIES}") -message(STATUS "Slycot version: ${SLYCOT_VERSION}") add_subdirectory(slycot) diff --git a/MANIFEST.in b/MANIFEST.in index 8fecc477..b8c04e7c 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -9,7 +9,6 @@ include conda-recipe/* include slycot/CMakeLists.txt include slycot/tests/CMakeLists.txt include slycot/*.py -include slycot/version.py.in include slycot/src/*.f include slycot/tests/*.py graft slycot/src/SLICOT-Reference diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index b3e846db..05f59a05 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -27,14 +27,16 @@ requirements: - libcblas * *netlib - liblapack * *netlib - python - - numpy!=1.23.0 + - numpy !=1.23.0 - pip - scikit-build >=0.14.1 + - setuptools_scm >=6.3 run: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} - libflang # [win] + - importlib_metadata # [py<38] test: requires: diff --git a/pyproject.toml b/pyproject.toml index e55372af..640b2115 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -1,8 +1,15 @@ [build-system] requires = [ "setuptools", + "setuptools_scm>=6.3", "wheel", "scikit-build>=0.14.1", "cmake", "numpy!=1.23.0"] build-backend = "setuptools.build_meta" + +[tool.setuptools_scm] + +[tool.pytest.ini_options] +# run the tests with compiled and installed package +addopts = "--pyargs slycot" diff --git a/setup.cfg.in b/setup.cfg.in deleted file mode 100644 index 6473f3df..00000000 --- a/setup.cfg.in +++ /dev/null @@ -1,10 +0,0 @@ -[metadata] - -name = slycot -version = @version@ -gitrevision = @gitrevision@ -release = @release@ - -[tool:pytest] -# run the tests with compiled and installed package -addopts = --pyargs slycot diff --git a/setup.py b/setup.py index 1f7f6707..bab8c695 100644 --- a/setup.py +++ b/setup.py @@ -12,10 +12,6 @@ import subprocess import re import platform -try: - import configparser -except ImportError: - import ConfigParser as configparser try: from skbuild import setup @@ -23,6 +19,11 @@ except ImportError: raise ImportError('scikit-build must be installed before running setup.py') +try: + from setuptools_scm import get_version +except ImportError: + raise ImportError('setuptools_scm must be installed before running setup.py') + DOCLINES = __doc__.split("\n") CLASSIFIERS = """\ @@ -46,74 +47,6 @@ Operating System :: MacOS """ -# defaults -ISRELEASED = True -# assume a version set by conda, next update with git, -# otherwise count on default -VERSION = 'Unknown' - - -class GitError(RuntimeError): - """Exception for git errors occuring in in git_version""" - pass - - -def git_version(srcdir=None): - """Return the git version, revision and cycle - - Uses rev-parse to get the revision tag to get the version number from the - latest tag and detects (approximate) revision cycles - - """ - def _minimal_ext_cmd(cmd, srcdir): - # construct minimal environment - env = {} - for k in ['SYSTEMROOT', 'PATH']: - v = os.environ.get(k) - if v is not None: - env[k] = v - # LANGUAGE is used on win32 - env['LANGUAGE'] = 'C' - env['LANG'] = 'C' - env['LC_ALL'] = 'C' - proc = subprocess.Popen( - cmd, - cwd=srcdir, - stdout=subprocess.PIPE, - stderr=subprocess.PIPE, - env=env) - out, err = proc.communicate() - if proc.returncode: - errmsg = err.decode('ascii', errors='ignore').strip() - raise GitError("git err; return code %d, error message:\n '%s'" - % (proc.returncode, errmsg)) - return out - - try: - GIT_VERSION = VERSION - GIT_REVISION = 'Unknown' - GIT_CYCLE = 0 - out = _minimal_ext_cmd(['git', 'rev-parse', 'HEAD'], srcdir) - GIT_REVISION = out.strip().decode('ascii') - out = _minimal_ext_cmd(['git', 'tag'], srcdir) - GIT_VERSION = out.strip().decode('ascii').split('\n')[-1][1:] - out = _minimal_ext_cmd(['git', 'describe', '--tags', - '--long', '--always'], srcdir) - try: - # don't get a good description with shallow clones - GIT_CYCLE = out.strip().decode('ascii').split('-')[1] - except IndexError: - pass - except OSError: - pass - - return GIT_VERSION, GIT_REVISION, GIT_CYCLE - -# BEFORE importing distutils, remove MANIFEST. distutils doesn't properly -# update it when the contents of directories change. -if os.path.exists('MANIFEST'): - os.remove('MANIFEST') - # This is a bit hackish: we are setting a global variable so that the main # slycot __init__ can detect if it is being loaded by the setup routine, to # avoid attempting to load components that aren't built yet. While ugly, it's @@ -121,69 +54,6 @@ def _minimal_ext_cmd(cmd, srcdir): builtins.__SLYCOT_SETUP__ = True -def rewrite_setup_cfg(version, gitrevision, release): - toreplace = dict(locals()) - data = ''.join(open('setup.cfg.in', 'r').readlines()).split('@') - for k, v in toreplace.items(): - idx = data.index(k) - data[idx] = v - cfg = open('setup.cfg', 'w') - cfg.write(''.join(data)) - cfg.close() - - -def get_version_info(srcdir=None): - global ISRELEASED - GIT_CYCLE = 0 - - # Adding the git rev number needs to be done inside write_version_py(), - # otherwise the import of slycot.version messes up - # the build under Python 3. - if os.environ.get('CONDA_BUILD', False): - FULLVERSION = os.environ.get('PKG_VERSION', '???') - GIT_REVISION = os.environ.get('GIT_DESCRIBE_HASH', '') - ISRELEASED = True - rewrite_setup_cfg(FULLVERSION, GIT_REVISION, 'yes') - elif os.path.exists('.git'): - FULLVERSION, GIT_REVISION, GIT_CYCLE = git_version(srcdir) - ISRELEASED = (GIT_CYCLE == 0) - rewrite_setup_cfg(FULLVERSION, GIT_REVISION, - (ISRELEASED and 'yes') or 'no') - elif os.path.exists('setup.cfg'): - # valid distribution - setupcfg = configparser.ConfigParser(allow_no_value=True) - setupcfg.read('setup.cfg') - - FULLVERSION = setupcfg.get(section='metadata', option='version') - - if FULLVERSION is None: - FULLVERSION = "Unknown" - - GIT_REVISION = setupcfg.get(section='metadata', option='gitrevision') - - if GIT_REVISION is None: - GIT_REVISION = "" - - return FULLVERSION, GIT_REVISION - else: - - # try to find a version number from the dir name - dname = os.getcwd().split(os.sep)[-1] - - m = re.search(r'[0-9.]+', dname) - if m: - FULLVERSION = m.group() - GIT_REVISION = '' - - else: - FULLVERSION = VERSION - GIT_REVISION = "Unknown" - - if not ISRELEASED: - FULLVERSION += '.' + str(GIT_CYCLE) - - return FULLVERSION, GIT_REVISION - def check_submodules(): """ verify that the submodules are checked out and clean use `git submodule update --init`; on failure @@ -216,14 +86,12 @@ def setup_package(): src_path = os.path.dirname(os.path.abspath(__file__)) sys.path.insert(0, src_path) - # Rewrite the version file everytime - VERSION, gitrevision = get_version_info(src_path) metadata = dict( name='slycot', packages=['slycot', 'slycot.tests'], cmake_languages=('C', 'Fortran'), - version=VERSION, + use_scm_version=True, maintainer="Slycot developers", maintainer_email="python-control-discuss@lists.sourceforge.net", description=DOCLINES[0], @@ -234,12 +102,9 @@ def setup_package(): classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], cmdclass={"sdist": sdist_checked}, - cmake_args=['-DSLYCOT_VERSION:STRING=' + VERSION, - '-DGIT_REVISION:STRING=' + gitrevision, - '-DISRELEASE:STRING=' + str(ISRELEASED), - '-DFULL_VERSION=' + VERSION + '.git' + gitrevision[:7]], zip_safe=False, - install_requires=['numpy'], + install_requires=["numpy", + "importlib-metadata; python_version < '3.8'"], python_requires=">=3.7" ) @@ -247,7 +112,6 @@ def setup_package(): setup(**metadata) finally: del sys.path[0] - return if __name__ == '__main__': diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index f656c326..a079bf98 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -630,13 +630,11 @@ set(F2PYSOURCE_DEPS src/transform.pyf src/synthesis.pyf src/_helper.pyf) -configure_file(version.py.in version.py @ONLY) - set(PYSOURCE __init__.py examples.py exceptions.py analysis.py math.py synthesis.py transform.py - ${CMAKE_CURRENT_BINARY_DIR}/version.py) +) set(SLYCOT_MODULE "_wrapper") diff --git a/slycot/__init__.py b/slycot/__init__.py index 836c8a51..53fbf4c3 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -45,8 +45,11 @@ from .transform import tf01md, tf01rd from .transform import td04ad, tb01pd - # Version information - from .version import version as __version__ + try: + from importlib.metadata import version + except ImportError: + from importlib_metadata import version + __version__ = version("slycot") def test(): diff --git a/slycot/version.py.in b/slycot/version.py.in deleted file mode 100644 index 0843bf15..00000000 --- a/slycot/version.py.in +++ /dev/null @@ -1,10 +0,0 @@ - -# THIS FILE IS GENERATED FROM SLYCOT SETUP.PY -short_version = '@SLYCOT_VERSION@' -version = '@SLYCOT_VERSION@' -full_version = '@FULL_VERSION@' -git_revision = '@GIT_REVISION@' -release = @ISRELEASE@ - -if not release: - version = full_version From c0563fb2e6d73759d5482bc9f87bf164560c3763 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 10 Jul 2022 12:24:23 +0200 Subject: [PATCH 305/405] avoid slycot.version being the version function --- slycot/__init__.py | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 53fbf4c3..3e57bf95 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -46,10 +46,11 @@ from .transform import td04ad, tb01pd try: - from importlib.metadata import version + from importlib.metadata import version as imv except ImportError: - from importlib_metadata import version - __version__ = version("slycot") + from importlib_metadata import version as imv + __version__ = imv(__package__) + def test(): From d51cbcfd02752fd56627a7ff0f9f08db0145cf37 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 16 Jul 2022 12:25:11 +0200 Subject: [PATCH 306/405] Apply suggestions from code review --- conda-recipe/meta.yaml | 3 ++- pyproject.toml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 05f59a05..f3b32d8b 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -30,7 +30,8 @@ requirements: - numpy !=1.23.0 - pip - scikit-build >=0.14.1 - - setuptools_scm >=6.3 + - setuptools >=45 + - setuptools_scm >=6.3 run: - python {{ PY_VER }} diff --git a/pyproject.toml b/pyproject.toml index 640b2115..26e13998 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -1,6 +1,6 @@ [build-system] requires = [ - "setuptools", + "setuptools>=45", "setuptools_scm>=6.3", "wheel", "scikit-build>=0.14.1", From 1da4cb8a40c70f4e60f57670f38db00b03c761b3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 16 Jul 2022 12:56:02 +0200 Subject: [PATCH 307/405] setuptools_scm writes slycot/version.py --- .coveragerc | 1 + conda-recipe/meta.yaml | 1 - pyproject.toml | 1 + setup.py | 3 +-- slycot/__init__.py | 7 +------ 5 files changed, 4 insertions(+), 9 deletions(-) diff --git a/.coveragerc b/.coveragerc index 97122d29..7f5d53d6 100644 --- a/.coveragerc +++ b/.coveragerc @@ -2,6 +2,7 @@ source = slycot omit = */tests/* + */version.py # please do not add any sections after this block diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index f3b32d8b..f2f128b0 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -37,7 +37,6 @@ requirements: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} - libflang # [win] - - importlib_metadata # [py<38] test: requires: diff --git a/pyproject.toml b/pyproject.toml index 26e13998..2ad51c36 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -9,6 +9,7 @@ requires = [ build-backend = "setuptools.build_meta" [tool.setuptools_scm] +write_to = "slycot/version.py" [tool.pytest.ini_options] # run the tests with compiled and installed package diff --git a/setup.py b/setup.py index bab8c695..10c04a1e 100644 --- a/setup.py +++ b/setup.py @@ -103,8 +103,7 @@ def setup_package(): platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], cmdclass={"sdist": sdist_checked}, zip_safe=False, - install_requires=["numpy", - "importlib-metadata; python_version < '3.8'"], + install_requires=["numpy"], python_requires=">=3.7" ) diff --git a/slycot/__init__.py b/slycot/__init__.py index 3e57bf95..6bd59014 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -45,12 +45,7 @@ from .transform import tf01md, tf01rd from .transform import td04ad, tb01pd - try: - from importlib.metadata import version as imv - except ImportError: - from importlib_metadata import version as imv - __version__ = imv(__package__) - + from .version import __version__ def test(): From c7852683d3af5149ac067548aa8ce5bd2960b4fb Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 16 Jul 2022 13:52:17 +0200 Subject: [PATCH 308/405] move metadata to pyproject.toml --- pyproject.toml | 38 ++++++++++++++++++++++++++++ setup.py | 67 ++++++-------------------------------------------- 2 files changed, 46 insertions(+), 59 deletions(-) diff --git a/pyproject.toml b/pyproject.toml index 2ad51c36..5b39b4da 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -8,6 +8,44 @@ requires = [ "numpy!=1.23.0"] build-backend = "setuptools.build_meta" +[project] +name = "slycot" +description = "A wrapper for the SLICOT control and systems library" +readme = "README.rst" +authors = [{ name = "Enrico Avventi et al." }] +maintainers = [{ name = "Slycot developers", email = "python-control-discuss@lists.sourceforge.net"}] +license = {text = "GPL-2.0 AND BSD-3-Clause"} +classifiers = [ + "Development Status :: 4 - Beta", + "Intended Audience :: Science/Research", + "Intended Audience :: Developers", + "License :: OSI Approved", + "License :: OSI Approved :: GNU General Public License v2 (GPLv2)", + "License :: OSI Approved :: BSD License", + "Programming Language :: C", + "Programming Language :: Fortran", + "Programming Language :: Python", + "Programming Language :: Python :: 3.7", + "Programming Language :: Python :: 3.8", + "Programming Language :: Python :: 3.9", + "Programming Language :: Python :: 3.10", + "Topic :: Software Development", + "Topic :: Scientific/Engineering", + "Operating System :: Microsoft :: Windows", + "Operating System :: POSIX", + "Operating System :: Unix", + "Operating System :: MacOS", +] +requires-python = ">=3.7" +dependencies = [ + "numpy", +] +dynamic = ["version"] + +[project.urls] +homepage = "https://github.com/python-control/Slycot" + + [tool.setuptools_scm] write_to = "slycot/version.py" diff --git a/setup.py b/setup.py index 10c04a1e..5ee3cb4f 100644 --- a/setup.py +++ b/setup.py @@ -8,10 +8,7 @@ import builtins import os -import sys import subprocess -import re -import platform try: from skbuild import setup @@ -24,29 +21,6 @@ except ImportError: raise ImportError('setuptools_scm must be installed before running setup.py') -DOCLINES = __doc__.split("\n") - -CLASSIFIERS = """\ -Development Status :: 4 - Beta -Intended Audience :: Science/Research -Intended Audience :: Developers -License :: OSI Approved -License :: OSI Approved :: GNU General Public License v2 (GPLv2) -Programming Language :: C -Programming Language :: Fortran -Programming Language :: Python -Programming Language :: Python :: 3.7 -Programming Language :: Python :: 3.8 -Programming Language :: Python :: 3.9 -Programming Language :: Python :: 3.10 -Topic :: Software Development -Topic :: Scientific/Engineering -Operating System :: Microsoft :: Windows -Operating System :: POSIX -Operating System :: Unix -Operating System :: MacOS -""" - # This is a bit hackish: we are setting a global variable so that the main # slycot __init__ can detect if it is being loaded by the setup routine, to # avoid attempting to load components that aren't built yet. While ugly, it's @@ -82,36 +56,11 @@ def run(self): check_submodules() sdist.run(self) -def setup_package(): - src_path = os.path.dirname(os.path.abspath(__file__)) - sys.path.insert(0, src_path) - - - metadata = dict( - name='slycot', - packages=['slycot', 'slycot.tests'], - cmake_languages=('C', 'Fortran'), - use_scm_version=True, - maintainer="Slycot developers", - maintainer_email="python-control-discuss@lists.sourceforge.net", - description=DOCLINES[0], - long_description=open('README.rst').read(), - url='https://github.com/python-control/Slycot', - author='Enrico Avventi et al.', - license='GPL-2.0', - classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], - platforms=["Windows", "Linux", "Solaris", "Mac OS-X", "Unix"], - cmdclass={"sdist": sdist_checked}, - zip_safe=False, - install_requires=["numpy"], - python_requires=">=3.7" - ) - - try: - setup(**metadata) - finally: - del sys.path[0] - - -if __name__ == '__main__': - setup_package() +# These need to stay in setup.py +# https://scikit-build.readthedocs.io/en/latest/usage.html#setuptools-options +setup( + packages=['slycot', 'slycot.tests'], + cmdclass={'sdist': sdist_checked}, + cmake_languages=('C', 'Fortran'), + use_scm_version = True, +) From 7c45025e45ddaf213b28b7dfc569dbf33fa6a87e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 26 Jul 2022 12:43:30 +0200 Subject: [PATCH 309/405] Use FindPython instead of deprecated FindPythonLibs --- CMakeLists.txt | 13 ++++++------- conda-recipe/meta.yaml | 4 ++-- pyproject.toml | 4 ++-- slycot/CMakeLists.txt | 3 ++- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 8ebbcd69..d7b015c5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,25 +1,24 @@ # CMake file for use in conjunction with scikit-build -cmake_minimum_required(VERSION 3.11.0) +cmake_minimum_required(VERSION 3.14.0) -if (CMAKE_VERSION VERSION_GREATER "3.11.99") - cmake_policy(SET CMP0074 NEW) -endif() +cmake_policy(SET CMP0074 NEW) project(slycot LANGUAGES NONE) enable_language(C) enable_language(Fortran) -find_package(PythonLibs REQUIRED) +find_package(Python COMPONENTS Interpreter Development NumPy REQUIRED) find_package(PythonExtensions REQUIRED) find_package(NumPy REQUIRED) find_package(F2PY REQUIRED) find_package(BLAS REQUIRED) find_package(LAPACK REQUIRED) -message(STATUS "NumPy included from: ${NumPy_INCLUDE_DIR}") -message(STATUS "F2PY included from: ${F2PY_INCLUDE_DIR}") +message(STATUS "Python headers included from: ${Python_INCLUDE_DIRS}") +message(STATUS "NumPy headers included from: ${Python_NumPy_INCLUDE_DIRS}") +message(STATUS "F2PY headers included from: ${F2PY_INCLUDE_DIRS}") message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") message(STATUS "BLAS: ${BLAS_LIBRARIES}") diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index f2f128b0..7b416356 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -13,7 +13,7 @@ requirements: build: - {{ compiler('fortran') }} # [not win] - {{ compiler('c') }} - - cmake + - cmake >=3.14 - make # [linux] - flang >=11 # [win] @@ -29,7 +29,7 @@ requirements: - python - numpy !=1.23.0 - pip - - scikit-build >=0.14.1 + - scikit-build >=0.15 - setuptools >=45 - setuptools_scm >=6.3 diff --git a/pyproject.toml b/pyproject.toml index 5b39b4da..be510f32 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -3,8 +3,8 @@ requires = [ "setuptools>=45", "setuptools_scm>=6.3", "wheel", - "scikit-build>=0.14.1", - "cmake", + "scikit-build>=0.15", + "cmake>=3.14", "numpy!=1.23.0"] build-backend = "setuptools.build_meta" diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index a079bf98..46980725 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -664,8 +664,9 @@ target_link_libraries(${SLYCOT_MODULE} target_include_directories( ${SLYCOT_MODULE} PUBLIC + ${Python_INCLUDE_DIRS} + ${Python_NumPy_INCLUDE_DIRS} ${F2PY_INCLUDE_DIRS} - ${PYTHON_INCLUDE_DIRS} ) if (UNIX) From b172020a5858c0cf31fe1d8a07badcf7ae3e1ab2 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 30 Oct 2022 10:23:55 +0100 Subject: [PATCH 310/405] Add Python 3.11 classifier --- pyproject.toml | 1 + 1 file changed, 1 insertion(+) diff --git a/pyproject.toml b/pyproject.toml index be510f32..1c6f74cc 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -29,6 +29,7 @@ classifiers = [ "Programming Language :: Python :: 3.8", "Programming Language :: Python :: 3.9", "Programming Language :: Python :: 3.10", + "Programming Language :: Python :: 3.11", "Topic :: Software Development", "Topic :: Scientific/Engineering", "Operating System :: Microsoft :: Windows", From 6f689e73595bf67c3184fd3cd748518c245077a4 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 30 Oct 2022 10:26:03 +0100 Subject: [PATCH 311/405] Bump pip tests to Python 3.11 --- .github/workflows/slycot-build-and-test.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index b8f84ade..9d9ae1a3 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -25,7 +25,7 @@ jobs: - name: Set up Python uses: actions/setup-python@v2 with: - python-version: 3.9 + python-version: 3.11 - name: Setup Ubuntu run: | sudo apt-get -y install gfortran cmake --fix-missing @@ -58,23 +58,23 @@ jobs: - 'macos' python: - '3.7' - - '3.10' + - '3.11' bla_vendor: [ 'unset' ] include: - os: 'ubuntu' - python: '3.10' + python: '3.11' bla_vendor: 'Generic' - os: 'ubuntu' - python: '3.10' + python: '3.11' bla_vendor: 'OpenBLAS' - os: 'macos' - python: '3.10' + python: '3.11' bla_vendor: 'Apple' - os: 'macos' - python: '3.10' + python: '3.11' bla_vendor: 'Generic' - os: 'macos' - python: '3.10' + python: '3.11' bla_vendor: 'OpenBLAS' steps: From 7788932e658cfafd45506afe4fc8263cbdc8be4d Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 30 Oct 2022 10:35:54 +0100 Subject: [PATCH 312/405] Bump gfortran to 11 for macos-latest runner --- .github/workflows/slycot-build-and-test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 9d9ae1a3..1063cafb 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -113,7 +113,7 @@ jobs: echo "bla_vendor option ${{ matrix.bla_vendor }} not supported" exit 1 ;; esac - echo "FC=gfortran-10" >> $GITHUB_ENV + echo "FC=gfortran-11" >> $GITHUB_ENV - name: Build wheel env: BLA_VENDOR: ${{ matrix.bla_vendor }} From 505c2e6be5d5ec4bc36673f90bede795e5cde468 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 30 Oct 2022 10:38:51 +0100 Subject: [PATCH 313/405] Bump setup-python action to v4 --- .github/workflows/slycot-build-and-test.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 1063cafb..9797dcc6 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -23,9 +23,9 @@ jobs: fetch-depth: 0 submodules: 'recursive' - name: Set up Python - uses: actions/setup-python@v2 + uses: actions/setup-python@v4 with: - python-version: 3.11 + python-version: '3.11' - name: Setup Ubuntu run: | sudo apt-get -y install gfortran cmake --fix-missing @@ -84,7 +84,7 @@ jobs: fetch-depth: 0 submodules: 'recursive' - name: Set up Python - uses: actions/setup-python@v2 + uses: actions/setup-python@v4 with: python-version: ${{ matrix.python }} - name: Setup Ubuntu @@ -243,7 +243,7 @@ jobs: repository: 'python-control/python-control' path: python-control - name: Setup Python - uses: actions/setup-python@v2 + uses: actions/setup-python@v4 with: python-version: ${{ matrix.python }} - name: Setup Ubuntu From f6895410c90452977497324e1022d40c735ef2ef Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 30 Oct 2022 12:14:05 +0100 Subject: [PATCH 314/405] Update README.rst --- README.rst | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.rst b/README.rst index 1dcde8bc..df1dbc22 100644 --- a/README.rst +++ b/README.rst @@ -19,18 +19,18 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ -Slycot supports Python versions 3.6 or later. +Slycot supports Python versions 3.7 or later. To run the compiled Slycot package, the following must be installed as dependencies: -- Python 3.6+ +- Python 3.7+ - NumPy If you are compiling and installing Slycot from source, you will need the following dependencies: -- 3.6+ +- Python 3.7+ - NumPy - scikit-build - CMake From 73f5c195b29d7db5d4a0d4dd4f1d7da75181934c Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 31 Oct 2022 10:07:00 +0100 Subject: [PATCH 315/405] Bump upper conda build to Python 3.11 --- .github/workflows/slycot-build-and-test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 9797dcc6..cc7c0d5a 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -144,7 +144,7 @@ jobs: - 'windows' python: - '3.9' - - '3.10' + - '3.11' steps: - name: Checkout Slycot From b7f07e931beb34589a004342e339dcb3f2cd0cfa Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 7 Nov 2022 11:45:29 +0100 Subject: [PATCH 316/405] remove mambabuild/boa: not ready for Python 3.11 --- .github/conda-env/build-env.yml | 6 ++++-- .github/workflows/slycot-build-and-test.yml | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml index 64ef8932..a2611b09 100644 --- a/.github/conda-env/build-env.yml +++ b/.github/conda-env/build-env.yml @@ -1,4 +1,6 @@ name: build-env dependencies: - - boa - - numpy!=1.23.0 + - conda-build + - conda-verify + # - boa # re-enable when boa is compatible with mamba 1.0 and Python 3.11 + - numpy !=1.23.0 diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index cc7c0d5a..1af15d3f 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -168,7 +168,7 @@ jobs: run: | set -e numpyversion=$(python -c 'import numpy; print(numpy.version.version)') - conda mambabuild --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe + conda build --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe # preserve directory structure for custom conda channel find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do conda_platform=$(basename $(dirname "${conda_pkg}")) From d906234b6aa2ca182de5ced55da496a6151bc67e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 23 Nov 2022 15:59:41 +0100 Subject: [PATCH 317/405] Drop support for Python 3.7 --- .github/workflows/slycot-build-and-test.yml | 2 +- README.rst | 6 +++--- pyproject.toml | 3 +-- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 1af15d3f..bc403dbf 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -57,7 +57,7 @@ jobs: - 'ubuntu' - 'macos' python: - - '3.7' + - '3.8' - '3.11' bla_vendor: [ 'unset' ] include: diff --git a/README.rst b/README.rst index df1dbc22..bf48b7db 100644 --- a/README.rst +++ b/README.rst @@ -19,18 +19,18 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ -Slycot supports Python versions 3.7 or later. +Slycot supports Python versions 3.8 or later. To run the compiled Slycot package, the following must be installed as dependencies: -- Python 3.7+ +- Python 3.8+ - NumPy If you are compiling and installing Slycot from source, you will need the following dependencies: -- Python 3.7+ +- Python 3.8+ - NumPy - scikit-build - CMake diff --git a/pyproject.toml b/pyproject.toml index 1c6f74cc..3719fa8e 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -25,7 +25,6 @@ classifiers = [ "Programming Language :: C", "Programming Language :: Fortran", "Programming Language :: Python", - "Programming Language :: Python :: 3.7", "Programming Language :: Python :: 3.8", "Programming Language :: Python :: 3.9", "Programming Language :: Python :: 3.10", @@ -37,7 +36,7 @@ classifiers = [ "Operating System :: Unix", "Operating System :: MacOS", ] -requires-python = ">=3.7" +requires-python = ">=3.8" dependencies = [ "numpy", ] From 52ccc8edebc434d3660c2b4b76e434876a6afdb7 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 23 Nov 2022 16:04:23 +0100 Subject: [PATCH 318/405] remove Python 3.7 from README --- README.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.rst b/README.rst index bf48b7db..fe82d095 100644 --- a/README.rst +++ b/README.rst @@ -189,7 +189,7 @@ A similar method can be used for Linux and macOS, but is detailed here for Windows. This method uses conda and conda-forge to get most build dependencies, *except* for the C compiler. -This procedure has been tested on Python 3.7 and 3.8. +This procedure has been tested on Python 3.8. 1. Install `Microsoft Visual Studio`_. 2. Unpack the source code to a directory of your choice, From 614e09a6f0804c509a088058dc30e6700c1962e6 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 23 Nov 2022 16:05:23 +0100 Subject: [PATCH 319/405] Revert "remove mambabuild/boa: not ready for Python 3.11" This reverts commit b7f07e931beb34589a004342e339dcb3f2cd0cfa. --- .github/conda-env/build-env.yml | 6 ++---- .github/workflows/slycot-build-and-test.yml | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml index a2611b09..64ef8932 100644 --- a/.github/conda-env/build-env.yml +++ b/.github/conda-env/build-env.yml @@ -1,6 +1,4 @@ name: build-env dependencies: - - conda-build - - conda-verify - # - boa # re-enable when boa is compatible with mamba 1.0 and Python 3.11 - - numpy !=1.23.0 + - boa + - numpy!=1.23.0 diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index bc403dbf..e4e520f7 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -168,7 +168,7 @@ jobs: run: | set -e numpyversion=$(python -c 'import numpy; print(numpy.version.version)') - conda build --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe + conda mambabuild --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe # preserve directory structure for custom conda channel find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do conda_platform=$(basename $(dirname "${conda_pkg}")) From 8725bb2319231c08330824e9eddcd597d4613a3d Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 23 Nov 2022 16:34:49 +0100 Subject: [PATCH 320/405] bump GitHub actions --- .github/workflows/slycot-build-and-test.yml | 30 ++++++++++----------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index e4e520f7..d5f00779 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -18,7 +18,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: fetch-depth: 0 submodules: 'recursive' @@ -79,7 +79,7 @@ jobs: steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: fetch-depth: 0 submodules: 'recursive' @@ -126,7 +126,7 @@ jobs: mkdir -p ${wheeldir} cp ./slycot*.whl ${wheeldir}/ - name: Save wheel - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: slycot-wheels path: slycot-wheels @@ -148,7 +148,7 @@ jobs: steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: fetch-depth: 0 submodules: 'recursive' @@ -176,7 +176,7 @@ jobs: cp "${conda_pkg}" "slycot-conda-pkgs/${conda_platform}/" done - name: Save to local conda pkg channel - uses: actions/upload-artifact@v2 + uses: actions/upload-artifact@v3 with: name: slycot-conda-pkgs path: slycot-conda-pkgs @@ -190,9 +190,9 @@ jobs: matrix: ${{ steps.set-matrix.outputs.matrix }} steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Download wheels (if any) - uses: actions/download-artifact@v2 + uses: actions/download-artifact@v3 with: name: slycot-wheels path: slycot-wheels @@ -210,9 +210,9 @@ jobs: matrix: ${{ steps.set-matrix.outputs.matrix }} steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 - name: Download conda packages - uses: actions/download-artifact@v2 + uses: actions/download-artifact@v3 with: name: slycot-conda-pkgs path: slycot-conda-pkgs @@ -234,11 +234,11 @@ jobs: steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: path: slycot-src - name: Checkout python-control - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: repository: 'python-control/python-control' path: python-control @@ -276,7 +276,7 @@ jobs: exit 1 ;; esac - name: Download wheels - uses: actions/download-artifact@v2 + uses: actions/download-artifact@v3 with: name: slycot-wheels path: slycot-wheels @@ -313,11 +313,11 @@ jobs: steps: - name: Checkout Slycot - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: path: slycot-src - name: Checkout python-control - uses: actions/checkout@v2 + uses: actions/checkout@v3 with: repository: 'python-control/python-control' path: python-control @@ -335,7 +335,7 @@ jobs: channel-priority: strict auto-activate-base: false - name: Download conda packages - uses: actions/download-artifact@v2 + uses: actions/download-artifact@v3 with: name: slycot-conda-pkgs path: slycot-conda-pkgs From c92de6299346e074912cbea6e32629f9b5ce90de Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 23 Nov 2022 18:26:36 +0100 Subject: [PATCH 321/405] replace set-output --- .github/workflows/slycot-build-and-test.yml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index d5f00779..9c68b243 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -197,9 +197,7 @@ jobs: name: slycot-wheels path: slycot-wheels - id: set-matrix - run: | - matrix=$(python3 .github/scripts/set-pip-test-matrix.py) - echo "::set-output name=matrix::$matrix" + run: echo "matrix=$(python3 .github/scripts/set-pip-test-matrix.py)" >> $GITHUB_OUTPUT create-conda-test-matrix: name: Create conda test matrix @@ -217,9 +215,7 @@ jobs: name: slycot-conda-pkgs path: slycot-conda-pkgs - id: set-matrix - run: | - matrix=$(python3 .github/scripts/set-conda-test-matrix.py) - echo "::set-output name=matrix::$matrix" + run: echo "matrix=$(python3 .github/scripts/set-conda-test-matrix.py)" >> $GITHUB_OUTPUT test-wheel: From 4e9403e6f0dda26ea7c78c3786159017f0518376 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 23 Nov 2022 22:34:25 +0100 Subject: [PATCH 322/405] Bump setuptools_scm to 7 --- conda-recipe/meta.yaml | 2 +- pyproject.toml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 7b416356..1f3314db 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -31,7 +31,7 @@ requirements: - pip - scikit-build >=0.15 - setuptools >=45 - - setuptools_scm >=6.3 + - setuptools_scm >=7 run: - python {{ PY_VER }} diff --git a/pyproject.toml b/pyproject.toml index 3719fa8e..94af52dd 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -1,7 +1,7 @@ [build-system] requires = [ "setuptools>=45", - "setuptools_scm>=6.3", + "setuptools_scm>=7", "wheel", "scikit-build>=0.15", "cmake>=3.14", From f7da2002b5aa9731ec19e4f7b68b04c9e2bce6f3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 18 Dec 2022 21:08:07 +0100 Subject: [PATCH 323/405] pin numpy to <1.24 due to gh-187 --- .github/conda-env/build-env.yml | 2 +- conda-recipe/meta.yaml | 2 +- pyproject.toml | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml index 64ef8932..d932718f 100644 --- a/.github/conda-env/build-env.yml +++ b/.github/conda-env/build-env.yml @@ -1,4 +1,4 @@ name: build-env dependencies: - boa - - numpy!=1.23.0 + - numpy <1.24 diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 7b416356..5b33f7b3 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -27,7 +27,7 @@ requirements: - libcblas * *netlib - liblapack * *netlib - python - - numpy !=1.23.0 + - numpy <1.24 - pip - scikit-build >=0.15 - setuptools >=45 diff --git a/pyproject.toml b/pyproject.toml index 3719fa8e..dfbf578d 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -5,7 +5,8 @@ requires = [ "wheel", "scikit-build>=0.15", "cmake>=3.14", - "numpy!=1.23.0"] + # python-control/Slycot/issues/187 + "numpy<1.24"] build-backend = "setuptools.build_meta" [project] From 9fec0d035eab26fe914bfd7b6141c1fe5770bffb Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 19 Dec 2022 12:38:14 +0100 Subject: [PATCH 324/405] remove -m argument from f2py .pyf generation remove numpy pins fixes gh-187 --- .github/conda-env/build-env.yml | 2 +- conda-recipe/meta.yaml | 2 +- pyproject.toml | 3 +-- slycot/CMakeLists.txt | 3 +-- 4 files changed, 4 insertions(+), 6 deletions(-) diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml index d932718f..f7597364 100644 --- a/.github/conda-env/build-env.yml +++ b/.github/conda-env/build-env.yml @@ -1,4 +1,4 @@ name: build-env dependencies: - boa - - numpy <1.24 + - numpy !=1.23.0 diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 8ee41ce3..1f3314db 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -27,7 +27,7 @@ requirements: - libcblas * *netlib - liblapack * *netlib - python - - numpy <1.24 + - numpy !=1.23.0 - pip - scikit-build >=0.15 - setuptools >=45 diff --git a/pyproject.toml b/pyproject.toml index cb13a95e..94af52dd 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -5,8 +5,7 @@ requires = [ "wheel", "scikit-build>=0.15", "cmake>=3.14", - # python-control/Slycot/issues/187 - "numpy<1.24"] + "numpy!=1.23.0"] build-backend = "setuptools.build_meta" [project] diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 46980725..eb49edd1 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -647,8 +647,7 @@ set(CMAKE_Fortran_FLAGS ) add_custom_target(wrapper ALL DEPENDS ${SLICOT_FSOURCE} ${SLYCOT_FSOURCE}) add_custom_command( OUTPUT _wrappermodule.c _wrapper-f2pywrappers.f - COMMAND ${F2PY_EXECUTABLE} -m SLYCOT - ${CMAKE_CURRENT_SOURCE_DIR}/${F2PYSOURCE} + COMMAND ${F2PY_EXECUTABLE} ${CMAKE_CURRENT_SOURCE_DIR}/${F2PYSOURCE} DEPENDS ${F2PYSOURCE_DEPS} ${F2PYSOURCE} ) From 8fca11eb2e05baf1fe7bed390be6c04848c33045 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 19 Dec 2022 13:37:17 +0100 Subject: [PATCH 325/405] require a recent coveralls --- .github/conda-env/test-env.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml index ac47f1ed..7d69d330 100644 --- a/.github/conda-env/test-env.yml +++ b/.github/conda-env/test-env.yml @@ -8,4 +8,4 @@ dependencies: - pytest-cov - pytest-timeout - coverage - - coveralls + - coveralls >= 3.3 From 68565e7eb6dd903d9e1f104aa308b947f5635070 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Sat, 24 Dec 2022 18:45:17 -0800 Subject: [PATCH 326/405] update workflow to pass jobname to python-control pytest --- .github/workflows/slycot-build-and-test.yml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 9c68b243..7d931e82 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -283,7 +283,9 @@ jobs: pip install slycot-wheels/${{ matrix.packagekey }}/slycot*.whl pip show slycot - name: Slycot and python-control tests - run: bash slycot-src/.github/scripts/run-tests.sh + run: JOBNAME=$JOBNAME bash slycot-src/.github/scripts/run-tests.sh + env: + JOBNAME: ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: report coverage env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -359,7 +361,9 @@ jobs: mamba install -c ./slycot-conda-pkgs slycot conda list - name: Slycot and python-control tests - run: bash slycot-src/.github/scripts/run-tests.sh + run: JOBNAME=$JOBNAME bash slycot-src/.github/scripts/run-tests.sh + env: + JOBNAME: ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: Report coverage env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} From 23c0093abc86a02d857d71043b3da35e7a324378 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Mon, 26 Dec 2022 07:51:47 -0800 Subject: [PATCH 327/405] add quotes to JOBNAME expansion --- .github/workflows/slycot-build-and-test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 7d931e82..1f45b719 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -283,7 +283,7 @@ jobs: pip install slycot-wheels/${{ matrix.packagekey }}/slycot*.whl pip show slycot - name: Slycot and python-control tests - run: JOBNAME=$JOBNAME bash slycot-src/.github/scripts/run-tests.sh + run: JOBNAME="$JOBNAME" bash slycot-src/.github/scripts/run-tests.sh env: JOBNAME: ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: report coverage @@ -361,7 +361,7 @@ jobs: mamba install -c ./slycot-conda-pkgs slycot conda list - name: Slycot and python-control tests - run: JOBNAME=$JOBNAME bash slycot-src/.github/scripts/run-tests.sh + run: JOBNAME="$JOBNAME" bash slycot-src/.github/scripts/run-tests.sh env: JOBNAME: ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: Report coverage From 73f575e8c08cc114bb1fc21ad8c1927718d91928 Mon Sep 17 00:00:00 2001 From: Richard Murray Date: Mon, 26 Dec 2022 08:49:44 -0800 Subject: [PATCH 328/405] add build type to JOBNAME --- .github/workflows/slycot-build-and-test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 1f45b719..050a6097 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -285,7 +285,7 @@ jobs: - name: Slycot and python-control tests run: JOBNAME="$JOBNAME" bash slycot-src/.github/scripts/run-tests.sh env: - JOBNAME: ${{ matrix.packagekey }} ${{ matrix.blas_lib }} + JOBNAME: wheel ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: report coverage env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -363,7 +363,7 @@ jobs: - name: Slycot and python-control tests run: JOBNAME="$JOBNAME" bash slycot-src/.github/scripts/run-tests.sh env: - JOBNAME: ${{ matrix.packagekey }} ${{ matrix.blas_lib }} + JOBNAME: conda ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: Report coverage env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} From 753f08caa4c8a0c543f40266c22192676178a94d Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 2 Feb 2023 20:13:50 +0100 Subject: [PATCH 329/405] Add lower numpy bound --- conda-recipe/meta.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 1f3314db..601aafed 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -27,7 +27,7 @@ requirements: - libcblas * *netlib - liblapack * *netlib - python - - numpy !=1.23.0 + - numpy >=1.19,!=1.23.0 - pip - scikit-build >=0.15 - setuptools >=45 From 02249d367fb75d28580a7de32f1ffab7905fe726 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 25 Apr 2023 21:04:19 +0200 Subject: [PATCH 330/405] Don't include package data --- setup.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/setup.py b/setup.py index 5ee3cb4f..230460fe 100644 --- a/setup.py +++ b/setup.py @@ -58,9 +58,10 @@ def run(self): # These need to stay in setup.py # https://scikit-build.readthedocs.io/en/latest/usage.html#setuptools-options -setup( +setup( packages=['slycot', 'slycot.tests'], cmdclass={'sdist': sdist_checked}, cmake_languages=('C', 'Fortran'), use_scm_version = True, + include_package_data = False, ) From 6c9394e892078e768ddea7b3434792f4b7318ba5 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Wed, 26 Apr 2023 09:33:28 +0200 Subject: [PATCH 331/405] Update SLICOT to 5.8 Update 1 --- slycot/src/SLICOT-Reference | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/SLICOT-Reference b/slycot/src/SLICOT-Reference index c1104834..979f39d7 160000 --- a/slycot/src/SLICOT-Reference +++ b/slycot/src/SLICOT-Reference @@ -1 +1 @@ -Subproject commit c1104834c7348b3412973bd86b063faa74219003 +Subproject commit 979f39d7863628407b0f9cae6804efc2833849ab From d3ef095fee99082fb2b0de7efe3a808e868eb591 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 25 Jun 2023 12:38:31 +0200 Subject: [PATCH 332/405] Check if likely-to-be-used Numpy include directory is from virtual environment Addresses gh-193, in that the user gets an error. --- CMakeLists.txt | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index d7b015c5..3cfa425f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -22,4 +22,18 @@ message(STATUS "F2PY headers included from: ${F2PY_INCLUDE_DIRS}") message(STATUS "LAPACK: ${LAPACK_LIBRARIES}") message(STATUS "BLAS: ${BLAS_LIBRARIES}") +# https://github.com/python-control/Slycot/issues/193 +if((EXISTS "${Python_INCLUDE_DIRS}/numpy") + AND (NOT ("${Python_INCLUDE_DIRS}/numpy" EQUAL "${Python_NumPy_INCLUDE_DIRS}"))) + + message(FATAL_ERROR + "Python include directory has a numpy sub-directory, + ${Python_INCLUDE_DIRS}/numpy, + which is different from Numpy include directory + ${Python_NumPy_INCLUDE_DIRS}. + You're probably building in a virtual environment, in which case + uninstall numpy from the base environment and try again.") + +endif() + add_subdirectory(slycot) From 601be641730718e7db045828025feaefaa2d6bdb Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 18 Aug 2023 22:47:24 +0200 Subject: [PATCH 333/405] Refactor imports, Update counts of routines --- slycot/__init__.py | 59 ++++++++++++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 6bd59014..3fe2fa8b 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -12,23 +12,47 @@ # import slycot.examples - # Analysis routines (15/40 wrapped) - from .analysis import ab01nd, ab05md, ab05nd, ab07nd, ab08nd, ab08nz - from .analysis import ab09ad, ab09ax, ab09bd, ab09md, ab09nd - from .analysis import ab13bd, ab13dd, ab13ed, ab13fd, ab13md + # The Slycot library is organised by 11-chapters. Each chapter can be identified by a single letter. + # The following chapters are included: + # A : Analysis Routines + # B : Benchmark + # C : Adaptive Control + # D : Data Analysis + # F : Filtering + # I : Identification + # M : Mathematical Routines + # N : Nonlinear Systems + # S : Synthesis Routines + # T : Transformation Routines + # U : Utility Routines - # Data analysis routines (0/7 wrapped) + # Analysis routines (16/60 wrapped) + from .analysis import (ab01nd, + ab05md, ab05nd, + ab07nd, + ab08nd, ab08nz, + ab09ad, ab09ax, ab09bd, ab09md, ab09nd, + ab13bd, ab13dd, ab13ed, ab13fd, ab13md) + + # Benchmark routines (0/6 wrapped) + + # Adaptive control routines (0/0 wrapped) + + # Data analysis routines (0/8 wrapped) # Filtering routines (0/6 wrapped) - # Identification routines (0/5 wrapped) + # Identification routines (0/15 wrapped) - # Mathematical routines (7/81 wrapped) - from .math import mc01td, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd + # Mathematical routines (7/281 wrapped) + from .math import (mc01td, + mb03rd, mb03vd, mb03vy, mb03wd, + mb05md, mb05nd) - # Synthesis routines (15/50 wrapped) + # Nonlinear Systems (0/16 wrapped) + # Synthesis routines ((15+1)/131 wrapped), sb03md57 is not part of slicot from .synthesis import (sb01bd, sb02md, sb02mt, sb02od, sb03md, sb03md57, sb03od, @@ -38,12 +62,17 @@ sg03ad, sg03bd) - # Transformation routines (9/40 wrapped) - from .transform import tb01id, tb03ad, tb04ad - from .transform import tb05ad - from .transform import tc04ad, tc01od - from .transform import tf01md, tf01rd - from .transform import td04ad, tb01pd + # Transformation routines (10/77 wrapped) + from .transform import (tb01id, tb01pd, + tb03ad, + tb04ad, + tb05ad, + tc01od, tc04ad, + td04ad, + tf01md, tf01rd) + + # Utility routines (0/7 wrapped) + from .version import __version__ From beb629862af31e0242fa4aa7ddc0ab7f73a9ffbc Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 18 Aug 2023 22:56:51 +0200 Subject: [PATCH 334/405] Update comments, reorder imports --- slycot/__init__.py | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 3fe2fa8b..69527783 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -14,16 +14,16 @@ # The Slycot library is organised by 11-chapters. Each chapter can be identified by a single letter. # The following chapters are included: - # A : Analysis Routines + # A : Analysis Routines (included) # B : Benchmark # C : Adaptive Control # D : Data Analysis # F : Filtering # I : Identification - # M : Mathematical Routines + # M : Mathematical Routines (included) # N : Nonlinear Systems - # S : Synthesis Routines - # T : Transformation Routines + # S : Synthesis Routines (included) + # T : Transformation Routines (included) # U : Utility Routines @@ -46,9 +46,9 @@ # Identification routines (0/15 wrapped) # Mathematical routines (7/281 wrapped) - from .math import (mc01td, - mb03rd, mb03vd, mb03vy, mb03wd, - mb05md, mb05nd) + from .math import (mb03rd, mb03vd, mb03vy, mb03wd, + mb05md, mb05nd, + mc01td) # Nonlinear Systems (0/16 wrapped) @@ -61,7 +61,6 @@ sg02ad, sg03ad, sg03bd) - # Transformation routines (10/77 wrapped) from .transform import (tb01id, tb01pd, tb03ad, From 3598ac9e06a60151f75321da95c79311aad78b5c Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 20 Jul 2023 22:29:00 +0200 Subject: [PATCH 335/405] Add ab04md wrapper --- slycot/__init__.py | 3 ++- slycot/analysis.py | 17 +++++++++++++++++ slycot/src/analysis.pyf | 20 ++++++++++++++++++++ 3 files changed, 39 insertions(+), 1 deletion(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 69527783..32b4a5db 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -27,8 +27,9 @@ # U : Utility Routines - # Analysis routines (16/60 wrapped) + # Analysis routines (17/60 wrapped) from .analysis import (ab01nd, + ab04md, ab05md, ab05nd, ab07nd, ab08nd, ab08nz, diff --git a/slycot/analysis.py b/slycot/analysis.py index 32050236..d2edb67e 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -139,6 +139,23 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): Z = None return Ac, Bc, ncont, indcon, nblk, Z, tau +def ab04md(type_bn, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): + """ a,b,c,d = ab04md() + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['type_bn', 'n', 'm', 'p', 'alpha', 'beta', + 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, + 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'info'+hidden] + + if ldwork is None: + ldwork = max(n, 3*m) + + out = _wrapper.ab04md(type_bn, n, m, p, alpha, beta, A, B, C, D, ldwork=ldwork) + info=out[-1] + raise_if_slycot_error(info, arg_list) + + return out[:-1] def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): """ n,a,b,c,d = ab05md(n1,m1,p1,n2,p2,a1,b1,c1,d1,a2,b2,c2,d2,[uplo]) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 633ff6ec..28629e38 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -19,6 +19,26 @@ subroutine ab01nd(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwo integer :: ldwork = max(n,3*m) integer intent(out) :: info end subroutine ab01nd +subroutine ab04md(type_bn,n,m,p,alpha,beta,a,lda,b,ldb,c,ldc,d,ldd,iwork,dwork,ldwork,info) ! in AB04MD.f + character :: type_bn + integer check(n>=0) :: n + integer check(m>=0) :: m + integer check(p>=0) :: p + double precision intent(in) :: alpha + double precision intent(in) :: beta + double precision intent(in,out,copy), dimension(n,n),depend(n) :: a + integer intent(hide),depend(a) :: lda = shape(a,0) + double precision intent(in,out,copy), dimension(n,m),depend(n,m) :: b + integer intent(hide),depend(b) :: ldb = shape(b,0) + double precision intent(in,out,copy), dimension(p,n),depend(n,p) :: c + integer intent(hide),depend(c) :: ldc = shape(c,0) + double precision intent(in,out,copy), dimension(p,m),depend(m,p) :: d + integer intent(hide),depend(d) :: ldd = shape(d,0) + integer intent(hide,cache),dimension(n),depend(n) :: iwork + double precision intent(hide,cache),dimension(ldwork),depend(ldwork) :: dwork + integer :: ldwork = max(1,n) + integer intent(out) :: info +end subroutine ab04md subroutine ab05md(uplo,over,n1,m1,p1,n2,p2,a1,lda1,b1,ldb1,c1,ldc1,d1,ldd1,a2,lda2,b2,ldb2,c2,ldc2,d2,ldd2,n,a,lda,b,ldb,c,ldc,d,ldd,dwork,ldwork,info) ! in AB05MD.f character :: uplo = 'U' character intent(hide) :: over = 'N' ! not sure how the overlap works From 52cc0f8fae101ee03dd2013bb83e43cc51527a4c Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sat, 29 Jul 2023 18:22:47 +0200 Subject: [PATCH 336/405] Unittest added for ab04md. --- slycot/tests/CMakeLists.txt | 1 + slycot/tests/test_ab04md.py | 71 +++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+) create mode 100644 slycot/tests/test_ab04md.py diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt index 2aafab3f..80d751da 100644 --- a/slycot/tests/CMakeLists.txt +++ b/slycot/tests/CMakeLists.txt @@ -2,6 +2,7 @@ set(PYSOURCE __init__.py test_ab01.py + test_ab04md.py test_ab08n.py test_ag08bd.py test_examples.py diff --git a/slycot/tests/test_ab04md.py b/slycot/tests/test_ab04md.py new file mode 100644 index 00000000..39b156da --- /dev/null +++ b/slycot/tests/test_ab04md.py @@ -0,0 +1,71 @@ +# =================================================== +# ab08n* tests + +import unittest +from slycot import analysis +import numpy as np + +from scipy.linalg import eig +from numpy.testing import assert_equal, assert_allclose + + +class test_ab04md(unittest.TestCase): + """Test ab04md. + + Example data taken from + https://www.slicot.org/objects/software/shared/doc/AB04MD.html. + """ + + Ac = np.array([[1.0, 0.5], + [0.5, 1.0]]) + Bc = np.array([[0.0, -1.0], + [1.0, 0.0]]) + Cc = np.array([[-1.0, 0.0], + [0.0, 1.0]]) + Dc = np.array([[1.0, 0.0], + [0.0, -1.0]]) + + Ad = np.array([[-1.0, -4.0], + [-4.0, -1.0]]) + Bd = np.array([[2.8284, 0.0], + [0.0, -2.8284]]) + Cd = np.array([[0.0, 2.8284], + [-2.8284, 0.0]]) + Dd = np.array([[-1.0, 0.0], + [0.0, -3.0]]) + + def test_ab04md_cont_disc_cont(self): + """Test transformation from continuous - to discrete - to continuous time. + """ + + n, m = self.Bc.shape + p = self.Cc.shape[0] + + Ad_t, Bd_t, Cd_t, Dd_t = analysis.ab04md('C',n,m,p,self.Ac,self.Bc,self.Cc,self.Dc) + + Ac_t, Bc_t, Cc_t, Dc_t = analysis.ab04md('D',n,m,p,Ad_t,Bd_t,Cd_t,Dd_t) + + assert_allclose(self.Ac, Ac_t) + assert_allclose(self.Bc, Bc_t) + assert_allclose(self.Cc, Cc_t) + assert_allclose(self.Dc, Dc_t) + + def test_ab04md_disc_cont_disc(self): + """Test transformation from discrete - to continuous - to discrete time. + """ + + n, m = self.Bc.shape + p = self.Cc.shape[0] + + Ac_t, Bc_t, Cc_t, Dc_t = analysis.ab04md('D',n,m,p,self.Ad,self.Bd,self.Cd,self.Dd) + + Ad_t, Bd_t, Cd_t, Dd_t = analysis.ab04md('C',n,m,p,Ac_t,Bc_t,Cc_t,Dc_t) + + assert_allclose(self.Ad, Ad_t) + assert_allclose(self.Bd, Bd_t) + assert_allclose(self.Cd, Cd_t) + assert_allclose(self.Dd, Dd_t) + + +if __name__ == "__main__": + unittest.main() From 416b352ec96fe5b6221fe6c4c99d2a78479424a4 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sat, 29 Jul 2023 19:38:21 +0200 Subject: [PATCH 337/405] Add docstring, Change parameter name from type_bn to type_t --- slycot/analysis.py | 66 +++++++++++++++++++++++++++++++++++++---- slycot/src/analysis.pyf | 4 +-- 2 files changed, 63 insertions(+), 7 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index d2edb67e..7da8eae8 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -139,19 +139,75 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): Z = None return Ac, Bc, ncont, indcon, nblk, Z, tau -def ab04md(type_bn, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): - """ a,b,c,d = ab04md() +def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): + """ At,Bt,Ct,Dt = ab04md(type_bn, n, m, p, A, B, C, D, [alpha, beta,ldwork]) + + Parameters + ---------- + type_t : {'D','C'} + Indicates the type of the original system and the + transformation to be performed as follows: + = 'D': discrete-time -> continuous-time; + = 'C': continuous-time -> discrete-time. + n : input int + The order of the matrix A, the number of rows of matrix B and + the number of columns of matrix C. It represents the dimension of + the state vector. n > 0. + m : input int + The number of columns of matrix B. It represents the dimension of + the input vector. m > 0. + p : input int + The number of rows of matrix C. It represents the dimension of + the output vector. p > 0. + A : input rank-2 array('d') with bounds (n,n) + The leading n-by-n part of this array must contain the system state + matrix A. + B : input rank-2 array('d') with bounds (n,m) + The leading n-by-m part of this array must contain the system input + matrix B. + C : input rank-2 array('d') with bounds (p,n) + The leading p-by-n part of this array must contain the system output + matrix C. + D : input rank-2 array('d') with bounds (p,m) + The leading p-by-m part of this array must contain the system direct + transmission matrix D. + alpha : double + Parameter specifying the bilinear transformation. + Recommended values for stable systems: alpha = 1, alpha != 0, + beta : double + Parameter specifying the bilinear transformation. + Recommended values for stable systems: beta = 1, beta != 0, + ldwork : int + The length of the cache array. + ldwork >= max(1, n) + Returns + ------- + At : output rank-2 array('d') with bounds (n,n) + The state matrix At of the transformed system. + Bt : output rank-2 array('d') with bounds (n,m) + The input matrix Bt of the transformed system. + Ct : output rank-2 array('d') with bounds (p,n) + The output matrix Ct of the transformed system. + Dt : output rank-2 array('d') with bounds (p,m) + The transmission matrix Dt of the transformed system. + Raises + ------ + SlycotArithmeticError + :info == 1: + If the matrix (ALPHA*I + A) is exactly singular + :info == 2: + If the matrix (BETA*I - A) is exactly singular. """ hidden = ' (hidden by the wrapper)' - arg_list = ['type_bn', 'n', 'm', 'p', 'alpha', 'beta', + arg_list = ['type_t', 'n', 'm', 'p', 'alpha', 'beta', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, 'C', 'LDC'+hidden, 'D', 'LDD'+hidden, 'IWORK'+hidden, 'DWORK'+hidden, 'ldwork', 'info'+hidden] if ldwork is None: - ldwork = max(n, 3*m) + ldwork = max(1, n) - out = _wrapper.ab04md(type_bn, n, m, p, alpha, beta, A, B, C, D, ldwork=ldwork) + out = _wrapper.ab04md(type_t, n, m, p, alpha, beta, A, B, C, D, ldwork=ldwork) info=out[-1] raise_if_slycot_error(info, arg_list) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 28629e38..b2bb5a12 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -19,8 +19,8 @@ subroutine ab01nd(jobz,n,m,a,lda,b,ldb,ncont,indcon,nblk,z,ldz,tau,tol,iwork,dwo integer :: ldwork = max(n,3*m) integer intent(out) :: info end subroutine ab01nd -subroutine ab04md(type_bn,n,m,p,alpha,beta,a,lda,b,ldb,c,ldc,d,ldd,iwork,dwork,ldwork,info) ! in AB04MD.f - character :: type_bn +subroutine ab04md(type_t,n,m,p,alpha,beta,a,lda,b,ldb,c,ldc,d,ldd,iwork,dwork,ldwork,info) ! in AB04MD.f + character :: type_t integer check(n>=0) :: n integer check(m>=0) :: m integer check(p>=0) :: p From 6643167d1d034f8c3a8ac8e86190400d037dc40a Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Mon, 7 Aug 2023 21:52:58 +0200 Subject: [PATCH 338/405] Update slycot/analysis.py Co-authored-by: Ben Greiner --- slycot/analysis.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 7da8eae8..41162852 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -149,7 +149,7 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): transformation to be performed as follows: = 'D': discrete-time -> continuous-time; = 'C': continuous-time -> discrete-time. - n : input int + n : int The order of the matrix A, the number of rows of matrix B and the number of columns of matrix C. It represents the dimension of the state vector. n > 0. From fe5c56aaf5b011d765ab77410543021496d4c70e Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Mon, 7 Aug 2023 22:11:15 +0200 Subject: [PATCH 339/405] Update docstring (remove input mark from int types) --- slycot/analysis.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 41162852..ea1227d2 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -153,10 +153,10 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): The order of the matrix A, the number of rows of matrix B and the number of columns of matrix C. It represents the dimension of the state vector. n > 0. - m : input int + m : int The number of columns of matrix B. It represents the dimension of the input vector. m > 0. - p : input int + p : int The number of rows of matrix C. It represents the dimension of the output vector. p > 0. A : input rank-2 array('d') with bounds (n,n) From 8ad02364625a54de094901f9b5a309d8f04aeebe Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Mon, 7 Aug 2023 22:33:37 +0200 Subject: [PATCH 340/405] Improve docstring --- slycot/analysis.py | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index ea1227d2..4fbe7678 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -159,16 +159,16 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): p : int The number of rows of matrix C. It represents the dimension of the output vector. p > 0. - A : input rank-2 array('d') with bounds (n,n) + A : (n,n) ndarray The leading n-by-n part of this array must contain the system state matrix A. - B : input rank-2 array('d') with bounds (n,m) + B : (n,m) ndarray The leading n-by-m part of this array must contain the system input matrix B. - C : input rank-2 array('d') with bounds (p,n) + C : (p,n) ndarray The leading p-by-n part of this array must contain the system output matrix C. - D : input rank-2 array('d') with bounds (p,m) + D : (p,m) ndarray The leading p-by-m part of this array must contain the system direct transmission matrix D. alpha : double @@ -182,13 +182,13 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): ldwork >= max(1, n) Returns ------- - At : output rank-2 array('d') with bounds (n,n) + At : (n,n) ndarray The state matrix At of the transformed system. - Bt : output rank-2 array('d') with bounds (n,m) + Bt : (n,m) ndarray The input matrix Bt of the transformed system. - Ct : output rank-2 array('d') with bounds (p,n) + Ct : (p,n) ndarray The output matrix Ct of the transformed system. - Dt : output rank-2 array('d') with bounds (p,m) + Dt : (p,m) ndarray The transmission matrix Dt of the transformed system. Raises ------ From 2289d93bbf8eb579327da9e6087d7753b7888932 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Wed, 23 Aug 2023 21:55:47 +0200 Subject: [PATCH 341/405] Update docstring, minor fixes --- slycot/analysis.py | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 4fbe7678..f84ff43f 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -140,7 +140,7 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): return Ac, Bc, ncont, indcon, nblk, Z, tau def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): - """ At,Bt,Ct,Dt = ab04md(type_bn, n, m, p, A, B, C, D, [alpha, beta,ldwork]) + """ At,Bt,Ct,Dt = ab04md(type_t, n, m, p, A, B, C, D, [alpha, beta,ldwork]) Parameters ---------- @@ -159,27 +159,29 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): p : int The number of rows of matrix C. It represents the dimension of the output vector. p > 0. - A : (n,n) ndarray + A : (n,n) array_like The leading n-by-n part of this array must contain the system state matrix A. - B : (n,m) ndarray + B : (n,m) array_like The leading n-by-m part of this array must contain the system input matrix B. - C : (p,n) ndarray + C : (p,n) array_like The leading p-by-n part of this array must contain the system output matrix C. - D : (p,m) ndarray + D : (p,m) array_like The leading p-by-m part of this array must contain the system direct transmission matrix D. - alpha : double + alpha : double, optional Parameter specifying the bilinear transformation. Recommended values for stable systems: alpha = 1, alpha != 0, - beta : double + Default is 1.0. + beta : double, optional Parameter specifying the bilinear transformation. Recommended values for stable systems: beta = 1, beta != 0, - ldwork : int + Default is 1.0. + ldwork : int, optional The length of the cache array. - ldwork >= max(1, n) + ldwork >= max(1, n), default is max(1, n) Returns ------- At : (n,n) ndarray From 75b1fdf13b68fba45ef7b2d2c3bdf991d2be4f26 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Wed, 19 Jul 2023 22:17:28 +0200 Subject: [PATCH 342/405] Fix datatype and value check of parameter (m,p) --- slycot/src/analysis.pyf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 633ff6ec..c306b114 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -305,8 +305,8 @@ function ab13bd(dico,jobn,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nq,tol,dwork,ldwork,iwar character intent(in) :: dico character intent(in) :: jobn integer check(n>=0) :: n - integer check(n>=0) :: m - integer check(n>=0) :: p + integer check(m>=0) :: m + integer check(p>=0) :: p double precision dimension(n,n),depend(n) :: a integer intent(hide),depend(a) :: lda = shape(a,0) double precision dimension(n,m),depend(n,m) :: b From 14472a620857f4628c61db775fcde9c500a505fa Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Wed, 19 Jul 2023 22:34:55 +0200 Subject: [PATCH 343/405] Add shallow copy to ab13bd, fix reference call of state space parameters (A,B,C,D) --- slycot/analysis.py | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index 32050236..d41e2043 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1378,13 +1378,19 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): denominator of `G` (see the SLICOT subroutine SB08DD). """ - out = _wrapper.ab13bd(dico, jobn, n, m, p, A, B, C, D, tol) - hidden = ' (hidden by the wrapper)' arg_list = ('dico', 'jobn', 'n', 'm', 'p', 'A', 'lda' + hidden, 'B', 'ldb' + hidden, 'C', 'ldc' + hidden, 'D', 'ldd' + hidden, 'nq' + hidden,'tol', 'dwork' + hidden, 'ldwork' + hidden, 'iwarn', 'info') + + a = A.copy() + b = B.copy() + c = C.copy() + d = D.copy() + + out = _wrapper.ab13bd(dico, jobn, n, m, p, a, b, c, d, tol) + raise_if_slycot_error(out[-2:], arg_list, ab13bd.__doc__, locals()) return out[0] From f93ef4778070ff57cf354e60a9fe4f5c14b9e4f2 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 20 Jul 2023 19:27:05 +0200 Subject: [PATCH 344/405] Remove shallow copy of A,B,C,D; Add intent(in,out,copy) in pyf --- slycot/analysis.py | 7 +------ slycot/src/analysis.pyf | 8 ++++---- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index d41e2043..9542fdaa 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1384,12 +1384,7 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): 'D', 'ldd' + hidden, 'nq' + hidden,'tol', 'dwork' + hidden, 'ldwork' + hidden, 'iwarn', 'info') - a = A.copy() - b = B.copy() - c = C.copy() - d = D.copy() - - out = _wrapper.ab13bd(dico, jobn, n, m, p, a, b, c, d, tol) + out = _wrapper.ab13bd(dico, jobn, n, m, p, A, B, C, D, tol) raise_if_slycot_error(out[-2:], arg_list, ab13bd.__doc__, locals()) return out[0] diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index c306b114..663c4747 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -307,13 +307,13 @@ function ab13bd(dico,jobn,n,m,p,a,lda,b,ldb,c,ldc,d,ldd,nq,tol,dwork,ldwork,iwar integer check(n>=0) :: n integer check(m>=0) :: m integer check(p>=0) :: p - double precision dimension(n,n),depend(n) :: a + double precision intent(in,out,copy), dimension(n,n),depend(n) :: a integer intent(hide),depend(a) :: lda = shape(a,0) - double precision dimension(n,m),depend(n,m) :: b + double precision intent(in,out,copy), dimension(n,m),depend(n,m) :: b integer intent(hide),depend(b) :: ldb = shape(b,0) - double precision dimension(p,n),depend(n,p) :: c + double precision intent(in,out,copy), dimension(p,n),depend(n,p) :: c integer intent(hide),depend(c) :: ldc = shape(c,0) - double precision dimension(p,m),depend(m,p) :: d + double precision intent(in,out,copy), dimension(p,m),depend(m,p) :: d integer intent(hide),depend(d) :: ldd = shape(d,0) integer intent(out) :: nq double precision :: tol From 823fda99e79811b768e712f4b39e3e4107e4824a Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sun, 30 Jul 2023 16:23:53 +0200 Subject: [PATCH 345/405] Add unittest to ad13bd --- slycot/tests/test_ab13bd.py | 123 ++++++++++++++++++++++++++++++++++++ 1 file changed, 123 insertions(+) create mode 100644 slycot/tests/test_ab13bd.py diff --git a/slycot/tests/test_ab13bd.py b/slycot/tests/test_ab13bd.py new file mode 100644 index 00000000..885777a5 --- /dev/null +++ b/slycot/tests/test_ab13bd.py @@ -0,0 +1,123 @@ +# =================================================== +# ab08n* tests + +import unittest +from slycot import analysis +import numpy as np + +from scipy import linalg +from scipy import signal +from numpy.testing import assert_equal, assert_allclose, assert_array_equal + +class test_ab13bd(unittest.TestCase): + """ Test regular pencil construction ab08nX with input parameters + according to example in documentation """ + + A = np.array([[0.0, 1.0],[-0.5, -0.1]]) + B = np.array([[0.],[1.]]) + C = np.eye(2) + D = np.zeros((2,1)) + + Ad, Bd, Cd, Dd, dt = signal.cont2discrete((A, B, C, D), 0.1, method='zoh') + + def test_no_change_args_ccase(self): + """ ab13md must not change its arguments. continuous system case. + """ + + acopy = self.A.copy() + bcopy = self.B.copy() + ccopy = self.C.copy() + dcopy = self.D.copy() + + dico = 'C' + jobn = 'H' + + n, m = self.B.shape + p = self.C.shape[0] + + analysis.ab13bd(dico, jobn, n, m, p, self.A, self.B, self.C, self.D) + assert_array_equal(self.A, acopy) + assert_array_equal(self.B, bcopy) + assert_array_equal(self.C, ccopy) + assert_array_equal(self.D, dcopy) + + def test_no_change_args_dcase(self): + """ ab13md must not change its arguments. discrete system case. + """ + + acopy = self.Ad.copy() + bcopy = self.Bd.copy() + ccopy = self.Cd.copy() + dcopy = self.Dd.copy() + + dico = 'D' + jobn = 'H' + + n, m = self.Bd.shape + p = self.Cd.shape[0] + + analysis.ab13bd(dico, jobn, n, m, p, self.Ad, self.Bd, self.Cd, self.Dd) + assert_array_equal(self.Ad, acopy) + assert_array_equal(self.Bd, bcopy) + assert_array_equal(self.Cd, ccopy) + assert_array_equal(self.Dd, dcopy) + + def test_ab13bd_2norm_ccase(self): + """ Compare ab13md with scipy solution (Lyapunov Equation). + continuous system case. + """ + + A = self.A + B = self.B + C = self.C + D = self.D + + n, m = self.B.shape + p = self.C.shape[0] + + dico = 'C' + jobn = 'H' + + h2norm = analysis.ab13bd(dico, jobn, n, m, p, A, B, C, D) + + Lc = linalg.solve_continuous_lyapunov(A, -B@B.T) + h2norm_Lc = np.sqrt(np.trace(C@Lc@C.T)) + print(h2norm_Lc, h2norm) + assert_allclose(h2norm_Lc, h2norm, atol=1e-5) + + Lo = linalg.solve_continuous_lyapunov(A.T, -C.T@C) + h2norm_Lo = np.sqrt(np.trace(B.T@Lo@B)) + print(h2norm_Lo, h2norm) + assert_allclose(h2norm_Lo, h2norm, atol=1e-5) + + def test_ab13bd_2norm_dcase(self): + """ Compare ab13md with scipy solution (Lyapunov Equation). + discrete system case. + """ + + Ad = self.Ad + Bd = self.Bd + Cd = self.Cd + Dd = self.Dd + + n, m = Bd.shape + p = Cd.shape[0] + + dico = 'D' + jobn = 'H' + + h2norm = analysis.ab13bd(dico, jobn, n, m, p, Ad, Bd, Cd, Dd) + + Lc = linalg.solve_discrete_lyapunov(Ad, Bd@Bd.T) + h2norm_Lc = np.sqrt(np.trace(Cd@Lc@Cd.T + Dd@Dd.T)) + print(h2norm, h2norm_Lc) + assert_allclose(h2norm_Lc, h2norm, atol=1e-5) + + Lo = linalg.solve_discrete_lyapunov(Ad.T, Cd.T@Cd) + h2norm_Lo = np.sqrt(np.trace(Bd.T@Lo@Bd + Dd.T@Dd)) + print(h2norm, h2norm_Lo) + assert_allclose(h2norm_Lo, h2norm, atol=1e-5) + + +if __name__ == "__main__": + unittest.main() From 118bf588f69168f6afc99d4fdd01bf40bc7241ab Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 24 Aug 2023 10:13:04 +0200 Subject: [PATCH 346/405] cleanup test file --- slycot/tests/test_ab04md.py | 47 +++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 26 deletions(-) diff --git a/slycot/tests/test_ab04md.py b/slycot/tests/test_ab04md.py index 39b156da..7ce59a0e 100644 --- a/slycot/tests/test_ab04md.py +++ b/slycot/tests/test_ab04md.py @@ -1,38 +1,33 @@ -# =================================================== -# ab08n* tests - -import unittest from slycot import analysis import numpy as np -from scipy.linalg import eig -from numpy.testing import assert_equal, assert_allclose +from numpy.testing import assert_allclose -class test_ab04md(unittest.TestCase): +class test_ab04md: """Test ab04md. - + Example data taken from - https://www.slicot.org/objects/software/shared/doc/AB04MD.html. + https://www.slicot.org/objects/software/shared/doc/AB04MD.html """ Ac = np.array([[1.0, 0.5], - [0.5, 1.0]]) + [0.5, 1.0]]) Bc = np.array([[0.0, -1.0], - [1.0, 0.0]]) + [1.0, 0.0]]) Cc = np.array([[-1.0, 0.0], - [0.0, 1.0]]) + [0.0, 1.0]]) Dc = np.array([[1.0, 0.0], - [0.0, -1.0]]) + [0.0, -1.0]]) Ad = np.array([[-1.0, -4.0], - [-4.0, -1.0]]) + [-4.0, -1.0]]) Bd = np.array([[2.8284, 0.0], - [0.0, -2.8284]]) + [0.0, -2.8284]]) Cd = np.array([[0.0, 2.8284], - [-2.8284, 0.0]]) + [-2.8284, 0.0]]) Dd = np.array([[-1.0, 0.0], - [0.0, -3.0]]) + [0.0, -3.0]]) def test_ab04md_cont_disc_cont(self): """Test transformation from continuous - to discrete - to continuous time. @@ -41,15 +36,17 @@ def test_ab04md_cont_disc_cont(self): n, m = self.Bc.shape p = self.Cc.shape[0] - Ad_t, Bd_t, Cd_t, Dd_t = analysis.ab04md('C',n,m,p,self.Ac,self.Bc,self.Cc,self.Dc) + Ad_t, Bd_t, Cd_t, Dd_t = analysis.ab04md( + 'C', n, m, p, self.Ac, self.Bc, self.Cc, self.Dc) - Ac_t, Bc_t, Cc_t, Dc_t = analysis.ab04md('D',n,m,p,Ad_t,Bd_t,Cd_t,Dd_t) + Ac_t, Bc_t, Cc_t, Dc_t = analysis.ab04md( + 'D', n, m, p, Ad_t, Bd_t, Cd_t, Dd_t) assert_allclose(self.Ac, Ac_t) assert_allclose(self.Bc, Bc_t) assert_allclose(self.Cc, Cc_t) assert_allclose(self.Dc, Dc_t) - + def test_ab04md_disc_cont_disc(self): """Test transformation from discrete - to continuous - to discrete time. """ @@ -57,15 +54,13 @@ def test_ab04md_disc_cont_disc(self): n, m = self.Bc.shape p = self.Cc.shape[0] - Ac_t, Bc_t, Cc_t, Dc_t = analysis.ab04md('D',n,m,p,self.Ad,self.Bd,self.Cd,self.Dd) + Ac_t, Bc_t, Cc_t, Dc_t = analysis.ab04md( + 'D', n, m, p, self.Ad, self.Bd, self.Cd, self.Dd) - Ad_t, Bd_t, Cd_t, Dd_t = analysis.ab04md('C',n,m,p,Ac_t,Bc_t,Cc_t,Dc_t) + Ad_t, Bd_t, Cd_t, Dd_t = analysis.ab04md( + 'C', n, m, p, Ac_t, Bc_t, Cc_t, Dc_t) assert_allclose(self.Ad, Ad_t) assert_allclose(self.Bd, Bd_t) assert_allclose(self.Cd, Cd_t) assert_allclose(self.Dd, Dd_t) - - -if __name__ == "__main__": - unittest.main() From 0175171fa8c526e91e2a281f402552b31cb72364 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 24 Aug 2023 21:49:59 +0200 Subject: [PATCH 347/405] replace unittest --- slycot/tests/test_ab04md.py | 2 +- slycot/tests/test_ab08n.py | 7 +- slycot/tests/test_ab13bd.py | 6 +- slycot/tests/test_ag08bd.py | 145 ++++----- slycot/tests/test_mb.py | 618 ++++++++++++++++++------------------ slycot/tests/test_sg02ad.py | 65 ++-- slycot/tests/test_sg03ad.py | 101 +++--- slycot/tests/test_tb05ad.py | 430 ++++++++++++------------- slycot/tests/test_td04ad.py | 431 +++++++++++++------------ slycot/tests/test_tg01ad.py | 24 +- slycot/tests/test_tg01fd.py | 91 +++--- 11 files changed, 930 insertions(+), 990 deletions(-) diff --git a/slycot/tests/test_ab04md.py b/slycot/tests/test_ab04md.py index 7ce59a0e..076c4a6c 100644 --- a/slycot/tests/test_ab04md.py +++ b/slycot/tests/test_ab04md.py @@ -4,7 +4,7 @@ from numpy.testing import assert_allclose -class test_ab04md: +class Test_ab04md: """Test ab04md. Example data taken from diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py index 06fd0c0d..130ae95d 100644 --- a/slycot/tests/test_ab08n.py +++ b/slycot/tests/test_ab08n.py @@ -1,7 +1,6 @@ # =================================================== # ab08n* tests -import unittest from slycot import analysis import numpy as np @@ -9,7 +8,7 @@ from numpy.testing import assert_equal, assert_allclose -class test_ab08nX(unittest.TestCase): +class Test_ab08nX: """ Test regular pencil construction ab08nX with input parameters according to example in documentation """ @@ -77,7 +76,3 @@ def test_ab08nz(self): Ac, Bc, Cc, Dc = [M.astype(np.complex128) for M in [self.A, self.B, self.C, self.D]] self.ab08nX(analysis.ab08nz, Ac, Bc, Cc, Dc) - - -if __name__ == "__main__": - unittest.main() diff --git a/slycot/tests/test_ab13bd.py b/slycot/tests/test_ab13bd.py index 885777a5..db4a2bd7 100644 --- a/slycot/tests/test_ab13bd.py +++ b/slycot/tests/test_ab13bd.py @@ -1,7 +1,6 @@ # =================================================== # ab08n* tests -import unittest from slycot import analysis import numpy as np @@ -9,7 +8,7 @@ from scipy import signal from numpy.testing import assert_equal, assert_allclose, assert_array_equal -class test_ab13bd(unittest.TestCase): +class Test_ab13bd: """ Test regular pencil construction ab08nX with input parameters according to example in documentation """ @@ -118,6 +117,3 @@ def test_ab13bd_2norm_dcase(self): print(h2norm, h2norm_Lo) assert_allclose(h2norm_Lo, h2norm, atol=1e-5) - -if __name__ == "__main__": - unittest.main() diff --git a/slycot/tests/test_ag08bd.py b/slycot/tests/test_ag08bd.py index 7c0706aa..e849cef4 100644 --- a/slycot/tests/test_ag08bd.py +++ b/slycot/tests/test_ag08bd.py @@ -1,7 +1,5 @@ -# =================================================== -# ag08bd tests +"""Verify ag08bd with input parameters according to example in documentation.""" -import unittest from slycot import analysis import numpy as np @@ -47,77 +45,70 @@ [ 0, 0, 0]]) -class test_ag08bd(unittest.TestCase): - """Verify ag08bd with input parameters according to example in documentation.""" - - def test1_ag08bd(self): - """test [A-lambda*E] - - B,C,D must have correct dimensions according to l,n,m and p, but cannot - have zero length in any dimenstion. Then the wrapper will complain. - The length is then set to one. - """ - - Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=0,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=np.zeros((1,test1_n)),D=np.zeros((1,1)),equil=test1_equil, tol=test1_tol) - - assert_equal(Af, np.zeros((0,0))) - assert_equal(Ef, np.zeros((0,0))) - assert_equal(nrank, 9) - assert_equal(niz, 6) - assert_equal(infz, [0,3]) - assert_equal(kronr, []) - assert_equal(infe, [3,3,3]) - assert_equal(kronl, []) - - def test2_ag08bd(self): - """test [A-lambda*E;C] - - B,D must have correct dimensions as before - """ - - Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=test1_p,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=test1_C,D=np.zeros((test1_p,1)),equil=test1_equil, tol=test1_tol) - - assert_equal(Af, np.zeros((0,0))) - assert_equal(Ef, np.zeros((0,0))) - assert_equal(nrank, 9) - assert_equal(niz, 4) - assert_equal(infz, [0,2]) - assert_equal(kronr, []) - assert_equal(infe, [1,3,3]) - assert_equal(kronl, [0,1,1]) - - def test3_ag08bd(self): - """test [A-lambda*E,B] - - C,D must have correct dimensions as before - """ - - Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=0,A=test1_A,E=test1_E,B=test1_B,C=np.zeros((1,test1_n)),D=np.zeros((1,test1_m)),equil=test1_equil, tol=test1_tol) - - assert_equal(Af, np.zeros((0,0))) - assert_equal(Ef, np.zeros((0,0))) - assert_equal(nrank, 9) - assert_equal(niz, 0) - assert_equal(infz, []) - assert_equal(kronr, [2,2,2]) - assert_equal(infe, [1,1,1]) - assert_equal(kronl, []) - - def test4_ag08bd(self): - """test [A-lambda*E,B;C,D]""" - - Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,D=test1_D,equil=test1_equil, tol=test1_tol) - - # Af-lambda*Ef==0. => lambda==1. => Finite Smith zero of S(lambda) == 1. - assert Af.shape == (1, 1) - assert_almost_equal(Af, Ef) - assert_equal(nrank, 11) - assert_equal(niz, 2) - assert_equal(infz, [0,1]) - assert_equal(kronr, [2]) - assert_equal(infe, [1,1,1,1,3]) - assert_equal(kronl, [1]) - - -if __name__ == "__main__": - unittest.main() +def test1_ag08bd(): + """test [A-lambda*E] + + B,C,D must have correct dimensions according to l,n,m and p, but cannot + have zero length in any dimenstion. Then the wrapper will complain. + The length is then set to one. + """ + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=0,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=np.zeros((1,test1_n)),D=np.zeros((1,1)),equil=test1_equil, tol=test1_tol) + + assert_equal(Af, np.zeros((0,0))) + assert_equal(Ef, np.zeros((0,0))) + assert_equal(nrank, 9) + assert_equal(niz, 6) + assert_equal(infz, [0,3]) + assert_equal(kronr, []) + assert_equal(infe, [3,3,3]) + assert_equal(kronl, []) + +def test2_ag08bd(): + """test [A-lambda*E;C] + + B,D must have correct dimensions as before + """ + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=0,p=test1_p,A=test1_A,E=test1_E,B=np.zeros((test1_l,1)),C=test1_C,D=np.zeros((test1_p,1)),equil=test1_equil, tol=test1_tol) + + assert_equal(Af, np.zeros((0,0))) + assert_equal(Ef, np.zeros((0,0))) + assert_equal(nrank, 9) + assert_equal(niz, 4) + assert_equal(infz, [0,2]) + assert_equal(kronr, []) + assert_equal(infe, [1,3,3]) + assert_equal(kronl, [0,1,1]) + +def test3_ag08bd(): + """test [A-lambda*E,B] + + C,D must have correct dimensions as before + """ + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=0,A=test1_A,E=test1_E,B=test1_B,C=np.zeros((1,test1_n)),D=np.zeros((1,test1_m)),equil=test1_equil, tol=test1_tol) + + assert_equal(Af, np.zeros((0,0))) + assert_equal(Ef, np.zeros((0,0))) + assert_equal(nrank, 9) + assert_equal(niz, 0) + assert_equal(infz, []) + assert_equal(kronr, [2,2,2]) + assert_equal(infe, [1,1,1]) + assert_equal(kronl, []) + +def test4_ag08bd(): + """test [A-lambda*E,B;C,D]""" + + Af,Ef,nrank,niz,infz,kronr,infe,kronl = analysis.ag08bd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,D=test1_D,equil=test1_equil, tol=test1_tol) + + # Af-lambda*Ef==0. => lambda==1. => Finite Smith zero of S(lambda) == 1. + assert Af.shape == (1, 1) + assert_almost_equal(Af, Ef) + assert_equal(nrank, 11) + assert_equal(niz, 2) + assert_equal(infz, [0,1]) + assert_equal(kronr, [2]) + assert_equal(infe, [1,1,1,1,3]) + assert_equal(kronl, [1]) diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index 1c8e137e..cdb84433 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -3,325 +3,318 @@ # bnavigator , Aug 2019 import sys -import unittest -import pytest - -from slycot import math -from slycot import mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd -from slycot.exceptions import SlycotResultWarning, SlycotArithmeticError -from .test_exceptions import assert_docstring_parse import numpy as np +import pytest +from numpy.testing import assert_allclose from scipy.linalg import schur -from numpy.testing import assert_allclose +from slycot import math, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd +from slycot.exceptions import SlycotArithmeticError, SlycotResultWarning + +from .test_exceptions import assert_docstring_parse -class test_mb(unittest.TestCase): - - def test_mb03rd(self): - """ Test for Schur form reduction. - - RvP, 31 Jul 2019""" - - test1_A = np.array([ - [ 1., -1., 1., 2., 3., 1., 2., 3.], - [ 1., 1., 3., 4., 2., 3., 4., 2.], - [ 0., 0., 1., -1., 1., 5., 4., 1.], - [ 0., 0., 0., 1., -1., 3., 1., 2.], - [ 0., 0., 0., 1., 1., 2., 3., -1.], - [ 0., 0., 0., 0., 0., 1., 5., 1.], - [ 0., 0., 0., 0., 0., 0., 0.99999999, -0.99999999 ], - [ 0., 0., 0., 0., 0., 0., 0.99999999, 0.99999999 ] - ]) - test1_n = test1_A.shape[0] - - test1_Ar = np.array([ - [ 1.0000, -1.0000, -1.2247, -0.7071, -3.4186, 1.4577, 0.0000, 0.0000 ], - [ 1.0000, 1.0000, 0.0000, 1.4142, -5.1390, 3.1637, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 1.0000, -1.7321, -0.0016, 2.0701, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.5774, 1.0000, 0.7516, 1.1379, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -5.8606, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.1706, 1.0000, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -0.8850 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000 ], - ]) - - test1_Xr = np.array([ - [ 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.9045, 0.1957 ], - [ 0.0000, 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, -0.3015, 0.9755 ], - [ 0.0000, 0.0000, 0.8165, 0.0000, -0.5768, -0.0156, -0.3015, 0.0148 ], - [ 0.0000, 0.0000, -0.4082, 0.7071, -0.5768, -0.0156, 0.0000, -0.0534 ], - [ 0.0000, 0.0000, -0.4082, -0.7071, -0.5768, -0.0156, 0.0000, 0.0801 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, -0.0276, 0.9805, 0.0000, 0.0267 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0332, -0.0066, 0.0000, 0.0000 ], - [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0011, 0.1948, 0.0000, 0.0000 ] - ]) - - test1_W = np.array([1+1j, 1-1j, - 1+1j, 1-1j, - 0.99999+0.99999j, 0.99999-0.99999j, - 1., 1.]) - - test1_pmax = 1e3 - test1_tol = 0.01 - # create schur form with scipy - A, X = schur(test1_A) - Ah, Xh = np.copy(A), np.copy(X) - # on this basis, get the transform +def test_mb03rd(): + """ Test for Schur form reduction. + + RvP, 31 Jul 2019""" + + test1_A = np.array([ + [ 1., -1., 1., 2., 3., 1., 2., 3.], + [ 1., 1., 3., 4., 2., 3., 4., 2.], + [ 0., 0., 1., -1., 1., 5., 4., 1.], + [ 0., 0., 0., 1., -1., 3., 1., 2.], + [ 0., 0., 0., 1., 1., 2., 3., -1.], + [ 0., 0., 0., 0., 0., 1., 5., 1.], + [ 0., 0., 0., 0., 0., 0., 0.99999999, -0.99999999 ], + [ 0., 0., 0., 0., 0., 0., 0.99999999, 0.99999999 ] + ]) + test1_n = test1_A.shape[0] + + test1_Ar = np.array([ + [ 1.0000, -1.0000, -1.2247, -0.7071, -3.4186, 1.4577, 0.0000, 0.0000 ], + [ 1.0000, 1.0000, 0.0000, 1.4142, -5.1390, 3.1637, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 1.0000, -1.7321, -0.0016, 2.0701, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.5774, 1.0000, 0.7516, 1.1379, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -5.8606, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.1706, 1.0000, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000, -0.8850 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 1.0000 ], + ]) + + test1_Xr = np.array([ + [ 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.9045, 0.1957 ], + [ 0.0000, 1.0000, 0.0000, 0.0000, 0.0000, 0.0000, -0.3015, 0.9755 ], + [ 0.0000, 0.0000, 0.8165, 0.0000, -0.5768, -0.0156, -0.3015, 0.0148 ], + [ 0.0000, 0.0000, -0.4082, 0.7071, -0.5768, -0.0156, 0.0000, -0.0534 ], + [ 0.0000, 0.0000, -0.4082, -0.7071, -0.5768, -0.0156, 0.0000, 0.0801 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, -0.0276, 0.9805, 0.0000, 0.0267 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0332, -0.0066, 0.0000, 0.0000 ], + [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0011, 0.1948, 0.0000, 0.0000 ] + ]) + + test1_W = np.array([1+1j, 1-1j, + 1+1j, 1-1j, + 0.99999+0.99999j, 0.99999-0.99999j, + 1., 1.]) + + test1_pmax = 1e3 + test1_tol = 0.01 + # create schur form with scipy + A, X = schur(test1_A) + Ah, Xh = np.copy(A), np.copy(X) + # on this basis, get the transform + Ar, Xr, blsize, W = mb03rd( + test1_n, A, X, 'U', 'S', test1_pmax, test1_tol) + # ensure X and A are unchanged + assert_allclose(A, Ah) + assert_allclose(X, Xh) + # compare to test case results + assert_allclose(Ar, test1_Ar, atol=0.0001) + assert_allclose(Xr, test1_Xr, atol=0.0001) + assert_allclose(W, test1_W, atol=0.0001) + + # Test that the non sorting options do not throw errors and that Xr is + # returned as None for jobx='N' + for sort in ['N', 'C', 'B']: Ar, Xr, blsize, W = mb03rd( - test1_n, A, X, 'U', 'S', test1_pmax, test1_tol) - # ensure X and A are unchanged - assert_allclose(A, Ah) - assert_allclose(X, Xh) - # compare to test case results - assert_allclose(Ar, test1_Ar, atol=0.0001) - assert_allclose(Xr, test1_Xr, atol=0.0001) - assert_allclose(W, test1_W, atol=0.0001) - - # Test that the non sorting options do not throw errors and that Xr is - # returned as None for jobx='N' - for sort in ['N', 'C', 'B']: - Ar, Xr, blsize, W = mb03rd( - test1_n, A, X, 'N', sort, test1_pmax, test1_tol) - assert Xr is None - - def test_mb03rd_default(self): - # regression: mb03rd was failing with no third arg (X) supplied - A = np.array([[ 6, -1, -7, -2, 2], - [-3, 4, 2, -7, 6], - [-6, -9, -3, -1, 10], - [-2, -4, 1, 5, 7], - [-7, -5, -6, 6, 7]]) - - Aschur, Tschur = schur(A) - - X = Tschur.copy() - - Ar, Xr, blsize, W = mb03rd(Aschur.shape[0], Aschur, X, 'U', 'N', pmax=1.0, tol=0.0) - - Ar2, Xr2, blsize2, W2 = mb03rd(Aschur.shape[0], Aschur) - - assert_allclose(Ar, Ar2) - assert_allclose(Xr, Tschur.dot(Xr2)) - - def test_mb03vd_mb03vy_ex(self): - """Test MB03VD and MB03VY - with the example given in the MB03VD SLICOT documentation""" - - n = 4 - p = 2 - ilo = 1 - ihi = 4 - A = np.zeros((n, n, p)) - A[:, :, 0] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - A[:, :, 1] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - - H_ref = np.zeros((n, n, p)) - H_ref[:, :, 0] = [[-2.3926, 2.7042, -0.9598, -1.2335], - [ 4.1417, -1.7046, 1.3001, -1.3120], - [ 0.0000, -1.6247, -0.2534, 1.6453], - [ 0.0000, 0.0000, -0.0169, -0.4451]] - - H_ref[:, :, 1] = [[-2.5495, 2.3402, 4.7021, 0.2329], - [ 0.0000, 1.9725, -0.2483, -2.3493], - [ 0.0000, 0.0000, -0.6290, -0.5975], - [ 0.0000, 0.0000, 0.0000, -0.4426]] - - Q_ref = np.zeros((n, n, p)) - Q_ref[:, :, 0] = [[ 1.0000, 0.0000, 0.0000, 0.0000], - [ 0.0000, -0.7103, 0.5504, -0.4388], - [ 0.0000, -0.4735, -0.8349, -0.2807], - [ 0.0000, -0.5209, 0.0084, 0.8536]] - - Q_ref[:, :, 1] = [[-0.5883, 0.2947, 0.7528, -0.0145], - [-0.3922, -0.8070, 0.0009, -0.4415], - [-0.5883, 0.4292, -0.6329, -0.2630], - [-0.3922, -0.2788, -0.1809, 0.8577]] - - HQ, Tau = mb03vd(n, ilo, ihi, A) - - H = np.zeros_like(HQ) - Q = np.zeros_like(HQ) - - for k in range(p): - Q[:, :, k] = np.tril(HQ[:, :, k]) - if k == 0: - H[:, :, k] = np.triu(HQ[:n, :n, k], -1) - elif k > 0: - H[:, :, k] = np.triu(HQ[:n, :n, k]) - assert_allclose(H[:, :, k], H_ref[:, :, k], atol=1e-4) - - Qr = mb03vy(n, ilo, ihi, Q, Tau) - - for k in range(p): - assert_allclose(Qr[:, :, k], Q_ref[:, :, k], atol=1e-4) - - # Computer Error: too machine dependent to test to reference value - # SSQ_ref = 2.93760e-15 - # SSQ = 0. - # for k in range(p): - # kp1 = k+1 - # if kp1 > p-1: - # kp1 = 0 - # P = Qr[:, :, k].T.dot(A[: ,: ,k]).dot(Qr[: ,: ,kp1]) - H[: ,: ,k] - # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) - - def test_mb03wd_ex(self): - """Test MB03WD with the example given in the SLICOT documentation""" - - n = 4 - p = 2 - ilo = 1 - ihi = 4 - iloz = 1 - ihiz = 4 - job = 'S' - compz = 'V' - A = np.zeros((n, n, p)) - A[:, :, 0] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - A[:, :, 1] = [[1.5, -.7, 3.5, -.7], - [1. , 0. , 2. , 3. ], - [1.5, -.7, 2.5, -.3], - [1. , 0. , 2. , 1. ]] - - W_ref = np.array([6.449861+7.817717J, - 6.449861-7.817717J, - 0.091315+0.000000J, - 0.208964+0.000000J]) - - T_ref = np.zeros((n, n, p)) - T_ref[:, :, 0] = [[ 2.2112, 4.3718, -2.3362, 0.8907], - [ -0.9179, 2.7688, -0.6570, -2.2426], - [ 0.0000, 0.0000, 0.3022, 0.1932], - [ 0.0000, 0.0000, 0.0000, -0.4571]] - - T_ref[:, :, 1] = [[ 2.9169, 3.4539, 2.2016, 1.2367], - [ 0.0000, 3.4745, 1.0209, -2.0720], - [ 0.0000, 0.0000, 0.3022, -0.1932], - [ 0.0000, 0.0000, 0.0000, -0.4571]] - - Z_ref = np.zeros((n, n, p)) - Z_ref[:, :, 0] = [[ 0.3493, 0.6751, -0.6490, 0.0327], - [ 0.7483, -0.4863, -0.1249, -0.4336], - [ 0.2939, 0.5504, 0.7148, -0.3158], - [ 0.4813, -0.0700, 0.2286, 0.8433]] - - - Z_ref[:, :, 1] = [[ 0.2372, 0.7221, 0.6490, 0.0327], - [ 0.8163, -0.3608, 0.1249, -0.4336], - [ 0.2025, 0.5902, -0.7148, -0.3158], - [ 0.4863, 0.0076, -0.2286, 0.8433]] - - HQ, Tau = mb03vd(n, ilo, ihi, A) - Q = mb03vy(n, ilo, ihi, HQ, Tau) - T, Z, W = mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, HQ, Q) - - # TODO (?) - # isolate eigenvalues with math.mb03wx - - assert_allclose(W, W_ref, atol=1e-5) - assert_allclose(T, T_ref, atol=1e-4) - assert_allclose(Z, Z_ref, atol=1e-4) - - # Computer Error: too machine dependent to test to reference value - # SSQ_ref = 7.18432D-15 - # SSQ = 0. - # for k in range(p): - # kp1 = k+1 - # if kp1 > p-1: - # kp1 = 0 - # P = Zrr[:, :, k].T.dot(A[: ,: ,k]).dot(Zrr[: ,: ,kp1]) - Hrr[: ,: ,k] - # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) - - - def test_mb05md(self): - """ test_mb05md: verify Matrix exponential with slicot doc example - - data from http://slicot.org/objects/software/shared/doc/MB05MD.html - """ - A = np.array([[ 0.5, 0., 2.3, -2.6], - [ 0., 0.5, -1.4, -0.7], - [ 2.3, -1.4, 0.5, 0.0], - [-2.6, -0.7, 0.0, 0.5]]) - delta = 1.0 - Ar_ref = np.array([[ 26.8551, -3.2824, 18.7409, -19.4430], - [ -3.2824, 4.3474, -5.1848, 0.2700], - [ 18.7409, -5.1848, 15.6012, -11.7228], - [ -19.4430, 0.2700, -11.7228, 15.6012]]) - Vr_ref = np.array([[-0.7, 0.7, 0.1, -0.1], - [ 0.1, -0.1, 0.7, -0.7], - [ 0.5, 0.5, 0.5, 0.5], - [-0.5, -0.5, 0.5, 0.5]]) - Yr_ref = np.array([[ -0.0349, 0.0050, 0.0249, -0.0249], - [ 38.2187, -5.4598, 27.2991, -27.2991], - [ 0.0368, 0.2575, 0.1839, 0.1839], - [ -0.7389, -5.1723, 3.6945, 3.6945]]) - VAL_ref = np.array([-3., 4., -1., 2.]) + test1_n, A, X, 'N', sort, test1_pmax, test1_tol) + assert Xr is None + +def test_mb03rd_default(): + # regression: mb03rd was failing with no third arg (X) supplied + A = np.array([[ 6, -1, -7, -2, 2], + [-3, 4, 2, -7, 6], + [-6, -9, -3, -1, 10], + [-2, -4, 1, 5, 7], + [-7, -5, -6, 6, 7]]) + + Aschur, Tschur = schur(A) + + X = Tschur.copy() + + Ar, Xr, blsize, W = mb03rd(Aschur.shape[0], Aschur, X, 'U', 'N', pmax=1.0, tol=0.0) + + Ar2, Xr2, blsize2, W2 = mb03rd(Aschur.shape[0], Aschur) + + assert_allclose(Ar, Ar2) + assert_allclose(Xr, Tschur.dot(Xr2)) + +def test_mb03vd_mb03vy_ex(): + """Test MB03VD and MB03VY + with the example given in the MB03VD SLICOT documentation""" + + n = 4 + p = 2 + ilo = 1 + ihi = 4 + A = np.zeros((n, n, p)) + A[:, :, 0] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + A[:, :, 1] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + + H_ref = np.zeros((n, n, p)) + H_ref[:, :, 0] = [[-2.3926, 2.7042, -0.9598, -1.2335], + [ 4.1417, -1.7046, 1.3001, -1.3120], + [ 0.0000, -1.6247, -0.2534, 1.6453], + [ 0.0000, 0.0000, -0.0169, -0.4451]] + + H_ref[:, :, 1] = [[-2.5495, 2.3402, 4.7021, 0.2329], + [ 0.0000, 1.9725, -0.2483, -2.3493], + [ 0.0000, 0.0000, -0.6290, -0.5975], + [ 0.0000, 0.0000, 0.0000, -0.4426]] + + Q_ref = np.zeros((n, n, p)) + Q_ref[:, :, 0] = [[ 1.0000, 0.0000, 0.0000, 0.0000], + [ 0.0000, -0.7103, 0.5504, -0.4388], + [ 0.0000, -0.4735, -0.8349, -0.2807], + [ 0.0000, -0.5209, 0.0084, 0.8536]] + + Q_ref[:, :, 1] = [[-0.5883, 0.2947, 0.7528, -0.0145], + [-0.3922, -0.8070, 0.0009, -0.4415], + [-0.5883, 0.4292, -0.6329, -0.2630], + [-0.3922, -0.2788, -0.1809, 0.8577]] + + HQ, Tau = mb03vd(n, ilo, ihi, A) + + H = np.zeros_like(HQ) + Q = np.zeros_like(HQ) + + for k in range(p): + Q[:, :, k] = np.tril(HQ[:, :, k]) + if k == 0: + H[:, :, k] = np.triu(HQ[:n, :n, k], -1) + elif k > 0: + H[:, :, k] = np.triu(HQ[:n, :n, k]) + assert_allclose(H[:, :, k], H_ref[:, :, k], atol=1e-4) + + Qr = mb03vy(n, ilo, ihi, Q, Tau) + + for k in range(p): + assert_allclose(Qr[:, :, k], Q_ref[:, :, k], atol=1e-4) + + # Computer Error: too machine dependent to test to reference value + # SSQ_ref = 2.93760e-15 + # SSQ = 0. + # for k in range(p): + # kp1 = k+1 + # if kp1 > p-1: + # kp1 = 0 + # P = Qr[:, :, k].T.dot(A[: ,: ,k]).dot(Qr[: ,: ,kp1]) - H[: ,: ,k] + # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) + +def test_mb03wd_ex(): + """Test MB03WD with the example given in the SLICOT documentation""" + + n = 4 + p = 2 + ilo = 1 + ihi = 4 + iloz = 1 + ihiz = 4 + job = 'S' + compz = 'V' + A = np.zeros((n, n, p)) + A[:, :, 0] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + A[:, :, 1] = [[1.5, -.7, 3.5, -.7], + [1. , 0. , 2. , 3. ], + [1.5, -.7, 2.5, -.3], + [1. , 0. , 2. , 1. ]] + + W_ref = np.array([6.449861+7.817717J, + 6.449861-7.817717J, + 0.091315+0.000000J, + 0.208964+0.000000J]) + + T_ref = np.zeros((n, n, p)) + T_ref[:, :, 0] = [[ 2.2112, 4.3718, -2.3362, 0.8907], + [ -0.9179, 2.7688, -0.6570, -2.2426], + [ 0.0000, 0.0000, 0.3022, 0.1932], + [ 0.0000, 0.0000, 0.0000, -0.4571]] + + T_ref[:, :, 1] = [[ 2.9169, 3.4539, 2.2016, 1.2367], + [ 0.0000, 3.4745, 1.0209, -2.0720], + [ 0.0000, 0.0000, 0.3022, -0.1932], + [ 0.0000, 0.0000, 0.0000, -0.4571]] + + Z_ref = np.zeros((n, n, p)) + Z_ref[:, :, 0] = [[ 0.3493, 0.6751, -0.6490, 0.0327], + [ 0.7483, -0.4863, -0.1249, -0.4336], + [ 0.2939, 0.5504, 0.7148, -0.3158], + [ 0.4813, -0.0700, 0.2286, 0.8433]] + + + Z_ref[:, :, 1] = [[ 0.2372, 0.7221, 0.6490, 0.0327], + [ 0.8163, -0.3608, 0.1249, -0.4336], + [ 0.2025, 0.5902, -0.7148, -0.3158], + [ 0.4863, 0.0076, -0.2286, 0.8433]] + + HQ, Tau = mb03vd(n, ilo, ihi, A) + Q = mb03vy(n, ilo, ihi, HQ, Tau) + T, Z, W = mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, HQ, Q) + + # TODO (?) + # isolate eigenvalues with math.mb03wx + + assert_allclose(W, W_ref, atol=1e-5) + assert_allclose(T, T_ref, atol=1e-4) + assert_allclose(Z, Z_ref, atol=1e-4) + + # Computer Error: too machine dependent to test to reference value + # SSQ_ref = 7.18432D-15 + # SSQ = 0. + # for k in range(p): + # kp1 = k+1 + # if kp1 > p-1: + # kp1 = 0 + # P = Zrr[:, :, k].T.dot(A[: ,: ,k]).dot(Zrr[: ,: ,kp1]) - Hrr[: ,: ,k] + # SSQ = np.sqrt(SSQ**2 + np.linalg.norm(P,'fro')**2) + + +def test_mb05md(): + """ test_mb05md: verify Matrix exponential with slicot doc example + + data from http://slicot.org/objects/software/shared/doc/MB05MD.html + """ + A = np.array([[ 0.5, 0., 2.3, -2.6], + [ 0., 0.5, -1.4, -0.7], + [ 2.3, -1.4, 0.5, 0.0], + [-2.6, -0.7, 0.0, 0.5]]) + delta = 1.0 + Ar_ref = np.array([[ 26.8551, -3.2824, 18.7409, -19.4430], + [ -3.2824, 4.3474, -5.1848, 0.2700], + [ 18.7409, -5.1848, 15.6012, -11.7228], + [ -19.4430, 0.2700, -11.7228, 15.6012]]) + Vr_ref = np.array([[-0.7, 0.7, 0.1, -0.1], + [ 0.1, -0.1, 0.7, -0.7], + [ 0.5, 0.5, 0.5, 0.5], + [-0.5, -0.5, 0.5, 0.5]]) + Yr_ref = np.array([[ -0.0349, 0.0050, 0.0249, -0.0249], + [ 38.2187, -5.4598, 27.2991, -27.2991], + [ 0.0368, 0.2575, 0.1839, 0.1839], + [ -0.7389, -5.1723, 3.6945, 3.6945]]) + VAL_ref = np.array([-3., 4., -1., 2.]) + (Ar, Vr, Yr, VAL) = mb05md(A, delta) + + assert_allclose(Ar, Ar_ref, atol=0.0001) + + # Order of eigenvalues is not guaranteed, so we check them one by one. + for i, e in enumerate(VAL): + erow = np.ones(VAL.shape)*e + i_ref = np.isclose(erow, VAL_ref) + assert any(i_ref), f"eigenvalue {e} not expected" + # Eigenvectors can have different scaling. + vr_ref = Vr_ref[:, i_ref]*Vr[0, i]/Vr_ref[0, i_ref][0] + assert_allclose(Vr[:, (i,)], vr_ref, atol=0.0001) + + assert_allclose(np.dot(Vr, Yr), np.dot(Vr_ref, Yr_ref), atol=0.0001) + +def test_mb05md_warning(): + """Check that the correct warning is raised from docstring""" + A = np.diag([3., 3., 3., 3.]) + np.diag([1., 1., 1.], k=1) + delta = 0.1 + + with pytest.warns(SlycotResultWarning, + match="\n" + "Matrix A is defective, possibly " + "due to rounding errors.") as record: (Ar, Vr, Yr, VAL) = mb05md(A, delta) - - assert_allclose(Ar, Ar_ref, atol=0.0001) - - # Order of eigenvalues is not guaranteed, so we check them one by one. - for i, e in enumerate(VAL): - erow = np.ones(VAL.shape)*e - i_ref = np.isclose(erow, VAL_ref) - self.assertTrue(any(i_ref), - msg="eigenvalue {} not expected".format(e)) - # Eigenvectors can have different scaling. - vr_ref = Vr_ref[:, i_ref]*Vr[0, i]/Vr_ref[0, i_ref][0] - assert_allclose(Vr[:, (i,)], vr_ref, atol=0.0001) - - assert_allclose(np.dot(Vr, Yr), np.dot(Vr_ref, Yr_ref), atol=0.0001) - - # TODO: move this to pytest recwarn together with the whole class - @unittest.skipIf(sys.version < "3", "no assertWarns in old Python") - def test_mb05md_warning(self): - """Check that the correct warning is raised from docstring""" - A = np.diag([3., 3., 3., 3.]) + np.diag([1., 1., 1.], k=1) - delta = 0.1 - - with self.assertWarns(SlycotResultWarning, - msg="\n" - "Matrix A is defective, possibly " - "due to rounding errors.") as cm: - (Ar, Vr, Yr, VAL) = mb05md(A, delta) - assert cm.warning.info == 6 - - def test_mb05nd(self): - """ test_mb05nd: verify Matrix exponential and integral - data from http://slicot.org/objects/software/shared/doc/MB05ND.html - """ - A = np.array([[5.0, 4.0, 3.0, 2.0, 1.0], - [1.0, 6.0, 0.0, 4.0, 3.0], - [2.0, 0.0, 7.0, 6.0, 5.0], - [1.0, 3.0, 1.0, 8.0, 7.0], - [2.0, 5.0, 7.0, 1.0, 9.0]]) - delta = 0.1 - F_ref = np.array([[1.8391, 0.9476, 0.7920, 0.8216, 0.7811], - [0.3359, 2.2262, 0.4013, 1.0078, 1.0957], - [0.6335, 0.6776, 2.6933, 1.6155, 1.8502], - [0.4804, 1.1561, 0.9110, 2.7461, 2.0854], - [0.7105, 1.4244, 1.8835, 1.0966, 3.4134]]) - H_ref = np.array([[0.1347, 0.0352, 0.0284, 0.0272, 0.0231], - [0.0114, 0.1477, 0.0104, 0.0369, 0.0368], - [0.0218, 0.0178, 0.1624, 0.0580, 0.0619], - [0.0152, 0.0385, 0.0267, 0.1660, 0.0732], - [0.0240, 0.0503, 0.0679, 0.0317, 0.1863]]) - - (F, H) = mb05nd(A, delta) - - assert_allclose(F, F_ref, atol=0.0001) - assert_allclose(H, H_ref, atol=0.0001) + assert record[0].message.info == 6 + +def test_mb05nd(): + """ test_mb05nd: verify Matrix exponential and integral + data from http://slicot.org/objects/software/shared/doc/MB05ND.html + """ + A = np.array([[5.0, 4.0, 3.0, 2.0, 1.0], + [1.0, 6.0, 0.0, 4.0, 3.0], + [2.0, 0.0, 7.0, 6.0, 5.0], + [1.0, 3.0, 1.0, 8.0, 7.0], + [2.0, 5.0, 7.0, 1.0, 9.0]]) + delta = 0.1 + F_ref = np.array([[1.8391, 0.9476, 0.7920, 0.8216, 0.7811], + [0.3359, 2.2262, 0.4013, 1.0078, 1.0957], + [0.6335, 0.6776, 2.6933, 1.6155, 1.8502], + [0.4804, 1.1561, 0.9110, 2.7461, 2.0854], + [0.7105, 1.4244, 1.8835, 1.0966, 3.4134]]) + H_ref = np.array([[0.1347, 0.0352, 0.0284, 0.0272, 0.0231], + [0.0114, 0.1477, 0.0104, 0.0369, 0.0368], + [0.0218, 0.0178, 0.1624, 0.0580, 0.0619], + [0.0152, 0.0385, 0.0267, 0.1660, 0.0732], + [0.0240, 0.0503, 0.0679, 0.0317, 0.1863]]) + + (F, H) = mb05nd(A, delta) + + assert_allclose(F, F_ref, atol=0.0001) + assert_allclose(H, H_ref, atol=0.0001) @pytest.mark.parametrize( @@ -335,6 +328,3 @@ def test_mb05nd(self): def test_mb_docparse(fun, exception_class, erange, checkvars): assert_docstring_parse(fun.__doc__, exception_class, erange, checkvars) - -if __name__ == "__main__": - unittest.main() diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py index df5e4a02..d640b159 100644 --- a/slycot/tests/test_sg02ad.py +++ b/slycot/tests/test_sg02ad.py @@ -1,46 +1,37 @@ # # test_sg02ad.py - test suite for ricatti equation solving # RvP, 19 Jun 2017 -from __future__ import print_function -import unittest from slycot import synthesis import numpy as np from numpy.testing import assert_almost_equal - -class test_sg02ad(unittest.TestCase): - - def test_sg02ad_case1(self): - n = 3 - m = 1 - # from a discussion here: - # https://github.com/scipy/scipy/issues/2251 - A = np.array([[ 0.63399379, 0.54906824, 0.76253406], - [ 0.5404729 , 0.53745766, 0.08731853], - [ 0.27524045, 0.84922129, 0.4681622 ]]) - B = np.array([[ 0.96861695], - [ 0.05532739], - [ 0.78934047]]) - Q = np.eye(3) - E = np.eye(3) - R = np.ones((1,1), dtype=float) - S = np.array([[-2.67522766, -5.39447418, 2.19128542], - [-1.94918951, -3.15480639, 5.24379117], - [ 4.29133973, 8.10585767, -5.88895897]]) - L = np.array(np.zeros((3,1))) - rcondu, X, alphar, alphai, beta, S, T, U, iwarn = \ - synthesis.sg02ad('D', 'B', 'N', 'U', 'Z', 'N', 'S', 'R', - n, m, 1, - A, E, B, Q, R, L) - LATXB = L + A.T.dot(X).dot(B) - assert_almost_equal( - A.T.dot(X).dot(A) - - E.T.dot(X).dot(E) - - LATXB.dot(np.linalg.solve(R+B.T.dot(X).dot(B), LATXB.T)) + Q, - np.zeros((n, n))) - - -if __name__ == "__main__": - unittest.main() +def test_sg02ad_case1(): + n = 3 + m = 1 + # from a discussion here: + # https://github.com/scipy/scipy/issues/2251 + A = np.array([[ 0.63399379, 0.54906824, 0.76253406], + [ 0.5404729 , 0.53745766, 0.08731853], + [ 0.27524045, 0.84922129, 0.4681622 ]]) + B = np.array([[ 0.96861695], + [ 0.05532739], + [ 0.78934047]]) + Q = np.eye(3) + E = np.eye(3) + R = np.ones((1,1), dtype=float) + S = np.array([[-2.67522766, -5.39447418, 2.19128542], + [-1.94918951, -3.15480639, 5.24379117], + [ 4.29133973, 8.10585767, -5.88895897]]) + L = np.array(np.zeros((3,1))) + rcondu, X, alphar, alphai, beta, S, T, U, iwarn = \ + synthesis.sg02ad('D', 'B', 'N', 'U', 'Z', 'N', 'S', 'R', + n, m, 1, + A, E, B, Q, R, L) + LATXB = L + A.T.dot(X).dot(B) + assert_almost_equal( + A.T.dot(X).dot(A) - + E.T.dot(X).dot(E) - + LATXB.dot(np.linalg.solve(R+B.T.dot(X).dot(B), LATXB.T)) + Q, + np.zeros((n, n))) diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index dc0f262a..1352ebb8 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -1,9 +1,7 @@ # # test_sg03ad.py - test suite for stability margin commands # RvP, 15 Jun 2017 -from __future__ import print_function -import unittest from slycot import synthesis import numpy as np @@ -14,60 +12,55 @@ # http://www.qucosa.de/fileadmin/data/qucosa/documents/4168/data/b002.pdf -class test_sg03ad(unittest.TestCase): - - def test_sg03ad_ex1c(self): - """ Example 1 continuous case""" - n = 100 - Xref = np.ones((n, n)) - U = np.tril(Xref) - for t in range(0, 50, 10): - A = (2**(-t) - 1) * np.eye(n) + np.diag(np.arange(1., n+1.)) + U.T - E = np.eye(n) + 2**(-t) * U - Y = A.T.dot(Xref).dot(E) + E.T.dot(Xref).dot(A) - Q = np.zeros((n, n)) - Z = np.zeros((n, n)) - A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ - synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) - assert_almost_equal(X, Xref) - - def test_sg03ad_ex1d(self): - """ Example 1 discrete case""" - n = 100 - Xref = np.ones((n, n)) - U = np.tril(Xref) - for t in range(0, 50, 10): - A = 2**(-t) * np.eye(n) + np.diag(np.arange(1., n+1.)) + U.T - E = np.eye(n) + 2**(-t) * U - Y = A.T.dot(Xref).dot(A) - E.T.dot(Xref).dot(E) - Q = np.zeros((n, n)) - Z = np.zeros((n, n)) - A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ - synthesis.sg03ad('D', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) - assert_almost_equal(X, Xref) +def test_sg03ad_ex1c(): + """ Example 1 continuous case""" + n = 100 + Xref = np.ones((n, n)) + U = np.tril(Xref) + for t in range(0, 50, 10): + A = (2**(-t) - 1) * np.eye(n) + np.diag(np.arange(1., n+1.)) + U.T + E = np.eye(n) + 2**(-t) * U + Y = A.T.dot(Xref).dot(E) + E.T.dot(Xref).dot(A) + Q = np.zeros((n, n)) + Z = np.zeros((n, n)) + A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ + synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) + assert_almost_equal(X, Xref) - def test_sg03ad_b1(self): - """ SLICOT doc example / Penzl B.1 """ - n = 3 - A = np.array([[3.0, 1.0, 1.0], - [1.0, 3.0, 0.0], - [1.0, 0.0, 2.0]]) - E = np.array([[1.0, 3.0, 0.0], - [3.0, 2.0, 1.0], - [1.0, 0.0, 1.0]]) - Y = np.array([[64.0, 73.0, 28.0], - [73.0, 70.0, 25.0], - [28.0, 25.0, 18.0]]) - Xref = np.array([[-2.0000, -1.0000, 0.0000], - [-1.0000, -3.0000, -1.0000], - [0.0000, -1.0000, -3.0000]]) - Q = np.zeros((3, 3)) - Z = np.zeros((3, 3)) +def test_sg03ad_ex1d(): + """ Example 1 discrete case""" + n = 100 + Xref = np.ones((n, n)) + U = np.tril(Xref) + for t in range(0, 50, 10): + A = 2**(-t) * np.eye(n) + np.diag(np.arange(1., n+1.)) + U.T + E = np.eye(n) + 2**(-t) * U + Y = A.T.dot(Xref).dot(A) - E.T.dot(Xref).dot(E) + Q = np.zeros((n, n)) + Z = np.zeros((n, n)) A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ - synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, -Y) - # print(A, E, Q, Z, X, scale, sep) + synthesis.sg03ad('D', 'B', 'N', 'N', 'L', n, A, E, Q, Z, Y) assert_almost_equal(X, Xref) +def test_sg03ad_b1(): + """ SLICOT doc example / Penzl B.1 """ + n = 3 + A = np.array([[3.0, 1.0, 1.0], + [1.0, 3.0, 0.0], + [1.0, 0.0, 2.0]]) + E = np.array([[1.0, 3.0, 0.0], + [3.0, 2.0, 1.0], + [1.0, 0.0, 1.0]]) + Y = np.array([[64.0, 73.0, 28.0], + [73.0, 70.0, 25.0], + [28.0, 25.0, 18.0]]) + Xref = np.array([[-2.0000, -1.0000, 0.0000], + [-1.0000, -3.0000, -1.0000], + [0.0000, -1.0000, -3.0000]]) + Q = np.zeros((3, 3)) + Z = np.zeros((3, 3)) + A, E, Q, Z, X, scale, sep, ferr, alphar, alphai, beta = \ + synthesis.sg03ad('C', 'B', 'N', 'N', 'L', n, A, E, Q, Z, -Y) + # print(A, E, Q, Z, X, scale, sep) + assert_almost_equal(X, Xref) -if __name__ == "__main__": - unittest.main() diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index 5732a660..b5a1d3e3 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -1,14 +1,16 @@ # =================================================== # tb05ad tests -from slycot import transform -from slycot.exceptions import SlycotArithmeticError, SlycotParameterError import sys + +import pytest import numpy as np from scipy.linalg import matrix_balance, eig -import unittest from numpy.testing import assert_almost_equal +from slycot import transform +from slycot.exceptions import SlycotArithmeticError, SlycotParameterError + # set the random seed so we can get consistent results. np.random.seed(40) CASES = {} @@ -35,213 +37,215 @@ 'C': np.random.randn(p, n)} -class test_tb05ad(unittest.TestCase): - - def test_tb05ad_ng(self): - """ - Test that tb05ad with job 'NG' computes the correct - frequency response. - """ - for key in CASES: - sys = CASES[key] - self.check_tb05ad_AG_NG(sys, 10*1j, 'NG') - - def test_tb05ad_ag(self): - """ - Test that tb05ad with job 'AG' computes the correct - frequency response. - """ - for key in CASES: - sys = CASES[key] - self.check_tb05ad_AG_NG(sys, 10*1j, 'AG') - - def test_tb05ad_nh(self): - """Test that tb05ad with job = 'NH' computes the correct - frequency response after conversion to Hessenberg form. - - First call tb05ad with job='NH' to transform to upper Hessenberg - form which outputs the transformed system. - Subsequently, call tb05ad with job='NH' using this transformed system. - """ - jomega = 10*1j - for key in CASES: - sys = CASES[key] - sys_transformed = self.check_tb05ad_AG_NG(sys, jomega, 'NG') - self.check_tb05ad_NH(sys_transformed, sys, jomega) - - def test_tb05ad_errors(self): - """ - Test tb05ad error handling. We give wrong inputs and - and check that this raises an error. - """ - self.check_tb05ad_errors(CASES['pass1']) - - def check_tb05ad_AG_NG(self, sys, jomega, job): - """ - Check that tb05ad computes the correct frequency response when - running jobs 'AG' and/or 'NG'. - - Inputs - ------ - - sys: A a dict of system matrices with keys 'A', 'B', and 'C'. - jomega: A complex scalar, which is the frequency we are - evaluating the system at. - job: A string, either 'AG' or 'NH' - - Returns - ------- - sys_transformed: A dict of the system matrices which have been - transformed according the job. - """ - n, m = sys['B'].shape - p = sys['C'].shape[0] - result = transform.tb05ad(n, m, p, jomega, - sys['A'], sys['B'], sys['C'], job=job) - g_i = result[3] - hinvb = np.linalg.solve(np.eye(n) * jomega - sys['A'], sys['B']) - g_i_solve = sys['C'].dot(hinvb) - assert_almost_equal(g_i_solve, g_i) - sys_transformed = {'A': result[0], 'B': result[1], 'C': result[2]} - return sys_transformed - - def check_tb05ad_NH(self, sys_transformed, sys, jomega): - """ - Check tb05ad, computes the correct frequency response when - job='NH' and we supply system matrices 'A', 'B', and 'C' - which have been transformed by a previous call to tb05ad. - We check we get the same result as computing C(sI - A)^-1B - with the original system. - - Inputs - ------ - - sys_transformed: A a dict of the transformed (A in upper - hessenberg form) system matrices with keys - 'A', 'B', and 'C'. - - sys: A dict of the original un-transformed system matrices. - - jomega: A complex scalar, which is the frequency to evaluate at. - - """ - - n, m = sys_transformed['B'].shape - p = sys_transformed['C'].shape[0] - result = transform.tb05ad(n, m, p, jomega, sys_transformed['A'], - sys_transformed['B'], sys_transformed['C'], - job='NH') - g_i = result[0] - hinvb = np.linalg.solve(np.eye(n) * jomega - sys['A'], sys['B']) - g_i_solve = sys['C'].dot(hinvb) - assert_almost_equal(g_i_solve, g_i) - - def check_tb05ad_errors(self, sys): - """ - Check the error handling of tb05ad. We give wrong inputs and - and check that this raises an error. - """ - n, m = sys['B'].shape - p = sys['C'].shape[0] - jomega = 10*1j - # test error handling - # wrong size A - with self.assertRaises(SlycotParameterError) as cm: - transform.tb05ad( - n+1, m, p, jomega, sys['A'], sys['B'], sys['C'], job='NH') - assert cm.exception.info == -7 - # wrong size B - with self.assertRaises(SlycotParameterError) as cm: - transform.tb05ad( - n, m+1, p, jomega, sys['A'], sys['B'], sys['C'], job='NH') - assert cm.exception.info == -9 - # wrong size C - with self.assertRaises(SlycotParameterError) as cm: - transform.tb05ad( - n, m, p+1, jomega, sys['A'], sys['B'], sys['C'], job='NH') - assert cm.exception.info == -11 - # unrecognized job - with self.assertRaises(SlycotParameterError) as cm: - transform.tb05ad( - n, m, p, jomega, sys['A'], sys['B'], sys['C'], job='a') - assert cm.exception.info == -1 - - @unittest.skipIf(sys.version < "3", "no assertRaisesRegex in old Python") - def test_tb05ad_resonance(self): - """ Test tb05ad resonance failure. - - Actually test one of the exception messages. These - are parsed from the docstring, tests both the info index and the - message - """ - A = np.array([[0, -1], - [1, 0]]) - B = np.array([[1], - [0]]) - C = np.array([[0, 1]]) - jomega = 1j - with self.assertRaisesRegex( - SlycotArithmeticError, - r"Either `freq`.* is too near to an eigenvalue of A,\n" - r"or `rcond` is less than the machine precision EPS.") as cm: - transform.tb05ad(2, 1, 1, jomega, A, B, C, job='NH') - assert cm.exception.info == 2 - - def test_tb05ad_balance(self): - """Test balancing in tb05ad. - - Tests for the cause of the problem reported in issue #11 - balancing permutations were not correctly applied to the - C and D matrix. - """ - - # find a good test case. Some sparsity, - # some zero eigenvalues, some non-zero eigenvalues, - # and proof that the 1st step, with dgebal, does some - # permutation and some scaling - crit = False - n = 8 - while not crit: - A = np.random.randn(n, n) - A[np.random.uniform(size=(n, n)) > 0.35] = 0.0 - - Aeig = eig(A)[0] - neig0 = np.sum(np.abs(Aeig) == 0) - As, T = matrix_balance(A) - nperm = np.sum(np.diag(T == 0)) - nscale = n - np.sum(T == 1.0) - crit = nperm < n and nperm >= n//2 and \ - neig0 > 1 and neig0 <= 3 and nscale > 0 - - # print("number of permutations", nperm, "eigenvalues=0", neig0) - B = np.random.randn(8, 4) - C = np.random.randn(3, 8) - - # do a run - jomega = 1.0 - At, Bt, Ct, rcond, g_jw, ev, hinvb, info = transform.tb05ad( - 8, 4, 3, jomega, A, B, C, job='AG') - - # remove information on Q, in lower sub-triangle part of A - At = np.triu(At, k=-1) - - # now after the balancing in DGEBAL, and conversion to - # upper Hessenberg form: - # At = Q^T * (P^-1 * A * P ) * Q - # with Q orthogonal - # Ct = C * P * Q - # Bt = Q^T * P^-1 * B - # so test with Ct * At * Bt == C * A * B - # and verify that eigenvalues of both A matrices are close - assert_almost_equal(np.dot(np.dot(Ct, At), Bt), - np.dot(np.dot(C, A), B)) - # uses a sort, there is no guarantee on the order of eigenvalues - eigAt = eig(At)[0] - idxAt = np.argsort(eigAt) - eigA = eig(A)[0] - idxA = np.argsort(eigA) - assert_almost_equal(eigA[idxA], eigAt[idxAt]) - - -if __name__ == "__main__": - unittest.main() +def test_tb05ad_ng(): + """ + Test that tb05ad with job 'NG' computes the correct + frequency response. + """ + for key in CASES: + sys = CASES[key] + check_tb05ad_AG_NG(sys, 10*1j, 'NG') + + +def test_tb05ad_ag(): + """ + Test that tb05ad with job 'AG' computes the correct + frequency response. + """ + for key in CASES: + sys = CASES[key] + check_tb05ad_AG_NG(sys, 10*1j, 'AG') + + +def test_tb05ad_nh(): + """Test that tb05ad with job = 'NH' computes the correct + frequency response after conversion to Hessenberg form. + + First call tb05ad with job='NH' to transform to upper Hessenberg + form which outputs the transformed system. + Subsequently, call tb05ad with job='NH' using this transformed system. + """ + jomega = 10*1j + for key in CASES: + sys = CASES[key] + sys_transformed = check_tb05ad_AG_NG(sys, jomega, 'NG') + check_tb05ad_NH(sys_transformed, sys, jomega) + + +def test_tb05ad_errors(): + """ + Test tb05ad error handling. We give wrong inputs and + and check that this raises an error. + """ + check_tb05ad_errors(CASES['pass1']) + + +def check_tb05ad_AG_NG(sys, jomega, job): + """ + Check that tb05ad computes the correct frequency response when + running jobs 'AG' and/or 'NG'. + + Inputs + ------ + + sys: A a dict of system matrices with keys 'A', 'B', and 'C'. + jomega: A complex scalar, which is the frequency we are + evaluating the system at. + job: A string, either 'AG' or 'NH' + + Returns + ------- + sys_transformed: A dict of the system matrices which have been + transformed according the job. + """ + n, m = sys['B'].shape + p = sys['C'].shape[0] + result = transform.tb05ad(n, m, p, jomega, + sys['A'], sys['B'], sys['C'], job=job) + g_i = result[3] + hinvb = np.linalg.solve(np.eye(n) * jomega - sys['A'], sys['B']) + g_i_solve = sys['C'].dot(hinvb) + assert_almost_equal(g_i_solve, g_i) + sys_transformed = {'A': result[0], 'B': result[1], 'C': result[2]} + return sys_transformed + + +def check_tb05ad_NH(sys_transformed, sys, jomega): + """ + Check tb05ad, computes the correct frequency response when + job='NH' and we supply system matrices 'A', 'B', and 'C' + which have been transformed by a previous call to tb05ad. + We check we get the same result as computing C(sI - A)^-1B + with the original system. + + Inputs + ------ + + sys_transformed: A a dict of the transformed (A in upper + hessenberg form) system matrices with keys + 'A', 'B', and 'C'. + + sys: A dict of the original un-transformed system matrices. + + jomega: A complex scalar, which is the frequency to evaluate at. + + """ + + n, m = sys_transformed['B'].shape + p = sys_transformed['C'].shape[0] + result = transform.tb05ad(n, m, p, jomega, sys_transformed['A'], + sys_transformed['B'], sys_transformed['C'], + job='NH') + g_i = result[0] + hinvb = np.linalg.solve(np.eye(n) * jomega - sys['A'], sys['B']) + g_i_solve = sys['C'].dot(hinvb) + assert_almost_equal(g_i_solve, g_i) + + +def check_tb05ad_errors(sys): + """ + Check the error handling of tb05ad. We give wrong inputs and + and check that this raises an error. + """ + n, m = sys['B'].shape + p = sys['C'].shape[0] + jomega = 10*1j + # test error handling + # wrong size A + with pytest.raises(SlycotParameterError) as cm: + transform.tb05ad( + n+1, m, p, jomega, sys['A'], sys['B'], sys['C'], job='NH') + assert cm.value.info == -7 + # wrong size B + with pytest.raises(SlycotParameterError) as cm: + transform.tb05ad( + n, m+1, p, jomega, sys['A'], sys['B'], sys['C'], job='NH') + assert cm.value.info == -9 + # wrong size C + with pytest.raises(SlycotParameterError) as cm: + transform.tb05ad( + n, m, p+1, jomega, sys['A'], sys['B'], sys['C'], job='NH') + assert cm.value.info == -11 + # unrecognized job + with pytest.raises(SlycotParameterError) as cm: + transform.tb05ad( + n, m, p, jomega, sys['A'], sys['B'], sys['C'], job='a') + assert cm.value.info == -1 + + +def test_tb05ad_resonance(): + """ Test tb05ad resonance failure. + + Actually test one of the exception messages. These + are parsed from the docstring, tests both the info index and the + message + """ + A = np.array([[0, -1], + [1, 0]]) + B = np.array([[1], + [0]]) + C = np.array([[0, 1]]) + jomega = 1j + with pytest.raises( + SlycotArithmeticError, + match=r"Either `freq`.* is too near to an eigenvalue of A,\n" + r"or `rcond` is less than the machine precision EPS.") as cm: + transform.tb05ad(2, 1, 1, jomega, A, B, C, job='NH') + assert cm.value.info == 2 + + +def test_tb05ad_balance(): + """Test balancing in tb05ad. + + Tests for the cause of the problem reported in issue #11 + balancing permutations were not correctly applied to the + C and D matrix. + """ + + # find a good test case. Some sparsity, + # some zero eigenvalues, some non-zero eigenvalues, + # and proof that the 1st step, with dgebal, does some + # permutation and some scaling + crit = False + n = 8 + while not crit: + A = np.random.randn(n, n) + A[np.random.uniform(size=(n, n)) > 0.35] = 0.0 + + Aeig = eig(A)[0] + neig0 = np.sum(np.abs(Aeig) == 0) + As, T = matrix_balance(A) + nperm = np.sum(np.diag(T == 0)) + nscale = n - np.sum(T == 1.0) + crit = nperm < n and nperm >= n//2 and \ + neig0 > 1 and neig0 <= 3 and nscale > 0 + + # print("number of permutations", nperm, "eigenvalues=0", neig0) + B = np.random.randn(8, 4) + C = np.random.randn(3, 8) + + # do a run + jomega = 1.0 + At, Bt, Ct, rcond, g_jw, ev, hinvb, info = transform.tb05ad( + 8, 4, 3, jomega, A, B, C, job='AG') + + # remove information on Q, in lower sub-triangle part of A + At = np.triu(At, k=-1) + + # now after the balancing in DGEBAL, and conversion to + # upper Hessenberg form: + # At = Q^T * (P^-1 * A * P ) * Q + # with Q orthogonal + # Ct = C * P * Q + # Bt = Q^T * P^-1 * B + # so test with Ct * At * Bt == C * A * B + # and verify that eigenvalues of both A matrices are close + assert_almost_equal(np.dot(np.dot(Ct, At), Bt), + np.dot(np.dot(C, A), B)) + # uses a sort, there is no guarantee on the order of eigenvalues + eigAt = eig(At)[0] + idxAt = np.argsort(eigAt) + eigA = eig(A)[0] + idxA = np.argsort(eigA) + assert_almost_equal(eigA[idxA], eigAt[idxAt]) + diff --git a/slycot/tests/test_td04ad.py b/slycot/tests/test_td04ad.py index 50206360..57c557d0 100644 --- a/slycot/tests/test_td04ad.py +++ b/slycot/tests/test_td04ad.py @@ -2,226 +2,219 @@ # test_td04ad.py - test suite for tf -> ss conversion # RvP, 04 Jun 2018 -from __future__ import print_function, division +import numpy as np -import unittest from slycot import transform -import numpy as np -class TestTf2SS(unittest.TestCase): - - def test_td04ad_c(self): - """td04ad: Convert with 'C' option""" - - # for octave: - """ - num = { [0.0, 0.0, 1.0 ], [ 1.0, 0.0 ]; - [3.0, -1.0, 1.0 ], [ 0.0, 1.0 ]; - [0.0, 0.0, 1.0], [ 0.0, 2.0 ] }; - den = { [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; - [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; - [1.0, 0.4, 3.0], [ 1.0, 1.0 ]}; - """ - - m = 2 - p = 3 - d = 3 - num = np.array([ - [ [0.0, 0.0, 1.0], [1.0, 0.0, 0.0] ], - [ [3.0, -1.0, 1.0], [0.0, 1.0, 0.0] ], - [ [0.0, 0.0, 1.0], [0.0, 2.0, 0.0] ] ]) - - numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) - numc[:p,:m,:] = num - denc = np.array( - [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ] ]) - indc = np.array( - [ 2, 1 ], dtype=int) - - nref = 3 - Aref = np.array([ [-1, 0, 0], - [ 0, -0.4, -0.3], - [ 0, 10, 0] ]) - Bref = np.array([ [0, -1], - [1, 0], - [0, 0] ]) - Cref = np.array([ [1, 0, 0.1], - [-1, -2.2, -0.8], - [-2, 0, 0.1] ]) - Dref = np.array([ [0, 1], - [3, 0], - [0, 0] ]) - - nr, A, B, C, D = transform.td04ad('C', m, p, indc, denc, numc) - #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) - np.testing.assert_equal(nref, nr) - # the returned state space representation is not guaranteed to - # be of one form for all architectures, so we transform back - # to tf and check for equality then - _, _, _, _, _, dcoeff, ucoeff = transform.tb04ad( - nr, m, p, A, B, C, D) - _, _, _, _, _, dcoeffref, ucoeffref = transform.tb04ad( - nref, m, p, Aref, Bref, Cref, Dref) - np.testing.assert_array_almost_equal(dcoeff,dcoeffref) - np.testing.assert_array_almost_equal(ucoeff,ucoeffref) - - def test_td04ad_r(self): - """td04ad: Convert with 'R' option - - example program from - http://slicot.org/objects/software/shared/doc/TD04AD.html - """ - - m = 2 - p = 2 - rowcol = 'R' - index = [3, 3] - dcoeff = np.array([ [1.0, 6.0, 11.0, 6.0], [1.0, 6.0, 11.0, 6.0] ]) - - ucoeff = np.array([ [[1.0, 6.0, 12.0, 7.0], [0.0, 1.0, 4.0, 3.0]], - [[0.0, 0.0, 1.0, 1.0], [1.0, 8.0, 20.0, 15.0]] ]) - - nref = 3 - - Aref = np.array([ [ 0.5000, -0.8028, 0.9387], - [ 4.4047, -2.3380, 2.5076], - [-5.5541, 1.6872, -4.1620] ]) - Bref = np.array([ [-0.2000, -1.2500], - [ 0.0000, -0.6097], - [ 0.0000, 2.2217] ]) - Cref = np.array([ [0.0000, -0.8679, 0.2119], - [0.0000, 0.0000, 0.9002] ]) - Dref = np.array([ [1.0000, 0.0000], - [0.0000, 1.0000] ]) - - nr, A, B, C, D = transform.td04ad(rowcol, m, p, index, dcoeff, ucoeff) - #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) - np.testing.assert_equal(nref, nr) - # order of states is not guaranteed, so we reorder the reference - rindex = np.flip(np.argsort(np.diag(A))) - Arref = Aref[rindex, :][:, rindex] - Brref = Bref[rindex, :] - Crref = Cref[:, rindex] - Drref = Dref - np.testing.assert_array_almost_equal(A, Arref,decimal=4) - np.testing.assert_array_almost_equal(B, Brref,decimal=4) - np.testing.assert_array_almost_equal(C, Crref,decimal=4) - np.testing.assert_array_almost_equal(D, Drref,decimal=4) - - - def test_staticgain(self): - """td04ad: Convert a transferfunction to SS with only static gain""" - - # 2 inputs, 3 outputs? columns share a denominator - num = np.array([ [ [1.0], [2.0] ], - [ [0.2], [4.3] ], - [ [1.2], [3.2] ] ]) - p, m, d = num.shape - numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) - numc[:p,:m,:] = num - - # denc, columns share a common denominator - denc = np.array([ [ 1.0], [0.5] ]) - Dc = (num / denc).reshape((3,2)) - idxc = np.zeros((2,), dtype=int) - - # denr, rows share a common denominator - denr = np.array([ [1.0], [0.5], [3.0] ]) - idxr = np.zeros((3,), dtype=int) - Dr = (num / denr[:, np.newaxis]).reshape((3,2)) - - # fails with: - # On entry to TB01XD parameter number 5 had an illegal value - - n, A, B, C, D = transform.td04ad('C', 2, 3, idxc, denc, numc) - #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) - self.assertEqual(A.shape, (0,0)) - self.assertEqual(B.shape, (0,2)) - self.assertEqual(C.shape, (3,0)) - np.testing.assert_array_almost_equal(D, Dc) - - n, A, B, C, D = transform.td04ad('R', 2, 3, idxr, denr, num) - #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) - self.assertEqual(A.shape, (0,0)) - self.assertEqual(B.shape, (0,2)) - self.assertEqual(C.shape, (3,0)) - np.testing.assert_array_almost_equal(D, Dr) - - def test_td04ad_static(self): - """Regression: td04ad (TFM -> SS transformation) for static TFM""" - from itertools import product - for nout, nin, rc in product(range(1, 6), range(1, 6), ['R', 'C']): - Dref = np.zeros((nout, nin)) - if rc == 'R': - num = np.reshape(np.arange(nout * nin), (nout, nin, 1)) - den = np.reshape(np.arange(1, 1 + nout), (nout, 1)) - index = np.repeat(0, nout) - Dref = num[:nout, :nin, 0] / np.broadcast_to(den, (nout, nin)) - else: - maxn = max(nout, nin) - num = np.zeros((maxn, maxn, 1)) - num[:nout, :nin, 0] = np.reshape( - np.arange(nout * nin), (nout, nin)) - den = np.reshape(np.arange(1, 1 + nin), (nin, 1)) - index = np.repeat(0, nin) - Dref = num[:nout, :nin, 0] / np.broadcast_to(den.T, (nout, nin)) - nr, A, B, C, D = transform.td04ad(rc, nin, nout, index, den, num) - np.testing.assert_equal(nr, 0) - for M in [A, B, C]: - np.testing.assert_equal(M, np.zeros_like(M)) - np.testing.assert_almost_equal(D, Dref) - - def test_mixfeedthrough(self): - """Test case popping up from control testing - - a mix of feedthrough and dynamics. The problem from the control - package was somewhere else - """ - num = np.array([ [ [ 0.0, 0.0 ], [ 0.0, -0.2 ] ], - [ [ -0.1, 0.0 ], [ 0.0, 0.0 ] ] ]) - p, m, d = num.shape - numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) - numc[:p,:m,:] = num - denc = np.array([[1.0, 1.1], - [1.0, 0.0]]) - idxc = np.array([1, 0]) - n, A, B, C, D = transform.td04ad('C', 2, 2, idxc, denc, numc) - np.testing.assert_array_almost_equal(D, np.array([[0, 0],[-0.1, 0]])) - - def test_toandfrom(self): - A = np.array([[-3.0]]) - B = np.array([[0.1, 0.0]]) - C = np.array([[1.0], - [0.0]]) - D = np.array([[0.0, 0.0], - [0.0, 1.0]]) - - tfout = transform.tb04ad(1, 2, 2, A, B, C, D) - - num = tfout[6] - den = tfout[5] - idxc = np.array([1, 0]) - n, At, Bt, Ct, Dt = transform.td04ad('R', 2, 2, idxc, den, num) - np.testing.assert_array_almost_equal(D, Dt) - np.testing.assert_array_almost_equal(A, At) - - def test_tfm2ss_6(self): - """Python version of Fortran test program from - -- Bug in TD04AD when ROWCOL='C' #6 - This bug was fixed in PR #27""" - m = 1 - p = 1 - index = np.array([0]) - dcoeff = np.array([[0.5]]) - ucoeff = np.array([[[32]]]) - n, A, B, C, D = transform.td04ad('R', m, p, index, dcoeff, ucoeff) - self.assertEqual(n, 0) - np.testing.assert_array_almost_equal(D, np.array([[64]])) - n, A, B, C, D = transform.td04ad('C', m, p, index, dcoeff, ucoeff) - self.assertEqual(n, 0) - np.testing.assert_array_almost_equal(D, np.array([[64]])) - - -if __name__ == "__main__": - unittest.main() +def test_td04ad_c(): + """td04ad: Convert with 'C' option""" + + # for octave: + """ + num = { [0.0, 0.0, 1.0 ], [ 1.0, 0.0 ]; + [3.0, -1.0, 1.0 ], [ 0.0, 1.0 ]; + [0.0, 0.0, 1.0], [ 0.0, 2.0 ] }; + den = { [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; + [1.0, 0.4, 3.0], [ 1.0, 1.0 ]; + [1.0, 0.4, 3.0], [ 1.0, 1.0 ]}; + """ + + m = 2 + p = 3 + d = 3 + num = np.array([ + [ [0.0, 0.0, 1.0], [1.0, 0.0, 0.0] ], + [ [3.0, -1.0, 1.0], [0.0, 1.0, 0.0] ], + [ [0.0, 0.0, 1.0], [0.0, 2.0, 0.0] ] ]) + + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) + numc[:p,:m,:] = num + denc = np.array( + [ [1.0, 0.4, 3.0], [ 1.0, 1.0, 0.0 ] ]) + indc = np.array( + [ 2, 1 ], dtype=int) + + nref = 3 + Aref = np.array([ [-1, 0, 0], + [ 0, -0.4, -0.3], + [ 0, 10, 0] ]) + Bref = np.array([ [0, -1], + [1, 0], + [0, 0] ]) + Cref = np.array([ [1, 0, 0.1], + [-1, -2.2, -0.8], + [-2, 0, 0.1] ]) + Dref = np.array([ [0, 1], + [3, 0], + [0, 0] ]) + + nr, A, B, C, D = transform.td04ad('C', m, p, indc, denc, numc) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + np.testing.assert_equal(nref, nr) + # the returned state space representation is not guaranteed to + # be of one form for all architectures, so we transform back + # to tf and check for equality then + _, _, _, _, _, dcoeff, ucoeff = transform.tb04ad( + nr, m, p, A, B, C, D) + _, _, _, _, _, dcoeffref, ucoeffref = transform.tb04ad( + nref, m, p, Aref, Bref, Cref, Dref) + np.testing.assert_array_almost_equal(dcoeff,dcoeffref) + np.testing.assert_array_almost_equal(ucoeff,ucoeffref) + +def test_td04ad_r(): + """td04ad: Convert with 'R' option + + example program from + http://slicot.org/objects/software/shared/doc/TD04AD.html + """ + + m = 2 + p = 2 + rowcol = 'R' + index = [3, 3] + dcoeff = np.array([ [1.0, 6.0, 11.0, 6.0], [1.0, 6.0, 11.0, 6.0] ]) + + ucoeff = np.array([ [[1.0, 6.0, 12.0, 7.0], [0.0, 1.0, 4.0, 3.0]], + [[0.0, 0.0, 1.0, 1.0], [1.0, 8.0, 20.0, 15.0]] ]) + + nref = 3 + + Aref = np.array([ [ 0.5000, -0.8028, 0.9387], + [ 4.4047, -2.3380, 2.5076], + [-5.5541, 1.6872, -4.1620] ]) + Bref = np.array([ [-0.2000, -1.2500], + [ 0.0000, -0.6097], + [ 0.0000, 2.2217] ]) + Cref = np.array([ [0.0000, -0.8679, 0.2119], + [0.0000, 0.0000, 0.9002] ]) + Dref = np.array([ [1.0000, 0.0000], + [0.0000, 1.0000] ]) + + nr, A, B, C, D = transform.td04ad(rowcol, m, p, index, dcoeff, ucoeff) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + np.testing.assert_equal(nref, nr) + # order of states is not guaranteed, so we reorder the reference + rindex = np.flip(np.argsort(np.diag(A))) + Arref = Aref[rindex, :][:, rindex] + Brref = Bref[rindex, :] + Crref = Cref[:, rindex] + Drref = Dref + np.testing.assert_array_almost_equal(A, Arref,decimal=4) + np.testing.assert_array_almost_equal(B, Brref,decimal=4) + np.testing.assert_array_almost_equal(C, Crref,decimal=4) + np.testing.assert_array_almost_equal(D, Drref,decimal=4) + + +def test_staticgain(): + """td04ad: Convert a transferfunction to SS with only static gain""" + + # 2 inputs, 3 outputs? columns share a denominator + num = np.array([ [ [1.0], [2.0] ], + [ [0.2], [4.3] ], + [ [1.2], [3.2] ] ]) + p, m, d = num.shape + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) + numc[:p,:m,:] = num + + # denc, columns share a common denominator + denc = np.array([ [ 1.0], [0.5] ]) + Dc = (num / denc).reshape((3,2)) + idxc = np.zeros((2,), dtype=int) + + # denr, rows share a common denominator + denr = np.array([ [1.0], [0.5], [3.0] ]) + idxr = np.zeros((3,), dtype=int) + Dr = (num / denr[:, np.newaxis]).reshape((3,2)) + + # fails with: + # On entry to TB01XD parameter number 5 had an illegal value + + n, A, B, C, D = transform.td04ad('C', 2, 3, idxc, denc, numc) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + assert A.shape == (0,0) + assert B.shape == (0,2) + assert C.shape == (3,0) + np.testing.assert_array_almost_equal(D, Dc) + + n, A, B, C, D = transform.td04ad('R', 2, 3, idxr, denr, num) + #print('A=\n', A, '\nB=\n', B, '\nC=\n', C, '\nD=\n', D) + assert A.shape == (0,0) + assert B.shape == (0,2) + assert C.shape == (3,0) + np.testing.assert_array_almost_equal(D, Dr) + +def test_td04ad_static(): + """Regression: td04ad (TFM -> SS transformation) for static TFM""" + from itertools import product + for nout, nin, rc in product(range(1, 6), range(1, 6), ['R', 'C']): + Dref = np.zeros((nout, nin)) + if rc == 'R': + num = np.reshape(np.arange(nout * nin), (nout, nin, 1)) + den = np.reshape(np.arange(1, 1 + nout), (nout, 1)) + index = np.repeat(0, nout) + Dref = num[:nout, :nin, 0] / np.broadcast_to(den, (nout, nin)) + else: + maxn = max(nout, nin) + num = np.zeros((maxn, maxn, 1)) + num[:nout, :nin, 0] = np.reshape( + np.arange(nout * nin), (nout, nin)) + den = np.reshape(np.arange(1, 1 + nin), (nin, 1)) + index = np.repeat(0, nin) + Dref = num[:nout, :nin, 0] / np.broadcast_to(den.T, (nout, nin)) + nr, A, B, C, D = transform.td04ad(rc, nin, nout, index, den, num) + np.testing.assert_equal(nr, 0) + for M in [A, B, C]: + np.testing.assert_equal(M, np.zeros_like(M)) + np.testing.assert_almost_equal(D, Dref) + +def test_mixfeedthrough(): + """Test case popping up from control testing + + a mix of feedthrough and dynamics. The problem from the control + package was somewhere else + """ + num = np.array([ [ [ 0.0, 0.0 ], [ 0.0, -0.2 ] ], + [ [ -0.1, 0.0 ], [ 0.0, 0.0 ] ] ]) + p, m, d = num.shape + numc = np.zeros((max(1, m, p), max(1, m, p), d), dtype=float) + numc[:p,:m,:] = num + denc = np.array([[1.0, 1.1], + [1.0, 0.0]]) + idxc = np.array([1, 0]) + n, A, B, C, D = transform.td04ad('C', 2, 2, idxc, denc, numc) + np.testing.assert_array_almost_equal(D, np.array([[0, 0],[-0.1, 0]])) + +def test_toandfrom(): + A = np.array([[-3.0]]) + B = np.array([[0.1, 0.0]]) + C = np.array([[1.0], + [0.0]]) + D = np.array([[0.0, 0.0], + [0.0, 1.0]]) + + tfout = transform.tb04ad(1, 2, 2, A, B, C, D) + + num = tfout[6] + den = tfout[5] + idxc = np.array([1, 0]) + n, At, Bt, Ct, Dt = transform.td04ad('R', 2, 2, idxc, den, num) + np.testing.assert_array_almost_equal(D, Dt) + np.testing.assert_array_almost_equal(A, At) + +def test_tfm2ss_6(): + """Python version of Fortran test program from + -- Bug in TD04AD when ROWCOL='C' #6 + This bug was fixed in PR #27""" + m = 1 + p = 1 + index = np.array([0]) + dcoeff = np.array([[0.5]]) + ucoeff = np.array([[[32]]]) + n, A, B, C, D = transform.td04ad('R', m, p, index, dcoeff, ucoeff) + assert n == 0 + np.testing.assert_array_almost_equal(D, np.array([[64]])) + n, A, B, C, D = transform.td04ad('C', m, p, index, dcoeff, ucoeff) + assert n == 0 + np.testing.assert_array_almost_equal(D, np.array([[64]])) + diff --git a/slycot/tests/test_tg01ad.py b/slycot/tests/test_tg01ad.py index 3b509204..db9479aa 100644 --- a/slycot/tests/test_tg01ad.py +++ b/slycot/tests/test_tg01ad.py @@ -1,7 +1,6 @@ # =================================================== # tg01ad tests -import unittest from slycot import transform import numpy as np @@ -66,20 +65,15 @@ test1_rscale_desired = \ np.array([ 0.1, 0.1, 1.0, 10.0 ]) -class test_tg01ad(unittest.TestCase): - """ test1: Verify tg01ad with input parameters according to example in documentation """ - def test1_tg01ad(self): +def test1_tg01ad(): + """Verify tg01ad with input parameters according to example in documentation.""" - A,E,B,C,lscale,rscale = transform.tg01ad(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,job=test1_job, thresh=test1_thresh) + A,E,B,C,lscale,rscale = transform.tg01ad(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,job=test1_job, thresh=test1_thresh) - assert_almost_equal(A, test1_A_desired) - assert_almost_equal(E, test1_E_desired) - assert_almost_equal(B, test1_B_desired) - assert_almost_equal(C, test1_C_desired) - assert_almost_equal(lscale, test1_lscale_desired) - assert_almost_equal(rscale, test1_rscale_desired) - - -if __name__ == "__main__": - unittest.main() + assert_almost_equal(A, test1_A_desired) + assert_almost_equal(E, test1_E_desired) + assert_almost_equal(B, test1_B_desired) + assert_almost_equal(C, test1_C_desired) + assert_almost_equal(lscale, test1_lscale_desired) + assert_almost_equal(rscale, test1_rscale_desired) diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py index e80ff6e3..70ebef19 100644 --- a/slycot/tests/test_tg01fd.py +++ b/slycot/tests/test_tg01fd.py @@ -1,7 +1,6 @@ # =================================================== # tg01fd tests -import unittest from slycot import transform import numpy as np @@ -62,51 +61,45 @@ test1_ranke_exp = 3 test1_rnka22_exp = 1 -class test_tg01fd(unittest.TestCase): - - def test1_tg01fd(self): - """ test1: Verify from tg01fd with input parameters according to test in documentation """ - A,E,B,C,ranke,rnka22,Q,Z = transform.tg01fd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,compq='I',compz='I',joba='T',tol=test1_tol) - assert_almost_equal(A, test1_Aexp) - assert_almost_equal(E, test1_Eexp) - assert_almost_equal(B, test1_Bexp) - assert_almost_equal(C, test1_Cexp) - assert_almost_equal(Q, test1_Qexp) - assert_almost_equal(Z, test1_Zexp) - assert_equal(test1_ranke_exp, ranke) - assert_equal(test1_rnka22_exp, rnka22) - - def test2_tg01fd(self): - """ verify that Q and Z output with compq and compz set to 'U' equals the dot product of Q and Z input and Q and Z output with compq and compz set to 'I' """ - - l = 30 - n = 30 - m = 70 - p = 44 - - np.random.seed(0) - - Ain = np.random.rand(l, n) - Ein = np.random.rand(l, n) - Bin = np.random.rand(n, m) - Cin = np.random.rand(p, n) - Qin = np.random.randn(l,l) - Zin = np.random.randn(n,n) - - A_1,E_1,B_1,C_1,ranke_1,rnka22_1,Q_1,Z_1= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,compq='I', compz='I', joba='T', tol=0.0) - - A_2,E_2,B_2,C_2,ranke_2,rnka22_2,Q_2,Z_2= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,Q=Qin,Z=Zin,compq='U', compz='U', joba='T', tol=0.0) - - assert_equal(A_1, A_2) - assert_equal(E_1, E_2) - assert_equal(B_1, B_2) - assert_equal(C_1, C_2) - assert_equal(ranke_1, ranke_2) - assert_equal(rnka22_1, rnka22_2) - - assert_almost_equal(np.dot(Qin, Q_1), Q_2) - assert_almost_equal(np.dot(Zin, Z_1), Z_2) - - -if __name__ == "__main__": - unittest.main() +def test1_tg01fd(): + """ test1: Verify from tg01fd with input parameters according to test in documentation """ + A,E,B,C,ranke,rnka22,Q,Z = transform.tg01fd(l=test1_l,n=test1_n,m=test1_m,p=test1_p,A=test1_A,E=test1_E,B=test1_B,C=test1_C,compq='I',compz='I',joba='T',tol=test1_tol) + assert_almost_equal(A, test1_Aexp) + assert_almost_equal(E, test1_Eexp) + assert_almost_equal(B, test1_Bexp) + assert_almost_equal(C, test1_Cexp) + assert_almost_equal(Q, test1_Qexp) + assert_almost_equal(Z, test1_Zexp) + assert_equal(test1_ranke_exp, ranke) + assert_equal(test1_rnka22_exp, rnka22) + +def test2_tg01fd(): + """ verify that Q and Z output with compq and compz set to 'U' equals the dot product of Q and Z input and Q and Z output with compq and compz set to 'I' """ + + l = 30 + n = 30 + m = 70 + p = 44 + + np.random.seed(0) + + Ain = np.random.rand(l, n) + Ein = np.random.rand(l, n) + Bin = np.random.rand(n, m) + Cin = np.random.rand(p, n) + Qin = np.random.randn(l,l) + Zin = np.random.randn(n,n) + + A_1,E_1,B_1,C_1,ranke_1,rnka22_1,Q_1,Z_1= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,compq='I', compz='I', joba='T', tol=0.0) + + A_2,E_2,B_2,C_2,ranke_2,rnka22_2,Q_2,Z_2= transform.tg01fd(l=l,n=n,m=m,p=p,A=Ain,E=Ein,B=Bin,C=Cin,Q=Qin,Z=Zin,compq='U', compz='U', joba='T', tol=0.0) + + assert_equal(A_1, A_2) + assert_equal(E_1, E_2) + assert_equal(B_1, B_2) + assert_equal(C_1, C_2) + assert_equal(ranke_1, ranke_2) + assert_equal(rnka22_1, rnka22_2) + + assert_almost_equal(np.dot(Qin, Q_1), Q_2) + assert_almost_equal(np.dot(Zin, Z_1), Z_2) From 36a44f7b1ee6c1a6b730d0e1680c0aa43f27d43a Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Fri, 25 Aug 2023 10:04:43 +0200 Subject: [PATCH 348/405] isort --- slycot/tests/test_ab01.py | 1 - slycot/tests/test_ab04md.py | 4 ++-- slycot/tests/test_ab08n.py | 6 +++--- slycot/tests/test_ab13bd.py | 8 ++++---- slycot/tests/test_ab13md.py | 3 +-- slycot/tests/test_ag08bd.py | 4 ++-- slycot/tests/test_analysis.py | 4 +++- slycot/tests/test_examples.py | 1 + slycot/tests/test_exceptions.py | 4 ++-- slycot/tests/test_mc.py | 3 ++- slycot/tests/test_sb.py | 12 ++++++------ slycot/tests/test_sg02ad.py | 5 +++-- slycot/tests/test_sg03ad.py | 4 ++-- slycot/tests/test_tb05ad.py | 4 ++-- slycot/tests/test_tg01ad.py | 4 ++-- slycot/tests/test_tg01fd.py | 4 ++-- slycot/tests/test_transform.py | 4 +++- 17 files changed, 40 insertions(+), 35 deletions(-) diff --git a/slycot/tests/test_ab01.py b/slycot/tests/test_ab01.py index ec544b13..01c1242b 100644 --- a/slycot/tests/test_ab01.py +++ b/slycot/tests/test_ab01.py @@ -6,7 +6,6 @@ from numpy import array from numpy.testing import assert_allclose, assert_equal - from scipy.linalg.lapack import dorgqr from slycot.analysis import ab01nd diff --git a/slycot/tests/test_ab04md.py b/slycot/tests/test_ab04md.py index 076c4a6c..bafee439 100644 --- a/slycot/tests/test_ab04md.py +++ b/slycot/tests/test_ab04md.py @@ -1,8 +1,8 @@ -from slycot import analysis import numpy as np - from numpy.testing import assert_allclose +from slycot import analysis + class Test_ab04md: """Test ab04md. diff --git a/slycot/tests/test_ab08n.py b/slycot/tests/test_ab08n.py index 130ae95d..c777fc07 100644 --- a/slycot/tests/test_ab08n.py +++ b/slycot/tests/test_ab08n.py @@ -1,11 +1,11 @@ # =================================================== # ab08n* tests -from slycot import analysis import numpy as np - +from numpy.testing import assert_allclose, assert_equal from scipy.linalg import eig -from numpy.testing import assert_equal, assert_allclose + +from slycot import analysis class Test_ab08nX: diff --git a/slycot/tests/test_ab13bd.py b/slycot/tests/test_ab13bd.py index db4a2bd7..dd2a735a 100644 --- a/slycot/tests/test_ab13bd.py +++ b/slycot/tests/test_ab13bd.py @@ -1,12 +1,12 @@ # =================================================== # ab08n* tests -from slycot import analysis import numpy as np +from numpy.testing import assert_allclose, assert_array_equal, assert_equal +from scipy import linalg, signal + +from slycot import analysis -from scipy import linalg -from scipy import signal -from numpy.testing import assert_equal, assert_allclose, assert_array_equal class Test_ab13bd: """ Test regular pencil construction ab08nX with input parameters diff --git a/slycot/tests/test_ab13md.py b/slycot/tests/test_ab13md.py index df69a6b3..5a30f5ba 100644 --- a/slycot/tests/test_ab13md.py +++ b/slycot/tests/test_ab13md.py @@ -1,7 +1,6 @@ import numpy as np -from numpy.testing import assert_allclose, assert_array_less - import pytest +from numpy.testing import assert_allclose, assert_array_less from slycot import ab13md diff --git a/slycot/tests/test_ag08bd.py b/slycot/tests/test_ag08bd.py index e849cef4..97aa2b41 100644 --- a/slycot/tests/test_ag08bd.py +++ b/slycot/tests/test_ag08bd.py @@ -1,10 +1,10 @@ """Verify ag08bd with input parameters according to example in documentation.""" -from slycot import analysis import numpy as np - from numpy.testing import assert_almost_equal, assert_equal +from slycot import analysis + # test1 input parameters test1_l = 9 diff --git a/slycot/tests/test_analysis.py b/slycot/tests/test_analysis.py index 701eab4a..0b899580 100644 --- a/slycot/tests/test_analysis.py +++ b/slycot/tests/test_analysis.py @@ -3,10 +3,12 @@ # repagh , Aug 2019 -import pytest import re +import pytest + from slycot import mc01td from slycot.exceptions import SlycotResultWarning diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index 00e406db..e6f97a07 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -1,14 +1,14 @@ # =================================================== # sb* synthesis tests -from slycot import synthesis -from slycot.exceptions import raise_if_slycot_error, \ - SlycotParameterError, SlycotArithmeticError, \ - SlycotResultWarning - +import pytest from numpy import array, eye, zeros from numpy.testing import assert_allclose, assert_raises -import pytest + +from slycot import synthesis +from slycot.exceptions import (SlycotArithmeticError, SlycotParameterError, + SlycotResultWarning, raise_if_slycot_error) + from .test_exceptions import assert_docstring_parse diff --git a/slycot/tests/test_sg02ad.py b/slycot/tests/test_sg02ad.py index d640b159..1576a8ec 100644 --- a/slycot/tests/test_sg02ad.py +++ b/slycot/tests/test_sg02ad.py @@ -2,11 +2,12 @@ # test_sg02ad.py - test suite for ricatti equation solving # RvP, 19 Jun 2017 -from slycot import synthesis import numpy as np - from numpy.testing import assert_almost_equal +from slycot import synthesis + + def test_sg02ad_case1(): n = 3 m = 1 diff --git a/slycot/tests/test_sg03ad.py b/slycot/tests/test_sg03ad.py index 1352ebb8..a5976e0d 100644 --- a/slycot/tests/test_sg03ad.py +++ b/slycot/tests/test_sg03ad.py @@ -2,11 +2,11 @@ # test_sg03ad.py - test suite for stability margin commands # RvP, 15 Jun 2017 -from slycot import synthesis import numpy as np - from numpy.testing import assert_almost_equal +from slycot import synthesis + # test cases from # Penzl T., Numerical Solution of Generalized Lyapunov Equations # http://www.qucosa.de/fileadmin/data/qucosa/documents/4168/data/b002.pdf diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index b5a1d3e3..900a49a2 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -3,10 +3,10 @@ import sys -import pytest import numpy as np -from scipy.linalg import matrix_balance, eig +import pytest from numpy.testing import assert_almost_equal +from scipy.linalg import eig, matrix_balance from slycot import transform from slycot.exceptions import SlycotArithmeticError, SlycotParameterError diff --git a/slycot/tests/test_tg01ad.py b/slycot/tests/test_tg01ad.py index db9479aa..864d41be 100644 --- a/slycot/tests/test_tg01ad.py +++ b/slycot/tests/test_tg01ad.py @@ -1,10 +1,10 @@ # =================================================== # tg01ad tests -from slycot import transform import numpy as np +from numpy.testing import assert_almost_equal, assert_equal, assert_raises -from numpy.testing import assert_raises, assert_almost_equal, assert_equal +from slycot import transform # test1 input parameters diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py index 70ebef19..902d1ef2 100644 --- a/slycot/tests/test_tg01fd.py +++ b/slycot/tests/test_tg01fd.py @@ -1,10 +1,10 @@ # =================================================== # tg01fd tests -from slycot import transform import numpy as np +from numpy.testing import assert_almost_equal, assert_equal, assert_raises -from numpy.testing import assert_raises, assert_almost_equal, assert_equal +from slycot import transform # test1 input parameters test1_l = 4 diff --git a/slycot/tests/test_transform.py b/slycot/tests/test_transform.py index fa22c514..928ac5d4 100644 --- a/slycot/tests/test_transform.py +++ b/slycot/tests/test_transform.py @@ -3,10 +3,12 @@ # repagh Date: Tue, 1 Aug 2023 19:35:38 +0200 Subject: [PATCH 349/405] Add sb01yd, first commit --- slycot/__init__.py | 4 +- slycot/src/sb10yd.pyf | 28 +++++++++++ slycot/src/synthesis.pyf | 21 ++++++++ slycot/synthesis.py | 95 +++++++++++++++++++++++++++++++++++++ slycot/tests/test_sb10yd.py | 63 ++++++++++++++++++++++++ 5 files changed, 209 insertions(+), 2 deletions(-) create mode 100644 slycot/src/sb10yd.pyf create mode 100644 slycot/tests/test_sb10yd.py diff --git a/slycot/__init__.py b/slycot/__init__.py index 32b4a5db..9d8704a8 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -53,12 +53,12 @@ # Nonlinear Systems (0/16 wrapped) - # Synthesis routines ((15+1)/131 wrapped), sb03md57 is not part of slicot + # Synthesis routines ((16+1)/131 wrapped), sb03md57 is not part of slicot from .synthesis import (sb01bd, sb02md, sb02mt, sb02od, sb03md, sb03md57, sb03od, sb04md, sb04qd, - sb10ad, sb10dd, sb10fd, sb10hd, + sb10ad, sb10dd, sb10fd, sb10hd, sb10yd, sg02ad, sg03ad, sg03bd) diff --git a/slycot/src/sb10yd.pyf b/slycot/src/sb10yd.pyf new file mode 100644 index 00000000..43c9850e --- /dev/null +++ b/slycot/src/sb10yd.pyf @@ -0,0 +1,28 @@ +! -*- f90 -*- +! Note: the context of this file is case sensitive. + +subroutine sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,a,lda,b,c,d,tol,iwork,dwork,ldwork,zwork,lzwork,info) ! in SB10YD.f + integer :: discfl + integer :: flag + integer :: lendat + double precision dimension(*) :: rfrdat + double precision dimension(*) :: ifrdat + double precision dimension(*) :: omega + integer :: n + double precision dimension(lda,*) :: a + integer, optional,check(shape(a, 0) == lda),depend(a) :: lda=shape(a, 0) + double precision dimension(*) :: b + double precision dimension(*) :: c + double precision dimension(*) :: d + double precision :: tol + integer dimension(*) :: iwork + double precision dimension(*) :: dwork + integer :: ldwork + complex*16 dimension(*) :: zwork + integer :: lzwork + integer :: info +end subroutine sb10yd + +! This file was auto-generated with f2py (version:1.25.1). +! See: +! https://web.archive.org/web/20140822061353/http://cens.ioc.ee/projects/f2py2e diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index a84cd03f..7104f177 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -1,4 +1,25 @@ ! -*- f90 -*- +subroutine sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,a,lda,b,c,d,tol,iwork,dwork,ldwork,zwork,lzwork,info) ! in SB10YD.f + integer intent(in) :: discfl + integer intent(in) :: flag + integer intent(in) :: lendat + double precision intent(in), dimension(lendat), depend(lendat) :: rfrdat + double precision intent(in), dimension(lendat), depend(lendat) :: ifrdat + double precision intent(in), dimension(lendat), depend(lendat) :: omega + integer intent(in,out,copy), :: n + double precision intent(out), dimension(lda,n) :: a + integer, intent(hide) :: lda=max(n,1) + double precision intent(out), dimension(n,1) :: b + double precision intent(out), dimension(1,n) :: c + double precision intent(out), dimension(1,1) :: d + double precision :: tol + integer intent(hide, cache), dimension(max(2,2*n+1)), depend(n) :: iwork + double precision intent(hide, cache), dimension(ldwork), depend(ldwork) :: dwork + integer intent(in) :: ldwork + complex*16 intent(hide, cache), dimension(lzwork), depend(lzwork) :: zwork + integer intent(in):: lzwork + integer intent(out):: info +end subroutine sb10yd subroutine sb01bd(dico,n,m,np,alpha,a,lda,b,ldb,wr,wi,nfp,nap,nup,f,ldf,z,ldz,tol,dwork,ldwork,iwarn,info) ! in SB01BD.f character :: dico integer required,check(n>=0) :: n diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 0ffbbd93..80f5a722 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -25,6 +25,101 @@ from . import _wrapper from .exceptions import raise_if_slycot_error, SlycotParameterError +def sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,ldwork=None): + """ A,B,C,D = sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,[ldwork,lzwork]) + + To fit frequency response data with a stable, minimum phase SISO system + + Parameters + ---------- + discfl : int + Indicatres the type of the system, as follows: + = 0: continuous-time system; + = 1: discrete-time system. + flag : int + If flag = 0, then the system zeros and poles are not constrained. + If flag = 1, then the system zeros and poles will have negative + real parts in the continuous-time case, or moduli less than 1 in + the discrete-time case. Consequently, flag must be equal to 1 in + mu-synthesis routines. + lendat : int + The length of the vectors rfrdat, ifrdat and omega. + length >= 2. + rfrdat : double precision array, dimension (lendat) + The real part of the frequency data to be fitted. + ifrdat : double precision array, dimension (lendat) + The imaginary part of the frequency data to be fitted. + omega : double precision array, dimension (lendat) + The frequencies corresponding to rfrdat and ifrdat. + These value must be nonnegative and monotonically increasing. + Additionally, for discrete-time systems they must be between 0 and PI. + n : integer + On entry, the desired order of the system to be fitted. + n <= lendat-1. + tol : int, optional + The length of the cache array. + ldwork >= max( 1, 2*n*n + 2*n + n*MAX( 5, n + m + np ) ). + For good performance, ldwork must generally be larger. + + Returns + ------- + A : (n, n) double precision array + The leading n-by-n part of this array contains the + matrix A. + B : (n) double precision array + The computed vector B. + C : (n) double precision array + The computed vector C. + D : (1) double precision array + The computed scalar D. + + Raises + ------ + SlycotArithmeticError + :info == 0: successful exit; + :info < 0: if infor = -i, the i-th argument had an illegal value + :info = 1: if the discret --> continous transformation cannot be made; + :info = 2: if the system poles cannot be found; + :info = 3: if the inverse system cannot be found, i.e., D is (close to) zero; + :info = 4: if the system zeros cannot be found; + :info = 5: if the state-space representation of the new transfer function T(s) cannot found; + :info = 6: if the continous --> discrete transformation cannot be made. + The iteration for computing singular value + decomposition did not converge. + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['discfl', 'flag', 'lendat', 'rfrdat', 'ifrdat', 'omega', + 'n', 'A', 'lda' + hidden, 'B', 'C', 'D', + 'TOL', 'IWORK' + hidden, 'DWORK' + hidden, 'LDWORK', + 'ZWORK' + hidden, 'LZWORK', 'INFO' + hidden] + + if ldwork is None: + lw1 = 2*lendat + 4*2048 + lw2 = lendat + 6*2048 + mn = min(2*lendat,2*n+1) + if n > 0: + lw3 = 2*lendat*(2*n+1) + max(2*lendat,2*n+1) + max(mn+6*n+4,2*mn+1) + elif n == 0: + lw3 = 4*lendat + 5 + if flag == 1: + lw4 = max(n*n+5*n,6*n+1+min(1,n)) + elif flag == 0: + lw4 = 0 + ldwork = max(2, lw1, lw2, lw3, lw4) + if n > 0: + lzwork = lendat*(2*n+3) + elif n == 0: + lzwork = lendat + + out = _wrapper.sb10yd( + discfl, flag, lendat, rfrdat, ifrdat, omega, + n, + tol,ldwork,lzwork) + + raise_if_slycot_error(out[-1], arg_list, sb10yd.__doc__, locals()) + + return out[:-1] def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): """ A_z,w,nfp,nap,nup,F,Z = sb01bd(n,m,np,alpha,A,B,w,dico,[tol,ldwork]) diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py new file mode 100644 index 00000000..4e87db01 --- /dev/null +++ b/slycot/tests/test_sb10yd.py @@ -0,0 +1,63 @@ +import unittest +from slycot import synthesis +import numpy as np +from scipy import signal + +from numpy.testing import assert_almost_equal, assert_equal + +class test_sb10yd(unittest.TestCase): + + def test_sb10yd_exec(self): + """Test execution. + """ + + A = np.array([[0.0, 1.0], [-0.5, -0.1]]) + B = np.array([[0.0], [1.0]]) + C = np.array([[1.0, 0.0]]) + D = np.zeros((1,1)) + + sys_tf = signal.ss2tf(A,B,C,D) + num, den = sys_tf + + omega, H = signal.freqs(num.squeeze(), den) + + real_H_resp = np.real(H) + imag_H_resp = np.imag(H) + + n = 2 + n_id, *_ = synthesis.sb10yd( + 0, 0, len(omega), + real_H_resp, imag_H_resp, omega, n, tol=0) + + np.testing.assert_equal(n, n_id) + + def test_sb10yd_allclose(self): + """Compare given and identified frequency response. + """ + + A = np.array([[0.0, 1.0], [-0.5, -0.1]]) + B = np.array([[0.0], [1.0]]) + C = np.array([[1.0, 0.0]]) + D = np.zeros((1,1)) + + sys_tf = signal.ss2tf(A,B,C,D) + num, den = sys_tf + + omega, H = signal.freqs(num.squeeze(), den) + + real_H_resp = np.real(H) + imag_H_resp = np.imag(H) + + n = 2 + n_id, A_id, B_id, C_id, D_id = synthesis.sb10yd( + 0, 0, len(omega), + real_H_resp, imag_H_resp, omega, n, tol=0) + + sys_tf_id = signal.ss2tf(A_id,B_id,C_id,D_id) + num_id, den_id = sys_tf_id + w_id, H_id = signal.freqs(num_id.squeeze(), den_id, worN=omega) + + np.testing.assert_allclose(abs(H),abs(H_id),rtol=0.3,atol=0) + +if __name__ == "__main__": + unittest.main() \ No newline at end of file From 374434a19bba862733783b1866f67ea70b911f9a Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 3 Aug 2023 17:17:22 +0200 Subject: [PATCH 350/405] Improve docstring, restore the order of procedurces --- slycot/src/synthesis.pyf | 42 ++++---- slycot/synthesis.py | 206 +++++++++++++++++++++------------------ 2 files changed, 131 insertions(+), 117 deletions(-) diff --git a/slycot/src/synthesis.pyf b/slycot/src/synthesis.pyf index 7104f177..1f797763 100644 --- a/slycot/src/synthesis.pyf +++ b/slycot/src/synthesis.pyf @@ -1,25 +1,4 @@ ! -*- f90 -*- -subroutine sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,a,lda,b,c,d,tol,iwork,dwork,ldwork,zwork,lzwork,info) ! in SB10YD.f - integer intent(in) :: discfl - integer intent(in) :: flag - integer intent(in) :: lendat - double precision intent(in), dimension(lendat), depend(lendat) :: rfrdat - double precision intent(in), dimension(lendat), depend(lendat) :: ifrdat - double precision intent(in), dimension(lendat), depend(lendat) :: omega - integer intent(in,out,copy), :: n - double precision intent(out), dimension(lda,n) :: a - integer, intent(hide) :: lda=max(n,1) - double precision intent(out), dimension(n,1) :: b - double precision intent(out), dimension(1,n) :: c - double precision intent(out), dimension(1,1) :: d - double precision :: tol - integer intent(hide, cache), dimension(max(2,2*n+1)), depend(n) :: iwork - double precision intent(hide, cache), dimension(ldwork), depend(ldwork) :: dwork - integer intent(in) :: ldwork - complex*16 intent(hide, cache), dimension(lzwork), depend(lzwork) :: zwork - integer intent(in):: lzwork - integer intent(out):: info -end subroutine sb10yd subroutine sb01bd(dico,n,m,np,alpha,a,lda,b,ldb,wr,wi,nfp,nap,nup,f,ldf,z,ldz,tol,dwork,ldwork,iwarn,info) ! in SB01BD.f character :: dico integer required,check(n>=0) :: n @@ -596,6 +575,27 @@ subroutine sb10jd(n,m,np,a,lda,b,ldb,c,ldc,d,ldd,e,lde,nsys,dwork,ldwork,info) ! integer required intent(in) :: ldwork integer intent(out) :: info end subroutine sb10jd +subroutine sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,a,lda,b,c,d,tol,iwork,dwork,ldwork,zwork,lzwork,info) ! in SB10YD.f + integer intent(in) :: discfl + integer intent(in) :: flag + integer intent(in) :: lendat + double precision intent(in), dimension(lendat), depend(lendat) :: rfrdat + double precision intent(in), dimension(lendat), depend(lendat) :: ifrdat + double precision intent(in), dimension(lendat), depend(lendat) :: omega + integer intent(in,out,copy), :: n + double precision intent(out), dimension(lda,n) :: a + integer, intent(hide) :: lda=max(n,1) + double precision intent(out), dimension(n,1) :: b + double precision intent(out), dimension(1,n) :: c + double precision intent(out), dimension(1,1) :: d + double precision :: tol + integer intent(hide, cache), dimension(max(2,2*n+1)), depend(n) :: iwork + double precision intent(hide, cache), dimension(ldwork), depend(ldwork) :: dwork + integer intent(in) :: ldwork + complex*16 intent(hide, cache), dimension(lzwork), depend(lzwork) :: zwork + integer intent(in):: lzwork + integer intent(out):: info +end subroutine sb10yd subroutine sg03ad(dico,job,fact,trans,uplo,n,a,lda,e,lde,q,ldq,z,ldz,x,ldx,scale,sep,ferr,alphar,alphai,beta,iwork,dwork,ldwork,info) ! in SG03AD.f character :: dico character :: job diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 80f5a722..648465f5 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -25,102 +25,6 @@ from . import _wrapper from .exceptions import raise_if_slycot_error, SlycotParameterError -def sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,ldwork=None): - """ A,B,C,D = sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,[ldwork,lzwork]) - - To fit frequency response data with a stable, minimum phase SISO system - - Parameters - ---------- - discfl : int - Indicatres the type of the system, as follows: - = 0: continuous-time system; - = 1: discrete-time system. - flag : int - If flag = 0, then the system zeros and poles are not constrained. - If flag = 1, then the system zeros and poles will have negative - real parts in the continuous-time case, or moduli less than 1 in - the discrete-time case. Consequently, flag must be equal to 1 in - mu-synthesis routines. - lendat : int - The length of the vectors rfrdat, ifrdat and omega. - length >= 2. - rfrdat : double precision array, dimension (lendat) - The real part of the frequency data to be fitted. - ifrdat : double precision array, dimension (lendat) - The imaginary part of the frequency data to be fitted. - omega : double precision array, dimension (lendat) - The frequencies corresponding to rfrdat and ifrdat. - These value must be nonnegative and monotonically increasing. - Additionally, for discrete-time systems they must be between 0 and PI. - n : integer - On entry, the desired order of the system to be fitted. - n <= lendat-1. - tol : int, optional - The length of the cache array. - ldwork >= max( 1, 2*n*n + 2*n + n*MAX( 5, n + m + np ) ). - For good performance, ldwork must generally be larger. - - Returns - ------- - A : (n, n) double precision array - The leading n-by-n part of this array contains the - matrix A. - B : (n) double precision array - The computed vector B. - C : (n) double precision array - The computed vector C. - D : (1) double precision array - The computed scalar D. - - Raises - ------ - SlycotArithmeticError - :info == 0: successful exit; - :info < 0: if infor = -i, the i-th argument had an illegal value - :info = 1: if the discret --> continous transformation cannot be made; - :info = 2: if the system poles cannot be found; - :info = 3: if the inverse system cannot be found, i.e., D is (close to) zero; - :info = 4: if the system zeros cannot be found; - :info = 5: if the state-space representation of the new transfer function T(s) cannot found; - :info = 6: if the continous --> discrete transformation cannot be made. - The iteration for computing singular value - decomposition did not converge. - """ - - hidden = ' (hidden by the wrapper)' - arg_list = ['discfl', 'flag', 'lendat', 'rfrdat', 'ifrdat', 'omega', - 'n', 'A', 'lda' + hidden, 'B', 'C', 'D', - 'TOL', 'IWORK' + hidden, 'DWORK' + hidden, 'LDWORK', - 'ZWORK' + hidden, 'LZWORK', 'INFO' + hidden] - - if ldwork is None: - lw1 = 2*lendat + 4*2048 - lw2 = lendat + 6*2048 - mn = min(2*lendat,2*n+1) - if n > 0: - lw3 = 2*lendat*(2*n+1) + max(2*lendat,2*n+1) + max(mn+6*n+4,2*mn+1) - elif n == 0: - lw3 = 4*lendat + 5 - if flag == 1: - lw4 = max(n*n+5*n,6*n+1+min(1,n)) - elif flag == 0: - lw4 = 0 - ldwork = max(2, lw1, lw2, lw3, lw4) - if n > 0: - lzwork = lendat*(2*n+3) - elif n == 0: - lzwork = lendat - - out = _wrapper.sb10yd( - discfl, flag, lendat, rfrdat, ifrdat, omega, - n, - tol,ldwork,lzwork) - - raise_if_slycot_error(out[-1], arg_list, sb10yd.__doc__, locals()) - - return out[:-1] - def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): """ A_z,w,nfp,nap,nup,F,Z = sb01bd(n,m,np,alpha,A,B,w,dico,[tol,ldwork]) @@ -1795,6 +1699,116 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): return A[:nsys,:nsys],B[:nsys,:m],C[:np, :nsys],D[:np, :m] +def sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,ldwork=None): + """ A,B,C,D = sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,[ldwork]) + + To fit frequency response data with a stable, minimum phase SISO system + + :: + + dx/dt = A*x + B*u + y = C*x + D*u + + :: + + x[n+1] = A*x[n] + B*u[n] + y[n] = C*x[n] + D*u[n] . + + Parameters + ---------- + discfl : int + Indicatres the type of the system, as follows: + = 0: continuous-time system; + = 1: discrete-time system. + flag : int + If flag = 0, then the system zeros and poles are not constrained. + If flag = 1, then the system zeros and poles will have negative + real parts in the continuous-time case, or moduli less than 1 in + the discrete-time case. Consequently, flag must be equal to 1 in + mu-synthesis routines. + lendat : int + The length of the vectors rfrdat, ifrdat and omega. + length >= 2. + rfrdat : dimension (lendat), array_like + The real part of the frequency data to be fitted. + ifrdat : dimension (lendat), array_like + The imaginary part of the frequency data to be fitted. + omega : dimension (lendat), array_like + The frequencies corresponding to rfrdat and ifrdat. + These value must be nonnegative and monotonically increasing. + Additionally, for discrete-time systems they must be between 0 and PI. + n : int + On entry, the desired order of the system to be fitted. + n <= lendat-1. + tol : int, optional + The length of the cache array. + ldwork : int + With None it will be automatically calculated. + For details see SLICOT help. + + Returns + ------- + n : int + The order of the obtained system. The value of n + could only be modified if n > 0 and flag = 1. + A : (n, n) ndarray + The computed matrix A. + matrix A. + B : (n, 1) ndarray + The computed column vector B. + C : (1, n) ndarray + The computed row vector C. + D : (1, 1) ndarray + The computed scalar D. + + Raises + ------ + SlycotArithmeticError + :info == 0: successful exit; + :info < 0: if info = -i, the i-th argument had an illegal value + :info = 1: if the discret --> continous transformation cannot be made; + :info = 2: if the system poles cannot be found; + :info = 3: if the inverse system cannot be found, i.e., D is (close to) zero; + :info = 4: if the system zeros cannot be found; + :info = 5: if the state-space representation of the new transfer function T(s) cannot found; + :info = 6: if the continous --> discrete transformation cannot be made. + The iteration for computing singular value + decomposition did not converge. + """ + + hidden = ' (hidden by the wrapper)' + arg_list = ['discfl', 'flag', 'lendat', 'rfrdat', 'ifrdat', 'omega', + 'n', 'A', 'lda' + hidden, 'B', 'C', 'D', + 'TOL', 'IWORK' + hidden, 'DWORK' + hidden, 'LDWORK', + 'ZWORK' + hidden, 'LZWORK', 'INFO' + hidden] + + if ldwork is None: + lw1 = 2*lendat + 4*2048 + lw2 = lendat + 6*2048 + mn = min(2*lendat,2*n+1) + if n > 0: + lw3 = 2*lendat*(2*n+1) + max(2*lendat,2*n+1) + max(mn+6*n+4,2*mn+1) + elif n == 0: + lw3 = 4*lendat + 5 + if flag == 1: + lw4 = max(n*n+5*n,6*n+1+min(1,n)) + elif flag == 0: + lw4 = 0 + ldwork = max(2, lw1, lw2, lw3, lw4) + if n > 0: + lzwork = lendat*(2*n+3) + elif n == 0: + lzwork = lendat + + out = _wrapper.sb10yd( + discfl, flag, lendat, rfrdat, ifrdat, omega, + n, + tol,ldwork,lzwork) + + raise_if_slycot_error(out[-1], arg_list, sb10yd.__doc__, locals()) + + return out[:-1] + def sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,ldwork=None): """ A,E,Q,Z,X,scale,sep,ferr,alphar,alphai,beta = sg03ad(dico,job,fact,trans,uplo,N,A,E,Q,Z,X,[ldwork]) From 459d501e3a5fe7d5bed5adb4f68b0c89411f2ba0 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 3 Aug 2023 17:20:35 +0200 Subject: [PATCH 351/405] Fix import order in __init__.py --- slycot/__init__.py | 3 +++ 1 file changed, 3 insertions(+) diff --git a/slycot/__init__.py b/slycot/__init__.py index 9d8704a8..eba508e6 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -53,7 +53,10 @@ # Nonlinear Systems (0/16 wrapped) +<<<<<<< HEAD # Synthesis routines ((16+1)/131 wrapped), sb03md57 is not part of slicot +======= +>>>>>>> 32e468f (Fix import order in __init__.py) from .synthesis import (sb01bd, sb02md, sb02mt, sb02od, sb03md, sb03md57, sb03od, From 57d0b088b1ff1034a37b451ae6379c10e9052f21 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 3 Aug 2023 18:11:10 +0200 Subject: [PATCH 352/405] Improve unitest --- slycot/__init__.py | 3 --- slycot/tests/test_sb10yd.py | 21 +++++++++++++++------ 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index eba508e6..9d8704a8 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -53,10 +53,7 @@ # Nonlinear Systems (0/16 wrapped) -<<<<<<< HEAD # Synthesis routines ((16+1)/131 wrapped), sb03md57 is not part of slicot -======= ->>>>>>> 32e468f (Fix import order in __init__.py) from .synthesis import (sb01bd, sb02md, sb02mt, sb02od, sb03md, sb03md57, sb03od, diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py index 4e87db01..fcb7aef4 100644 --- a/slycot/tests/test_sb10yd.py +++ b/slycot/tests/test_sb10yd.py @@ -3,12 +3,10 @@ import numpy as np from scipy import signal -from numpy.testing import assert_almost_equal, assert_equal - class test_sb10yd(unittest.TestCase): def test_sb10yd_exec(self): - """Test execution. + """A simple execution test. """ A = np.array([[0.0, 1.0], [-0.5, -0.1]]) @@ -25,10 +23,13 @@ def test_sb10yd_exec(self): imag_H_resp = np.imag(H) n = 2 + dico = 0 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles n_id, *_ = synthesis.sb10yd( - 0, 0, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) + # Because flag = 0, we expect n == n_id np.testing.assert_equal(n, n_id) def test_sb10yd_allclose(self): @@ -49,15 +50,23 @@ def test_sb10yd_allclose(self): imag_H_resp = np.imag(H) n = 2 + dico = 0 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles n_id, A_id, B_id, C_id, D_id = synthesis.sb10yd( - 0, 0, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) sys_tf_id = signal.ss2tf(A_id,B_id,C_id,D_id) num_id, den_id = sys_tf_id w_id, H_id = signal.freqs(num_id.squeeze(), den_id, worN=omega) - np.testing.assert_allclose(abs(H),abs(H_id),rtol=0.3,atol=0) + #print(np.max(abs(H)-abs(H_id)), np.max(abs(H_id)-abs(H))) + #print(np.max(abs(H_id)/abs(H))) + + # Compare given and identified frequency response up to some toleration. + # absolute(a-b) <= atol + rtol*abolute(b), element-wise true + # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true + np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=0.1) if __name__ == "__main__": unittest.main() \ No newline at end of file From 59adbfdbd4956c7afb06bb1bef866c7deb60e6fa Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 17 Aug 2023 23:10:47 +0200 Subject: [PATCH 353/405] Delete sb10yd.pyf artifact created by f2py --- slycot/src/sb10yd.pyf | 28 ---------------------------- 1 file changed, 28 deletions(-) delete mode 100644 slycot/src/sb10yd.pyf diff --git a/slycot/src/sb10yd.pyf b/slycot/src/sb10yd.pyf deleted file mode 100644 index 43c9850e..00000000 --- a/slycot/src/sb10yd.pyf +++ /dev/null @@ -1,28 +0,0 @@ -! -*- f90 -*- -! Note: the context of this file is case sensitive. - -subroutine sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,a,lda,b,c,d,tol,iwork,dwork,ldwork,zwork,lzwork,info) ! in SB10YD.f - integer :: discfl - integer :: flag - integer :: lendat - double precision dimension(*) :: rfrdat - double precision dimension(*) :: ifrdat - double precision dimension(*) :: omega - integer :: n - double precision dimension(lda,*) :: a - integer, optional,check(shape(a, 0) == lda),depend(a) :: lda=shape(a, 0) - double precision dimension(*) :: b - double precision dimension(*) :: c - double precision dimension(*) :: d - double precision :: tol - integer dimension(*) :: iwork - double precision dimension(*) :: dwork - integer :: ldwork - complex*16 dimension(*) :: zwork - integer :: lzwork - integer :: info -end subroutine sb10yd - -! This file was auto-generated with f2py (version:1.25.1). -! See: -! https://web.archive.org/web/20140822061353/http://cens.ioc.ee/projects/f2py2e From 2545fe4e2be0ef5389be289de3ce49c844bcad31 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 18 Aug 2023 00:01:01 +0200 Subject: [PATCH 354/405] Update docstring --- slycot/synthesis.py | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 648465f5..5f4e06e2 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -1702,7 +1702,10 @@ def sb10jd(n,m,np,A,B,C,D,E,ldwork=None): def sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,ldwork=None): """ A,B,C,D = sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,[ldwork]) - To fit frequency response data with a stable, minimum phase SISO system + To fit a supplied frequency response data with a stable, minimum + phase SISO (single-input single-output) system represented by its + matrices A, B, C, D. It handles both discrete- and continuous-time + cases. :: @@ -1805,7 +1808,7 @@ def sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,ldwork=None): n, tol,ldwork,lzwork) - raise_if_slycot_error(out[-1], arg_list, sb10yd.__doc__, locals()) + raise_if_slycot_error(out[-1], arg_list, sb10yd.__doc__) return out[:-1] From 0b1530f677ad966f84d56be12aed333603a18118 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 18 Aug 2023 00:01:30 +0200 Subject: [PATCH 355/405] Add unittest for discrete time case --- slycot/tests/test_sb10yd.py | 81 ++++++++++++++++++++++++++++++++++++- 1 file changed, 79 insertions(+), 2 deletions(-) diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py index fcb7aef4..07e1828c 100644 --- a/slycot/tests/test_sb10yd.py +++ b/slycot/tests/test_sb10yd.py @@ -3,9 +3,11 @@ import numpy as np from scipy import signal +import matplotlib.pyplot as plt + class test_sb10yd(unittest.TestCase): - def test_sb10yd_exec(self): + def test_sb10yd_cont_exec(self): """A simple execution test. """ @@ -32,7 +34,7 @@ def test_sb10yd_exec(self): # Because flag = 0, we expect n == n_id np.testing.assert_equal(n, n_id) - def test_sb10yd_allclose(self): + def test_sb10yd_cont_allclose(self): """Compare given and identified frequency response. """ @@ -68,5 +70,80 @@ def test_sb10yd_allclose(self): # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=0.1) + def test_sb10yd_disc_exec(self): + """A simple execution test. + """ + + A = np.array([[0.0, 1.0], [-0.5, -0.1]]) + B = np.array([[0.0], [1.0]]) + C = np.array([[1.0, 0.0]]) + D = np.zeros((1,1)) + + sys_tf = signal.ss2tf(A,B,C,D) + num, den = sys_tf + + dt = 0.1 + num, den, dt = signal.cont2discrete((num, den), dt, method="zoh") + print(den) + + omega, H = signal.freqz(num.squeeze(), den) + + real_H_resp = np.real(H) + imag_H_resp = np.imag(H) + + n = 2 + dico = 1 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles + n_id, *_ = synthesis.sb10yd( + dico, flag, len(omega), + real_H_resp, imag_H_resp, omega, n, tol=0) + + # Because flag = 0, we expect n == n_id + np.testing.assert_equal(n, n_id) + + def test_sb10yd_disc_allclose(self): + """Compare given and identified frequency response. + """ + + A = np.array([[0.0, 1.0], [-0.5, -0.1]]) + B = np.array([[0.0], [1.0]]) + C = np.array([[1.0, 0.0]]) + D = np.zeros((1,1)) + + sys_tf = signal.ss2tf(A,B,C,D) + num, den = sys_tf + + dt = 0.01 + num, den, dt = signal.cont2discrete((num, den), dt, method="zoh") + + omega, H = signal.freqz(num.squeeze(), den) + + real_H_resp = np.real(H) + imag_H_resp = np.imag(H) + + n = 2 + dico = 1 # 0 for discrete time + flag = 0 # 0 for no constraints on the poles + n_id, A_id, B_id, C_id, D_id = synthesis.sb10yd( + dico, flag, len(omega), + real_H_resp, imag_H_resp, omega, n, tol=0) + + sys_id = signal.dlti(A_id,B_id,C_id,D_id, dt=dt) + sys_tf_id = signal.TransferFunction(sys_id) + num_id, den_id = sys_tf_id.num, sys_tf_id.den + w_id, H_id = signal.freqz(num_id.squeeze(), den_id, worN=omega) + + #print(np.max(abs(H)-abs(H_id)), np.max(abs(H_id)-abs(H))) + #print(np.max(abs(H_id)/abs(H))) + + #plt.loglog(omega, abs(H)) + #plt.loglog(omega, abs(H_id)) + #plt.show(block=True) + + # Compare given and identified frequency response up to some toleration. + # absolute(a-b) <= atol + rtol*abolute(b), element-wise true + # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true + np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=1.0) + if __name__ == "__main__": unittest.main() \ No newline at end of file From 95676942c5655f501d0e471c282ac6f011a67c4a Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 18 Aug 2023 20:30:16 +0200 Subject: [PATCH 356/405] Delete matplotlib import in unittest --- slycot/tests/test_sb10yd.py | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py index 07e1828c..a05db9b9 100644 --- a/slycot/tests/test_sb10yd.py +++ b/slycot/tests/test_sb10yd.py @@ -3,8 +3,6 @@ import numpy as np from scipy import signal -import matplotlib.pyplot as plt - class test_sb10yd(unittest.TestCase): def test_sb10yd_cont_exec(self): @@ -92,7 +90,7 @@ def test_sb10yd_disc_exec(self): imag_H_resp = np.imag(H) n = 2 - dico = 1 # 0 for continuous time + dico = 1 # 0 for discrete time flag = 0 # 0 for no constraints on the poles n_id, *_ = synthesis.sb10yd( dico, flag, len(omega), @@ -136,10 +134,6 @@ def test_sb10yd_disc_allclose(self): #print(np.max(abs(H)-abs(H_id)), np.max(abs(H_id)-abs(H))) #print(np.max(abs(H_id)/abs(H))) - #plt.loglog(omega, abs(H)) - #plt.loglog(omega, abs(H_id)) - #plt.show(block=True) - # Compare given and identified frequency response up to some toleration. # absolute(a-b) <= atol + rtol*abolute(b), element-wise true # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true From 4206fef53c90b9c7dd7cf805a70c9f9ba16587b1 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 25 Aug 2023 18:02:24 +0200 Subject: [PATCH 357/405] Clean up pytest, get rid of unittest --- slycot/tests/test_sb10yd.py | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py index a05db9b9..c3157160 100644 --- a/slycot/tests/test_sb10yd.py +++ b/slycot/tests/test_sb10yd.py @@ -1,9 +1,8 @@ -import unittest from slycot import synthesis import numpy as np from scipy import signal -class test_sb10yd(unittest.TestCase): +class Test_sb10yd(): def test_sb10yd_cont_exec(self): """A simple execution test. @@ -137,7 +136,4 @@ def test_sb10yd_disc_allclose(self): # Compare given and identified frequency response up to some toleration. # absolute(a-b) <= atol + rtol*abolute(b), element-wise true # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true - np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=1.0) - -if __name__ == "__main__": - unittest.main() \ No newline at end of file + np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=1.0) \ No newline at end of file From 6ff1902986c36d98f8889bf8716085dabf2beaf1 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Fri, 25 Aug 2023 20:00:27 +0200 Subject: [PATCH 358/405] Update test, add case n=0 --- slycot/tests/test_sb10yd.py | 54 ++++++++++++++++++++++++++++++++++--- 1 file changed, 50 insertions(+), 4 deletions(-) diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py index c3157160..6f9fc4ed 100644 --- a/slycot/tests/test_sb10yd.py +++ b/slycot/tests/test_sb10yd.py @@ -4,8 +4,32 @@ class Test_sb10yd(): + # TODO: There are might be better systems/filters to do these tests. + + def test_sb10yd_cont_exec_case_n0(self): + """A simple execution test. Case n=0. + """ + + sys_tf = signal.TransferFunction(1,1) + num, den = sys_tf.num, sys_tf.den + + omega, H = signal.freqs(num, den) + + real_H_resp = np.real(H) + imag_H_resp = np.imag(H) + + n = 0 + dico = 0 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles + n_id, *_ = synthesis.sb10yd( + dico, flag, len(omega), + real_H_resp, imag_H_resp, omega, n, tol=0) + + # Because flag = 0, we expect n == n_id + np.testing.assert_equal(n, n_id) + def test_sb10yd_cont_exec(self): - """A simple execution test. + """A simple execution test. Case n=2. """ A = np.array([[0.0, 1.0], [-0.5, -0.1]]) @@ -32,7 +56,7 @@ def test_sb10yd_cont_exec(self): np.testing.assert_equal(n, n_id) def test_sb10yd_cont_allclose(self): - """Compare given and identified frequency response. + """Compare given and identified frequency response. Case n=2. """ A = np.array([[0.0, 1.0], [-0.5, -0.1]]) @@ -67,8 +91,30 @@ def test_sb10yd_cont_allclose(self): # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=0.1) + def test_sb10yd_disc_exec_case_n0(self): + """A simple execution test. Case n=0. + """ + + sys_tf = signal.TransferFunction(1,1,dt=0.1) + num, den = sys_tf.num, sys_tf.den + + omega, H = signal.freqz(num.squeeze(), den) + + real_H_resp = np.real(H) + imag_H_resp = np.imag(H) + + n = 0 + dico = 1 # 0 for discrete time + flag = 0 # 0 for no constraints on the poles + n_id, *_ = synthesis.sb10yd( + dico, flag, len(omega), + real_H_resp, imag_H_resp, omega, n, tol=0) + + # Because flag = 0, we expect n == n_id + np.testing.assert_equal(n, n_id) + def test_sb10yd_disc_exec(self): - """A simple execution test. + """A simple execution test. Case n=2. """ A = np.array([[0.0, 1.0], [-0.5, -0.1]]) @@ -99,7 +145,7 @@ def test_sb10yd_disc_exec(self): np.testing.assert_equal(n, n_id) def test_sb10yd_disc_allclose(self): - """Compare given and identified frequency response. + """Compare given and identified frequency response. Case n=2. """ A = np.array([[0.0, 1.0], [-0.5, -0.1]]) From 42b888536f89d761f02fca8bf7d4b7e688d65470 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 26 Aug 2023 12:37:46 +0200 Subject: [PATCH 359/405] Delint --- slycot/tests/test_sb10yd.py | 88 ++++++++++++++++--------------------- 1 file changed, 38 insertions(+), 50 deletions(-) diff --git a/slycot/tests/test_sb10yd.py b/slycot/tests/test_sb10yd.py index 6f9fc4ed..8574bd51 100644 --- a/slycot/tests/test_sb10yd.py +++ b/slycot/tests/test_sb10yd.py @@ -1,16 +1,17 @@ -from slycot import synthesis import numpy as np from scipy import signal +from slycot import synthesis + + class Test_sb10yd(): - # TODO: There are might be better systems/filters to do these tests. + # TODO: There might be better systems/filters to do these tests. def test_sb10yd_cont_exec_case_n0(self): """A simple execution test. Case n=0. """ - - sys_tf = signal.TransferFunction(1,1) + sys_tf = signal.TransferFunction(1, 1) num, den = sys_tf.num, sys_tf.den omega, H = signal.freqs(num, den) @@ -19,10 +20,10 @@ def test_sb10yd_cont_exec_case_n0(self): imag_H_resp = np.imag(H) n = 0 - dico = 0 # 0 for continuous time - flag = 0 # 0 for no constraints on the poles + dico = 0 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles n_id, *_ = synthesis.sb10yd( - dico, flag, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) # Because flag = 0, we expect n == n_id @@ -31,13 +32,12 @@ def test_sb10yd_cont_exec_case_n0(self): def test_sb10yd_cont_exec(self): """A simple execution test. Case n=2. """ - A = np.array([[0.0, 1.0], [-0.5, -0.1]]) B = np.array([[0.0], [1.0]]) C = np.array([[1.0, 0.0]]) - D = np.zeros((1,1)) + D = np.zeros((1, 1)) - sys_tf = signal.ss2tf(A,B,C,D) + sys_tf = signal.ss2tf(A, B, C, D) num, den = sys_tf omega, H = signal.freqs(num.squeeze(), den) @@ -46,10 +46,10 @@ def test_sb10yd_cont_exec(self): imag_H_resp = np.imag(H) n = 2 - dico = 0 # 0 for continuous time - flag = 0 # 0 for no constraints on the poles + dico = 0 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles n_id, *_ = synthesis.sb10yd( - dico, flag, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) # Because flag = 0, we expect n == n_id @@ -62,9 +62,9 @@ def test_sb10yd_cont_allclose(self): A = np.array([[0.0, 1.0], [-0.5, -0.1]]) B = np.array([[0.0], [1.0]]) C = np.array([[1.0, 0.0]]) - D = np.zeros((1,1)) + D = np.zeros((1, 1)) - sys_tf = signal.ss2tf(A,B,C,D) + sys_tf = signal.ss2tf(A, B, C, D) num, den = sys_tf omega, H = signal.freqs(num.squeeze(), den) @@ -73,29 +73,23 @@ def test_sb10yd_cont_allclose(self): imag_H_resp = np.imag(H) n = 2 - dico = 0 # 0 for continuous time - flag = 0 # 0 for no constraints on the poles + dico = 0 # 0 for continuous time + flag = 0 # 0 for no constraints on the poles n_id, A_id, B_id, C_id, D_id = synthesis.sb10yd( - dico, flag, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) - - sys_tf_id = signal.ss2tf(A_id,B_id,C_id,D_id) + + sys_tf_id = signal.ss2tf(A_id, B_id, C_id, D_id) num_id, den_id = sys_tf_id w_id, H_id = signal.freqs(num_id.squeeze(), den_id, worN=omega) - #print(np.max(abs(H)-abs(H_id)), np.max(abs(H_id)-abs(H))) - #print(np.max(abs(H_id)/abs(H))) - - # Compare given and identified frequency response up to some toleration. - # absolute(a-b) <= atol + rtol*abolute(b), element-wise true - # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true - np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=0.1) + np.testing.assert_allclose(abs(H_id), abs(H), rtol=0, atol=0.1) def test_sb10yd_disc_exec_case_n0(self): """A simple execution test. Case n=0. """ - sys_tf = signal.TransferFunction(1,1,dt=0.1) + sys_tf = signal.TransferFunction(1, 1, dt=0.1) num, den = sys_tf.num, sys_tf.den omega, H = signal.freqz(num.squeeze(), den) @@ -104,10 +98,10 @@ def test_sb10yd_disc_exec_case_n0(self): imag_H_resp = np.imag(H) n = 0 - dico = 1 # 0 for discrete time - flag = 0 # 0 for no constraints on the poles + dico = 1 # 0 for discrete time + flag = 0 # 0 for no constraints on the poles n_id, *_ = synthesis.sb10yd( - dico, flag, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) # Because flag = 0, we expect n == n_id @@ -120,9 +114,9 @@ def test_sb10yd_disc_exec(self): A = np.array([[0.0, 1.0], [-0.5, -0.1]]) B = np.array([[0.0], [1.0]]) C = np.array([[1.0, 0.0]]) - D = np.zeros((1,1)) + D = np.zeros((1, 1)) - sys_tf = signal.ss2tf(A,B,C,D) + sys_tf = signal.ss2tf(A, B, C, D) num, den = sys_tf dt = 0.1 @@ -135,10 +129,10 @@ def test_sb10yd_disc_exec(self): imag_H_resp = np.imag(H) n = 2 - dico = 1 # 0 for discrete time - flag = 0 # 0 for no constraints on the poles + dico = 1 # 0 for discrete time + flag = 0 # 0 for no constraints on the poles n_id, *_ = synthesis.sb10yd( - dico, flag, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) # Because flag = 0, we expect n == n_id @@ -151,9 +145,9 @@ def test_sb10yd_disc_allclose(self): A = np.array([[0.0, 1.0], [-0.5, -0.1]]) B = np.array([[0.0], [1.0]]) C = np.array([[1.0, 0.0]]) - D = np.zeros((1,1)) + D = np.zeros((1, 1)) - sys_tf = signal.ss2tf(A,B,C,D) + sys_tf = signal.ss2tf(A, B, C, D) num, den = sys_tf dt = 0.01 @@ -165,21 +159,15 @@ def test_sb10yd_disc_allclose(self): imag_H_resp = np.imag(H) n = 2 - dico = 1 # 0 for discrete time - flag = 0 # 0 for no constraints on the poles + dico = 1 # 0 for discrete time + flag = 0 # 0 for no constraints on the poles n_id, A_id, B_id, C_id, D_id = synthesis.sb10yd( - dico, flag, len(omega), + dico, flag, len(omega), real_H_resp, imag_H_resp, omega, n, tol=0) - - sys_id = signal.dlti(A_id,B_id,C_id,D_id, dt=dt) + + sys_id = signal.dlti(A_id, B_id, C_id, D_id, dt=dt) sys_tf_id = signal.TransferFunction(sys_id) num_id, den_id = sys_tf_id.num, sys_tf_id.den w_id, H_id = signal.freqz(num_id.squeeze(), den_id, worN=omega) - #print(np.max(abs(H)-abs(H_id)), np.max(abs(H_id)-abs(H))) - #print(np.max(abs(H_id)/abs(H))) - - # Compare given and identified frequency response up to some toleration. - # absolute(a-b) <= atol + rtol*abolute(b), element-wise true - # absolute(a-b) or absolute(b-a) <= atol, for rtol=0 element-wise true - np.testing.assert_allclose(abs(H_id),abs(H),rtol=0,atol=1.0) \ No newline at end of file + np.testing.assert_allclose(abs(H_id), abs(H), rtol=0, atol=1.0) From e0fe51697385aaaf74d8a69e8d47869934d7371f Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 23 Sep 2023 20:57:34 +0200 Subject: [PATCH 360/405] remove use_scm_version --- setup.py | 1 - 1 file changed, 1 deletion(-) diff --git a/setup.py b/setup.py index 230460fe..e832d146 100644 --- a/setup.py +++ b/setup.py @@ -62,6 +62,5 @@ def run(self): packages=['slycot', 'slycot.tests'], cmdclass={'sdist': sdist_checked}, cmake_languages=('C', 'Fortran'), - use_scm_version = True, include_package_data = False, ) From 0e43cb3675aa8b5e3b96edc90b1c273d4f997096 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sat, 23 Sep 2023 21:10:30 +0200 Subject: [PATCH 361/405] bump setuptools_scm to v8 --- pyproject.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pyproject.toml b/pyproject.toml index 94af52dd..0aff147f 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -1,7 +1,7 @@ [build-system] requires = [ "setuptools>=45", - "setuptools_scm>=7", + "setuptools_scm>=8", "wheel", "scikit-build>=0.15", "cmake>=3.14", From 9485d94aaae2221dd82ee0bd7c66e28d610e390f Mon Sep 17 00:00:00 2001 From: Alexander Bodenseher Date: Sun, 24 Sep 2023 16:06:32 +0200 Subject: [PATCH 362/405] Implement MB02ED (#214) --- slycot/__init__.py | 10 +-- slycot/math.py | 101 +++++++++++++++++++++++ slycot/src/math.pyf | 14 ++++ slycot/tests/test_mb.py | 173 +++++++++++++++++++++++++++++++++++++++- 4 files changed, 291 insertions(+), 7 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 9d8704a8..af0ed13a 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -35,7 +35,7 @@ ab08nd, ab08nz, ab09ad, ab09ax, ab09bd, ab09md, ab09nd, ab13bd, ab13dd, ab13ed, ab13fd, ab13md) - + # Benchmark routines (0/6 wrapped) # Adaptive control routines (0/0 wrapped) @@ -46,8 +46,8 @@ # Identification routines (0/15 wrapped) - # Mathematical routines (7/281 wrapped) - from .math import (mb03rd, mb03vd, mb03vy, mb03wd, + # Mathematical routines (8/281 wrapped) + from .math import (mb02ed, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd, mc01td) @@ -55,13 +55,13 @@ # Synthesis routines ((16+1)/131 wrapped), sb03md57 is not part of slicot from .synthesis import (sb01bd, - sb02md, sb02mt, sb02od, + sb02md, sb02mt, sb02od, sb03md, sb03md57, sb03od, sb04md, sb04qd, sb10ad, sb10dd, sb10fd, sb10hd, sb10yd, sg02ad, sg03ad, sg03bd) - + # Transformation routines (10/77 wrapped) from .transform import (tb01id, tb01pd, tb03ad, diff --git a/slycot/math.py b/slycot/math.py index ae9aab18..d7447047 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -23,6 +23,107 @@ import numpy as np +def mb02ed(typet: str, T: np.ndarray, B: np.ndarray, n: int, k: int, nrhs: int): + """ X, T = mb02ed(typet, T, B, n, k, nrhs) + + Solve a system of linear equations T*X = B or X*T = B with a positive + definite block Toeplitz matrix T. + + Parameters + ---------- + typet: str + Specifies the type of T: + - 'R': T contains the first block row of an s.p.d. block Toeplitz matrix, + and the system X*T = B is solved. + - 'C': T contains the first block column of an s.p.d. block Toeplitz matrix, + and the system T*X = B is solved. + Note: the notation x / y means that x corresponds to + typet = 'R' and y corresponds to typet = 'C'. + T : array_like + The leading k-by-n*k / n*k-by-k part of this array must contain the first + block row/column of an s.p.d. block Toeplitz matrix. + B : array_like + The leading nrhs-by-n*k / n*k-by-nrhs part of this array must contain the + right-hand side matrix B. + n : int + The number of blocks in T. n >= 0. + k : int + The number of rows/columns in T, equal to the blocksize. k >= 0. + nrhs : int + The number of right-hand sides. nrhs >= 0. + + Returns + ------- + X : ndarray + Leading nrhs-by-n*k / n*k-by-nrhs part of + this array contains the solution matrix X. + T: ndarray + If no error is thrown and nrhs > 0, then the leading + k-by-n*k / n*k-by-k part of this array contains the last + row / column of the Cholesky factor of inv(T). + + Raises + ------ + SlycotArithmeticError + :info = 1: + The reduction algorithm failed. The Toeplitz matrix associated + with T is not numerically positive definite. + SlycotParameterError + :info = -1: + typet must be either "R" or "C" + :info = -2: + k must be >= 0 + :info = -3: + n must be >= 0 + :info = -4: + nrhs must be >= 0 + + Notes + ----- + The algorithm uses Householder transformations, modified hyperbolic rotations, + and block Gaussian eliminations in the Schur algorithm [1], [2]. + + References + ---------- + [1] Kailath, T. and Sayed, A. + Fast Reliable Algorithms for Matrices with Structure. + SIAM Publications, Philadelphia, 1999. + + [2] Kressner, D. and Van Dooren, P. + Factorizations and linear system solvers for matrices with Toeplitz structure. + SLICOT Working Note 2000-2, 2000. + + Numerical Aspects + ----------------- + The implemented method is numerically equivalent to forming the Cholesky factor R and the + inverse Cholesky factor of T using the generalized Schur algorithm and solving the systems + of equations R*X = L*B or X*R = B*L by a blocked backward substitution algorithm. + The algorithm requires O(K * N^2 + K * N * NRHS) floating-point operations. + + """ + + hidden = " (hidden by the wrapper)" + arg_list = [ + "typet", + "k", + "n", + "nrhs", + "t", + "ldt" + hidden, + "b", + "ldb" + hidden, + "ldwork" + hidden, + "dwork" + hidden, + "info", + ] + + T, X, info = _wrapper.mb02ed(typet=typet, k=k, n=n, nrhs=nrhs, t=T, b=B) + + raise_if_slycot_error(info, arg_list, docstring=mb02ed.__doc__, checkvars=locals()) + + return X, T + + def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): """Ar, Xr, blsize, W = mb03rd(n, A, [X, jobx, sort, pmax, tol]) diff --git a/slycot/src/math.pyf b/slycot/src/math.pyf index 7dc53ff9..fe78cdde 100644 --- a/slycot/src/math.pyf +++ b/slycot/src/math.pyf @@ -12,6 +12,20 @@ subroutine mc01td(dico,dp,p,stable,nz,dwork,iwarn,info) ! in :new:MC01TD.f integer intent(out) :: info end subroutine mc01td +subroutine mb02ed(typet,k,n,nrhs,t,ldt,b,ldb,dwork,ldwork,info) ! in MB02ED.f + character :: typet + integer intent(in),required :: k + integer intent(in),required :: n + integer intent(in),required :: nrhs + double precision intent(in,out,copy),dimension(ldt,*) :: t + integer, intent(hide),optional,check(shape(t, 0) == ldt),depend(t) :: ldt=shape(t, 0) + double precision intent(in,out,copy),dimension(ldb,*) :: b + integer, intent(hide),optional,check(shape(b, 0) == ldb),depend(b) :: ldb=shape(b, 0) + double precision intent(cache,hide),dimension(ldwork) :: dwork + integer optional,check(ldwork>=n*k*k+(n+2)*k), depend(n,k) :: ldwork=max(1,n*k*k+(n+2)*k) + integer intent(out):: info +end subroutine mb02ed + subroutine mb03rd(jobx,sort,n,pmax,a,lda,x,ldx,nblcks,blsize,wr,wi,tol,dwork,info) ! in MB03RD.f character intent(in) :: jobx character intent(in),required :: sort diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index cdb84433..5dc5dcd5 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -9,12 +9,181 @@ from numpy.testing import assert_allclose from scipy.linalg import schur -from slycot import math, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd -from slycot.exceptions import SlycotArithmeticError, SlycotResultWarning +from slycot import math, mb02ed, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd +from slycot.exceptions import SlycotArithmeticError, SlycotResultWarning, SlycotParameterError from .test_exceptions import assert_docstring_parse +def test_mb02ed_ex(): + """Test MB02ED using the example given in the MB02ED SLICOT Documentation""" + n = 3 + k = 3 + nrhs = 2 + TYPET = "C" + T = np.array( + [ + [3.0000, 1.0000, 0.2000], + [1.0000, 4.0000, 0.4000], + [0.2000, 0.4000, 5.0000], + [0.1000, 0.1000, 0.2000], + [0.2000, 0.0400, 0.0300], + [0.0500, 0.2000, 0.1000], + [0.1000, 0.0300, 0.1000], + [0.0400, 0.0200, 0.2000], + [0.0100, 0.0300, 0.0200], + ] + ) + B = np.array( + [ + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + ] + ) + X = np.array( + [ + [0.2408, 0.4816], + [0.1558, 0.3116], + [0.1534, 0.3068], + [0.2302, 0.4603], + [0.1467, 0.2934], + [0.1537, 0.3075], + [0.2349, 0.4698], + [0.1498, 0.2995], + [0.1653, 0.3307], + ] + ) + + result,_ = mb02ed(T=T, B=B, n=n, k=k, typet=TYPET, nrhs=nrhs) + np.testing.assert_almost_equal(result, X, decimal=4) + +def test_mb02ed_parameter_errors(): + """Test for errors in the input parameters of MB02ED""" + n = 3 + k = 3 + nrhs = 2 + TYPET = "C" + T = np.array( + [ + [3.0000, 1.0000, 0.2000], + [1.0000, 4.0000, 0.4000], + [0.2000, 0.4000, 5.0000], + [0.1000, 0.1000, 0.2000], + [0.2000, 0.0400, 0.0300], + [0.0500, 0.2000, 0.1000], + [0.1000, 0.0300, 0.1000], + [0.0400, 0.0200, 0.2000], + [0.0100, 0.0300, 0.0200], + ] + ) + B = np.array( + [ + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + ] + ) + X = np.array( + [ + [0.2408, 0.4816], + [0.1558, 0.3116], + [0.1534, 0.3068], + [0.2302, 0.4603], + [0.1467, 0.2934], + [0.1537, 0.3075], + [0.2349, 0.4698], + [0.1498, 0.2995], + [0.1653, 0.3307], + ] + ) + + # Test for wrong parameter typet + with pytest.raises(expected_exception=SlycotParameterError, match='typet must be either "R" or "C"') as cm: + mb02ed(T=T, B=B, n=n, k=k, typet='U', nrhs=nrhs) + assert cm.value.info == -1 + #Test for negative number of columns + with pytest.raises(expected_exception=SlycotParameterError, match="k must be >= 0") as cm: + mb02ed(T=T, B=B, n=n, k=-1, typet=TYPET, nrhs=nrhs) + assert cm.value.info == -2 + #Test for negative number of blocks + with pytest.raises(expected_exception=SlycotParameterError, match="n must be >= 0") as cm: + mb02ed(T=T, B=B, n=-1, k=k, typet=TYPET, nrhs=nrhs) + assert cm.value.info == -3 + #Test for negative number of right hand sides + with pytest.raises(expected_exception=SlycotParameterError, match="nrhs must be >= 0") as cm: + mb02ed(T=T, B=B, n=n, k=k, typet=TYPET, nrhs=-1) + assert cm.value.info == -4 + + +def test_mb02ed_matrix_error(): + """Test for a negative definite input matrix in MB02ED""" + n = 3 + k = 3 + nrhs = 2 + TYPET = "C" + T = np.array( + [ + [3.0000, 1.0000, 0.2000], + [1.0000, 4.0000, 0.4000], + [0.2000, 0.4000, 5.0000], + [0.1000, 0.1000, 0.2000], + [0.2000, 0.0400, 0.0300], + [0.0500, 0.2000, 0.1000], + [0.1000, 0.0300, 0.1000], + [0.0400, 0.0200, 0.2000], + [0.0100, 0.0300, 0.0200], + ] + ) + # Create a negative definite matrix + T = -1 * T + B = np.array( + [ + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + [1.0000, 2.0000], + ] + ) + X = np.array( + [ + [0.2408, 0.4816], + [0.1558, 0.3116], + [0.1534, 0.3068], + [0.2302, 0.4603], + [0.1467, 0.2934], + [0.1537, 0.3075], + [0.2349, 0.4698], + [0.1498, 0.2995], + [0.1653, 0.3307], + ] + ) + + with pytest.raises(SlycotArithmeticError, + match = "The reduction algorithm failed. " + "The Toeplitz matrix associated\nwith T " + r"is not numerically positive definite.") as cm: + mb02ed(T=T, B=B, n=n, k=k, typet=TYPET, nrhs=nrhs) + assert cm.value.info == 1 + + def test_mb03rd(): """ Test for Schur form reduction. From cbbddc6b2dfd093c5e04db0536bb3921142a8fd4 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Fri, 20 Oct 2023 16:39:27 +0200 Subject: [PATCH 363/405] Use conda-build for build matrix and pin like conda-forge --- .github/conda-env/test-env.yml | 1 - .github/workflows/slycot-build-and-test.yml | 9 ++-- README.rst | 10 ++--- conda-recipe/bld.bat | 2 + conda-recipe/conda_build_config.yaml | 49 +++++++++++++++++++++ conda-recipe/meta.yaml | 21 +++------ 6 files changed, 65 insertions(+), 27 deletions(-) create mode 100644 conda-recipe/conda_build_config.yaml diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml index 7d69d330..8ab7abdd 100644 --- a/.github/conda-env/test-env.yml +++ b/.github/conda-env/test-env.yml @@ -1,7 +1,6 @@ name: test-env dependencies: # in addtion to package dependencies and explicit LAPACK/BLAS implementations installed in workflow - - conda-build # for conda index - scipy - matplotlib - pytest diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 050a6097..3f079c69 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -132,7 +132,7 @@ jobs: path: slycot-wheels build-conda: - name: Build conda Py${{ matrix.python }}, ${{ matrix.os }} + name: Build conda, ${{ matrix.os }} runs-on: ${{ matrix.os }}-latest needs: build-sdist strategy: @@ -143,7 +143,7 @@ jobs: - 'macos' - 'windows' python: - - '3.9' + # this is not the packaged version, just the version conda-build runs on. - '3.11' steps: @@ -167,14 +167,14 @@ jobs: shell: bash -l {0} run: | set -e - numpyversion=$(python -c 'import numpy; print(numpy.version.version)') - conda mambabuild --python "${{ matrix.python }}" --numpy $numpyversion conda-recipe + conda mambabuild conda-recipe # preserve directory structure for custom conda channel find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do conda_platform=$(basename $(dirname "${conda_pkg}")) mkdir -p "slycot-conda-pkgs/${conda_platform}" cp "${conda_pkg}" "slycot-conda-pkgs/${conda_platform}/" done + conda index --no-progress ./slycot-conda-pkgs - name: Save to local conda pkg channel uses: actions/upload-artifact@v3 with: @@ -357,7 +357,6 @@ jobs: echo "libblas * *mkl" >> $CONDA_PREFIX/conda-meta/pinned ;; esac - conda index --no-progress ./slycot-conda-pkgs mamba install -c ./slycot-conda-pkgs slycot conda list - name: Slycot and python-control tests diff --git a/README.rst b/README.rst index fe82d095..0551d685 100644 --- a/README.rst +++ b/README.rst @@ -19,18 +19,18 @@ Riccati, Lyapunov, and Sylvester equations. Dependencies ------------ -Slycot supports Python versions 3.8 or later. +Slycot supports Python versions 3.10 or later. To run the compiled Slycot package, the following must be installed as dependencies: -- Python 3.8+ +- Python 3.10+ - NumPy If you are compiling and installing Slycot from source, you will need the following dependencies: -- Python 3.8+ +- Python 3.10+ - NumPy - scikit-build - CMake @@ -189,8 +189,6 @@ A similar method can be used for Linux and macOS, but is detailed here for Windows. This method uses conda and conda-forge to get most build dependencies, *except* for the C compiler. -This procedure has been tested on Python 3.8. - 1. Install `Microsoft Visual Studio`_. 2. Unpack the source code to a directory of your choice, 3. Create a command shell setup that can run the conda commands and the Visual @@ -199,7 +197,7 @@ This procedure has been tested on Python 3.8. following commands to build and install Slycot (this example creates a Python 3.8 environment):: - conda create --channel conda-forge --name build-slycot python=3.8 numpy scipy libblas=*=*netlib liblapack=*=*netlib scikit-build flang pytest + conda create --channel conda-forge --name build-slycot python=3.10 numpy scipy libblas=*=*netlib liblapack=*=*netlib scikit-build flang pytest conda activate build-slycot pip install -v . diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 4b2811d0..9f4db0b3 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -1,3 +1,5 @@ +:: correct FC, apparently pointed to host prefix?? +set FC=%BUILD_PREFIX%\Library\bin\flang.exe set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% diff --git a/conda-recipe/conda_build_config.yaml b/conda-recipe/conda_build_config.yaml new file mode 100644 index 00000000..26423158 --- /dev/null +++ b/conda-recipe/conda_build_config.yaml @@ -0,0 +1,49 @@ +# https://github.com/conda-forge/blas-feedstock/issues/106#issuecomment-1771747983 +# https://github.com/conda-forge/conda-forge-pinning-feedstock/blob/main/recipe/conda_build_config.yaml + + +# zip_keys Python/Numpy matrix to build for +python: + - 3.10.* *_cpython + - 3.11.* *_cpython +# 3.12 is already building in conda-forge/slycot-feedstock, but they did not publish everything yet +# - 3.12.* *_cpython +numpy: + - 1.22 + - 1.23 +# - 1.23 + +zip_keys: + - + - python + - numpy + +# Compiler selection +c_compiler: + - gcc # [linux] + - clang # [osx] + - vs2019 # [win and x86_64] + - vs2022 # [win and arm64] +c_compiler_version: # [unix] + - 12 # [linux] + - 16 # [osx] +fortran_compiler: # [unix or win64] + - gfortran # [linux64 or (osx and x86_64)] + - gfortran # [aarch64 or ppc64le or armv7l or s390x] + - flang # [win64] +fortran_compiler_version: # [unix or win64] + - 12 # [linux] + - 12 # [osx] + - 5 # [win64] + +# Pinning + +# blas +libblas: + - 3.9 *netlib +libcblas: + - 3.9 *netlib +liblapack: + - 3.9 *netlib +liblapacke: + - 3.9 *netlib \ No newline at end of file diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index 601aafed..e01ad376 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -11,32 +11,23 @@ build: requirements: build: - - {{ compiler('fortran') }} # [not win] + - {{ compiler('fortran') }} - {{ compiler('c') }} - cmake >=3.14 - make # [linux] - - flang >=11 # [win] - host: - # Always build against NETLIB ('Generic') LAPACK/Blas - # https://conda-forge.org/docs/maintainer/knowledge_base.html#blas - # deviating from above link: we have to specifiy netlib variant, because - # the mkl variant selected by default for older pythons on windows - # does not provide the generic headers - - libblas * *netlib - - libcblas * *netlib - - liblapack * *netlib + - libblas + - libcblas + - liblapack - python - - numpy >=1.19,!=1.23.0 - - pip + - numpy - scikit-build >=0.15 + - pip - setuptools >=45 - setuptools_scm >=7 - run: - python {{ PY_VER }} - {{ pin_compatible('numpy') }} - - libflang # [win] test: requires: From 3969264bd3f18fb2405eb89915bce1d2107ecd9b Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sun, 3 Sep 2023 12:24:47 +0200 Subject: [PATCH 364/405] Add ag08bd to __init__ file --- slycot/__init__.py | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index af0ed13a..120bdedb 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -27,15 +27,16 @@ # U : Utility Routines - # Analysis routines (17/60 wrapped) + # Analysis routines (18/60 wrapped) from .analysis import (ab01nd, ab04md, ab05md, ab05nd, ab07nd, ab08nd, ab08nz, ab09ad, ab09ax, ab09bd, ab09md, ab09nd, - ab13bd, ab13dd, ab13ed, ab13fd, ab13md) - + ab13bd, ab13dd, ab13ed, ab13fd, ab13md, + ag08bd) + # Benchmark routines (0/6 wrapped) # Adaptive control routines (0/0 wrapped) From 1c33c790ec2d543e97152b7cbe4fc7315581d71e Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Wed, 23 Aug 2023 20:05:10 +0200 Subject: [PATCH 365/405] Change analysis.py docstrings to numpydoc style --- slycot/analysis.py | 1997 ++++++++++++++++++++++---------------------- 1 file changed, 1010 insertions(+), 987 deletions(-) diff --git a/slycot/analysis.py b/slycot/analysis.py index c9c2bf5a..230eedb9 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -67,15 +67,14 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): the order of the matrix A. ``n > 0``. m : int The number of system inputs, or of columns of B. ``m > 0``. - A : (n,n) array_like + A : (n, n) array_like The original state dynamics matrix A. - B : (n,m) array_like + B : (n, m) array_like The input matrix B. jobz : {'N', 'F', 'I'}, optional Indicates whether the user wishes to accumulate in a matrix Z the orthogonal similarity transformations for reducing the system, as follows: - := 'N': Do not form Z and do not store the orthogonal transformations; (default) := 'F': Do not form Z, but store the orthogonal transformations in @@ -92,12 +91,12 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): Returns ------- - Ac : (n,n) ndarray + Ac : (n, n) ndarray The leading ncont-by-ncont part contains the upper block Hessenberg state dynamics matrix Acont in Ac, given by Z'*A*Z, of a controllable realization for the original system. The elements below the first block-subdiagonal are set to zero. - Bc : (n,m) ndarray + Bc : (n, m) ndarray The leading ncont-by-m part of this array contains the transformed input matrix Bcont in Bc, given by ``Z'*B``, with all elements but the first block set to zero. @@ -106,10 +105,10 @@ def ab01nd(n, m, A, B, jobz='N', tol=0, ldwork=None): indcon : int The controllability index of the controllable part of the system representation. - nblk : (n,) int ndarray + nblk : (n, ) int ndarray The leading indcon elements of this array contain the the orders of the diagonal blocks of Acont. - Z : (n,n) ndarray + Z : (n, n) ndarray - If jobz = 'I', then the leading N-by-N part of this array contains the matrix of accumulated orthogonal similarity transformations which reduces the given system to orthogonal canonical form. @@ -159,23 +158,23 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): p : int The number of rows of matrix C. It represents the dimension of the output vector. p > 0. - A : (n,n) array_like + A : (n, n) array_like The leading n-by-n part of this array must contain the system state matrix A. - B : (n,m) array_like + B : (n, m) array_like The leading n-by-m part of this array must contain the system input matrix B. - C : (p,n) array_like + C : (p, n) array_like The leading p-by-n part of this array must contain the system output matrix C. - D : (p,m) array_like + D : (p, m) array_like The leading p-by-m part of this array must contain the system direct transmission matrix D. - alpha : double, optional + alpha : float, optional Parameter specifying the bilinear transformation. Recommended values for stable systems: alpha = 1, alpha != 0, Default is 1.0. - beta : double, optional + beta : float, optional Parameter specifying the bilinear transformation. Recommended values for stable systems: beta = 1, beta != 0, Default is 1.0. @@ -184,13 +183,13 @@ def ab04md(type_t, n, m, p, A, B, C, D, alpha=1.0, beta=1.0, ldwork=None): ldwork >= max(1, n), default is max(1, n) Returns ------- - At : (n,n) ndarray + At : (n, n) ndarray The state matrix At of the transformed system. - Bt : (n,m) ndarray + Bt : (n, m) ndarray The input matrix Bt of the transformed system. - Ct : (p,n) ndarray + Ct : (p, n) ndarray The output matrix Ct of the transformed system. - Dt : (p,m) ndarray + Dt : (p, m) ndarray The transmission matrix Dt of the transformed system. Raises ------ @@ -221,72 +220,76 @@ def ab05md(n1,m1,p1,n2,p2,A1,B1,C1,D1,A2,B2,C2,D2,uplo='U'): To obtain the state-space model (A,B,C,D) for the cascaded inter-connection of two systems, each given in state-space form. - Required arguments: - n1 : input int - The number of state variables in the first system, i.e. the order - of the matrix A1. n1 > 0. - m1 : input int - The number of input variables for the first system. m1 > 0. - p1 : input int - The number of output variables from the first system and the number - of input variables for the second system. p1 > 0. - n2 : input int - The number of state variables in the second system, i.e. the order - of the matrix A2. n2 > 0. - p2 : input int - The number of output variables from the second system. p2 > 0. - A1 : input rank-2 array('d') with bounds (n1,n1) - The leading n1-by-n1 part of this array must contain the state - transition matrix A1 for the first system. - B1 : input rank-2 array('d') with bounds (n1,m1) - The leading n1-by-m1 part of this array must contain the input/state - matrix B1 for the first system. - C1 : input rank-2 array('d') with bounds (p1,n1) - The leading p1-by-n1 part of this array must contain the state/output - matrix C1 for the first system. - D1 : input rank-2 array('d') with bounds (p1,m1) - The leading p1-by-m1 part of this array must contain the input/output - matrix D1 for the first system. - A2 : input rank-2 array('d') with bounds (n2,n2) - The leading n2-by-n2 part of this array must contain the state - transition matrix A2 for the second system. - B2 : input rank-2 array('d') with bounds (n2,p1) - The leading n2-by-p1 part of this array must contain the input/state - matrix B2 for the second system. - C2 : input rank-2 array('d') with bounds (p2,n2) - The leading p2-by-n2 part of this array must contain the state/output - matrix C2 for the second system. - D2 : input rank-2 array('d') with bounds (p2,p1) - The leading p2-by-p1 part of this array must contain the input/output - matrix D2 for the second system. - Optional arguments: - uplo := 'U' input string(len=1) - Indicates whether the user wishes to obtain the matrix A in - the upper or lower block diagonal form, as follows: - = 'U': Obtain A in the upper block diagonal form; - = 'L': Obtain A in the lower block diagonal form. - Return objects: - n : int - The number of state variables (n1 + n2) in the resulting system, - i.e. the order of the matrix A, the number of rows of B and - the number of columns of C. - A : rank-2 array('d') with bounds (n1+n2,n1+n2) - The leading N-by-N part of this array contains the state transition - matrix A for the cascaded system. - B : rank-2 array('d') with bounds (n1+n2,m1) - The leading n-by-m1 part of this array contains the input/state - matrix B for the cascaded system. - C : rank-2 array('d') with bounds (p2,n1+n2) - The leading p2-by-n part of this array contains the state/output - matrix C for the cascaded system. - D : rank-2 array('d') with bounds (p2,m1) - The leading p2-by-m1 part of this array contains the input/output - matrix D for the cascaded system. - - Notes: - The implemented methods rely on accuracy enhancing square-root or - balancing-free square-root techniques. - The algorithms require less than 30N^3 floating point operations. + Parameters + ---------- + n1 : int + The number of state variables in the first system, i.e. the order + of the matrix A1. n1 > 0. + m1 : int + The number of input variables for the first system. m1 > 0. + p1 : int + The number of output variables from the first system and the number + of input variables for the second system. p1 > 0. + n2 : int + The number of state variables in the second system, i.e. the order + of the matrix A2. n2 > 0. + p2 : int + The number of output variables from the second system. p2 > 0. + A1 : (n1, n1) array_like + The leading n1-by-n1 part of this array must contain the state + transition matrix A1 for the first system. + B1 : (n1, m1) array_like + The leading n1-by-m1 part of this array must contain the input/state + matrix B1 for the first system. + C1 : (p1, n1) array_like + The leading p1-by-n1 part of this array must contain the state/output + matrix C1 for the first system. + D1 : (p1, m1) array_like + The leading p1-by-m1 part of this array must contain the input/output + matrix D1 for the first system. + A2 : (n2, n2) array_like + The leading n2-by-n2 part of this array must contain the state + transition matrix A2 for the second system. + B2 : (n2, p1) array_like + The leading n2-by-p1 part of this array must contain the input/state + matrix B2 for the second system. + C2 : (p2, n2) array_like + The leading p2-by-n2 part of this array must contain the state/output + matrix C2 for the second system. + D2 : (p2, p1) array_like + The leading p2-by-p1 part of this array must contain the input/output + matrix D2 for the second system. + uplo : {'U', 'L'}, optional + Indicates whether the user wishes to obtain the matrix A in + the upper or lower block diagonal form, as follows: + = 'U': Obtain A in the upper block diagonal form; + = 'L': Obtain A in the lower block diagonal form. + Default is `U`. + + Returns + ------- + n : int + The number of state variables (n1 + n2) in the resulting system, + i.e. the order of the matrix A, the number of rows of B and + the number of columns of C. + A : (n1+n2, n1+n2) ndarray + The leading N-by-N part of this array contains the state transition + matrix A for the cascaded system. + B : (n1+n2, m1) ndarray + The leading n-by-m1 part of this array contains the input/state + matrix B for the cascaded system. + C : (p2, n1+n2) ndarray + The leading p2-by-n part of this array contains the state/output + matrix C for the cascaded system. + D : (p2, m1) ndarray + The leading p2-by-m1 part of this array contains the input/output + matrix D for the cascaded system. + + Notes + ----- + The implemented methods rely on accuracy enhancing square-root or + balancing-free square-root techniques. + The algorithms require less than 30N^3 floating point operations. """ hidden = ' (hidden by the wrapper)' arg_list = ['uplo', 'OVER'+hidden, 'n1', 'm1', 'p1', 'n2', 'p2', 'A1', @@ -305,68 +308,72 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): To obtain the state-space model (A,B,C,D) for the feedback inter-connection of two systems, each given in state-space form. - Required arguments: - n1 : input int - The number of state variables in the first system, i.e. the order - of the matrix A1. n1 > 0. - m1 : input int - The number of input variables for the first system and the number - of output variables from the second system. m1 > 0. - p1 : input int - The number of output variables from the first system and the number - of input variables for the second system. p1 > 0. - n2 : input int - The number of state variables in the second system, i.e. the order - of the matrix A2. n2 > 0. - A1 : input rank-2 array('d') with bounds (n1,n1) - The leading n1-by-n1 part of this array must contain the state - transition matrix A1 for the first system. - B1 : input rank-2 array('d') with bounds (n1,m1) - The leading n1-by-m1 part of this array must contain the input/state - matrix B1 for the first system. - C1 : input rank-2 array('d') with bounds (p1,n1) - The leading p1-by-n1 part of this array must contain the state/output - matrix C1 for the first system. - D1 : input rank-2 array('d') with bounds (p1,m1) - The leading p1-by-m1 part of this array must contain the input/output - matrix D1 for the first system. - A2 : input rank-2 array('d') with bounds (n2,n2) - The leading n2-by-n2 part of this array must contain the state - transition matrix A2 for the second system. - B2 : input rank-2 array('d') with bounds (n2,p1) - The leading n2-by-p1 part of this array must contain the input/state - matrix B2 for the second system. - C2 : input rank-2 array('d') with bounds (m1,n2) - The leading m1-by-n2 part of this array must contain the state/output - matrix C2 for the second system. - D2 : input rank-2 array('d') with bounds (m1,p1) - The leading m1-by-p1 part of this array must contain the input/output - matrix D2 for the second system. - Optional arguments: - alpha := 1.0 input float - A coefficient multiplying the transfer-function matrix (or the - output equation) of the second system. i.e alpha = +1 corresponds - to positive feedback, and alpha = -1 corresponds to negative - feedback. - ldwork := max(p1*p1,m1*m1,n1*p1) input int - The length of the cache array. ldwork >= max(p1*p1,m1*m1,n1*p1). - Return objects: - n : int - The number of state variables (n1 + n2) in the connected system, i.e. - the order of the matrix A, the number of rows of B and the number of - columns of C. - A : rank-2 array('d') with bounds (n1+n2,n1+n2) - The leading n-by-n part of this array contains the state transition - matrix A for the connected system. - B : rank-2 array('d') with bounds (n1+n2,m1) - The leading n-by-m1 part of this array contains the input/state - matrix B for the connected system. - C : rank-3 array('d') with bounds (p1,n1,n2) - The leading p1-by-n part of this array contains the state/output - matrix C for the connected system. - D : rank-2 array('d') with bounds (p1,m1) - The leading p1-by-m1 part of this array contains the input/output - matrix D for the connected system. + Parameters + ---------- + n1 : int + The number of state variables in the first system, i.e. the order + of the matrix A1. n1 > 0. + m1 : int + The number of input variables for the first system and the number + of output variables from the second system. m1 > 0. + p1 : int + The number of output variables from the first system and the number + of input variables for the second system. p1 > 0. + n2 : int + The number of state variables in the second system, i.e. the order + of the matrix A2. n2 > 0. + A1 : (n1, n1) array_like + The leading n1-by-n1 part of this array must contain the state + transition matrix A1 for the first system. + B1 : (n1, m1) array_like + The leading n1-by-m1 part of this array must contain the input/state + matrix B1 for the first system. + C1 : (p1, n1) array_like + The leading p1-by-n1 part of this array must contain the state/output + matrix C1 for the first system. + D1 : (p1, m1) array_like + The leading p1-by-m1 part of this array must contain the input/output + matrix D1 for the first system. + A2 : (n2, n2) array_like + The leading n2-by-n2 part of this array must contain the state + transition matrix A2 for the second system. + B2 : (n2, p1) array_like + The leading n2-by-p1 part of this array must contain the input/state + matrix B2 for the second system. + C2 : (m1, n2) array_like + The leading m1-by-n2 part of this array must contain the state/output + matrix C2 for the second system. + D2 : (m1, p1) array_like + The leading m1-by-p1 part of this array must contain the input/output + matrix D2 for the second system. + alpha : float, optional + A coefficient multiplying the transfer-function matrix (or the + output equation) of the second system. i.e alpha = +1 corresponds + to positive feedback, and alpha = -1 corresponds to negative + feedback. + Default is `1.0`. + ldwork : int, optional + The length of the cache array. ldwork >= max(p1*p1,m1*m1,n1*p1). + Default is max(p1*p1,m1*m1,n1*p1). + + Returns + ------- + n : int + The number of state variables (n1 + n2) in the connected system, i.e. + the order of the matrix A, the number of rows of B and the number of + columns of C. + A : (n1+n2, n1+n2) ndarray + The leading n-by-n part of this array contains the state transition + matrix A for the connected system. + B : (n1+n2, m1) ndarray + The leading n-by-m1 part of this array contains the input/state + matrix B for the connected system. + C : (p1, n1, n2) ndarray + The leading p1-by-n part of this array contains the state/output + matrix C for the connected system. + D : (p1, m1) ndarray + The leading p1-by-m1 part of this array contains the input/output + matrix D for the connected system. Raises ------ @@ -392,47 +399,49 @@ def ab05nd(n1,m1,p1,n2,A1,B1,C1,D1,A2,B2,C2,D2,alpha=1.0,ldwork=None): return out[:-1] def ab07nd(n,m,A,B,C,D,ldwork=None): - """ A_i,B_i,C_i,D_i,rcond = ab07nd(n,m,A,B,C,D,[ldwork]) - - To compute the inverse (A_i,B_i,C_i,D_i) of a given system (A,B,C,D). - - Required arguments: - n : input int - The order of the state matrix A. n >= 0. - m : input int - The number of system inputs and outputs. m >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state matrix - A of the original system. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input matrix - B of the original system. - C : input rank-2 array('d') with bounds (m,n) - The leading m-by-n part of this array must contain the output matrix - C of the original system. - D : input rank-2 array('d') with bounds (m,m) - The leading m-by-m part of this array must contain the feedthrough - matrix D of the original system. - Optional arguments: - ldwork := None input int - The length of the cache array. The default value is max(1,4*m), - for better performance should be larger. - Return objects: - A_i : rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array contains the state matrix A_i - of the inverse system. - B_i : rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array contains the input matrix B_i - of the inverse system. - C_i : rank-2 array('d') with bounds (m,n) - The leading m-by-n part of this array contains the output matrix C_i - of the inverse system. - D_i : rank-2 array('d') with bounds (m,m) - The leading m-by-m part of this array contains the feedthrough - matrix D_i of the inverse system. - rcond : float - The estimated reciprocal condition number of the feedthrough matrix - D of the original system. + """ Ai,Bi,Ci,Di,rcond = ab07nd(n,m,A,B,C,D,[ldwork]) + + To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D). + + Parameters + ---------- + n : int + The order of the state matrix A. n >= 0. + m : int + The number of system inputs and outputs. m >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the state matrix + A of the original system. + B : (n, m) array_like + The leading n-by-m part of this array must contain the input matrix + B of the original system. + C : (m, n) array_like + The leading m-by-n part of this array must contain the output matrix + C of the original system. + D : (m, m) array_like + The leading m-by-m part of this array must contain the feedthrough + matrix D of the original system. + ldwork : int, optional + The length of the cache array. The default value is max(1,4*m), + for better performance should be larger. + + Returns + ------- + Ai : (n, n) ndarray + The leading n-by-n part of this array contains the state matrix Ai + of the inverse system. + Bi : (n, m) ndarray + The leading n-by-m part of this array contains the input matrix Bi + of the inverse system. + Ci : (m, n) ndarray + The leading m-by-n part of this array contains the output matrix Ci + of the inverse system. + Di : (m, m) ndarray + The leading m-by-m part of this array contains the feedthrough + matrix Di of the inverse system. + rcond : float + The estimated reciprocal condition number of the feedthrough matrix + D of the original system. Warns ----- @@ -467,68 +476,73 @@ def ab08nd(n,m,p,A,B,C,D,equil='N',tol=0,ldwork=None): The routine also computes the orders of the infinite zeros and the right and left Kronecker indices of the system (A,B,C,D). - Required arguments: - n : input int - The number of state variables. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state - dynamics matrix A of the system. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input/state - matrix B of the system. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the state/output - matrix C of the system. - D : input rank-2 array('d') with bounds (p,m) - The leading p-by-m part of this array must contain the direct - transmission matrix D of the system. - Optional arguments: - equil := 'N' input string(len=1) - Specifies whether the user wishes to balance the compound matrix - as follows: - = 'S': Perform balancing (scaling); - = 'N': Do not perform balancing. - tol := 0.0 input float - A tolerance used in rank decisions to determine the effective rank, - which is defined as the order of the largest leading (or trailing) - triangular submatrix in the QR (or RQ) factorization with column - (or row) pivoting whose estimated condition number is less than 1/tol. - ldwork := None input int - The length of the cache array. The default value is n + 3*max(m,p), - for better performance should be larger. - Return objects: - nu : int - The number of (finite) invariant zeros. - rank : int - The normal rank of the transfer function matrix. - dinfz : int - The maximum degree of infinite elementary divisors. - nkror : int - The number of right Kronecker indices. - nkrol : int - The number of left Kronecker indices. - infz : rank-1 array('i') with bounds (n) - The leading dinfz elements of infz contain information on the - infinite elementary divisors as follows: the system has infz(i) - infinite elementary divisors of degree i, where i = 1,2,...,dinfz. - kronr : rank-1 array('i') with bounds (max(n,m)+1) - the leading nkror elements of this array contain the right kronecker - (column) indices. - kronl : rank-1 array('i') with bounds (max(n,p)+1) - the leading nkrol elements of this array contain the left kronecker - (row) indices. - Af : rank-2 array('d') with bounds (max(1,n+m),n+min(p,m)) - the leading nu-by-nu part of this array contains the coefficient - matrix Af of the reduced pencil. the remainder of the leading - (n+m)-by-(n+min(p,m)) part is used as internal workspace. - Bf : rank-2 array('d') with bounds (max(1,n+p),n+m) - The leading nu-by-nu part of this array contains the coefficient - matrix Bf of the reduced pencil. the remainder of the leading - (n+p)-by-(n+m) part is used as internal workspace. + Parameters + ---------- + n : int + The number of state variables. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system. + B : (n, m) array_like + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : (p, n) array_like + The leading p-by-n part of this array must contain the state/output + matrix C of the system. + D : (p, m) array_like + The leading p-by-m part of this array must contain the direct + transmission matrix D of the system. + equil : {'S', 'N'}, optional + Specifies whether the user wishes to balance the compound matrix + as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + Default is `N`. + tol : float, optional + A tolerance used in rank decisions to determine the effective rank, + which is defined as the order of the largest leading (or trailing) + triangular submatrix in the QR (or RQ) factorization with column + (or row) pivoting whose estimated condition number is less than 1/tol. + Default is `0.0`. + ldwork : int, optional + The length of the cache array. The default value is n + 3*max(m,p), + for better performance should be larger. + Default is None. + + Returns + ------- + nu : int + The number of (finite) invariant zeros. + rank : int + The normal rank of the transfer function matrix. + dinfz : int + The maximum degree of infinite elementary divisors. + nkror : int + The number of right Kronecker indices. + nkrol : int + The number of left Kronecker indices. + infz : (n, ) ndarray + The leading dinfz elements of infz contain information on the + infinite elementary divisors as follows: the system has infz(i) + infinite elementary divisors of degree i, where i = 1,2,...,dinfz. + kronr :(max(n,m)+1, ) ndarray + the leading nkror elements of this array contain the right kronecker + (column) indices. + kronl : (max(n,p)+1, ) ndarray + the leading nkrol elements of this array contain the left kronecker + (row) indices. + Af : (max(1,n+m), n+min(p,m)) ndarray + the leading nu-by-nu part of this array contains the coefficient + matrix Af of the reduced pencil. the remainder of the leading + (n+m)-by-(n+min(p,m)) part is used as internal workspace. + Bf : (max(1,n+p), n+m) ndarray + The leading nu-by-nu part of this array contains the coefficient + matrix Bf of the reduced pencil. the remainder of the leading + (n+p)-by-(n+m) part is used as internal workspace. """ hidden = ' (hidden by the wrapper)' arg_list = ['equil', 'n', 'm', 'p', 'A', 'LDA'+hidden, 'B', 'LDB'+hidden, @@ -551,82 +565,87 @@ def ab08nz(n, m, p, A, B, C, D, equil='N', tol=0., lzwork=None): The routine also computes the orders of the infinite zeros and the right and left Kronecker indices of the system (A,B,C,D). - Required arguments: - n : input int - The number of state variables. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state - dynamics matrix A of the system. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input/state - matrix B of the system. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the state/output - matrix C of the system. - D : input rank-2 array('d') with bounds (p,m) - The leading p-by-m part of this array must contain the direct - transmission matrix D of the system. - Optional arguments: - equil := 'N' input string(len=1) - Specifies whether the user wishes to balance the compound matrix - as follows: - = 'S': Perform balancing (scaling); - = 'N': Do not perform balancing. - tol := 0.0 input float - A tolerance used in rank decisions to determine the effective rank, - which is defined as the order of the largest leading (or trailing) - triangular submatrix in the QR (or RQ) factorization with column - (or row) pivoting whose estimated condition number is less than 1/tol. - If tol is set to less than SQRT((N+P)*(N+M))*EPS - then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, - where EPS is the machine precision (see LAPACK Library - Routine DLAMCH). - lzwork := None input int - The length of the internal cache array ZWORK. The default value is - calculated to - MAX( 1, - MIN(P,M) + MAX(3*M-1,N), - MIN(P,N) + MAX(3*P-1,N+P,N+M), - MIN(M,N) + MAX(3*M-1,N+M) ) - For optimum performance lzwork should be larger. - If lzwork = -1, then a workspace query is assumed; - the routine only calculates the optimal size of the - ZWORK array, and returns this value in lzwork_opt - Return objects: - nu : int - The number of (finite) invariant zeros. - rank : int - The normal rank of the transfer function matrix. - dinfz : int - The maximum degree of infinite elementary divisors. - nkror : int - The number of right Kronecker indices. - nkrol : int - The number of left Kronecker indices. - infz : rank-1 array('i') with bounds (n) - The leading dinfz elements of infz contain information on the - infinite elementary divisors as follows: the system has infz(i) - infinite elementary divisors of degree i, where i = 1,2,...,dinfz. - kronr : rank-1 array('i') with bounds (max(n,m)+1) - the leading nkror elements of this array contain the right kronecker - (column) indices. - kronl : rank-1 array('i') with bounds (max(n,p)+1) - the leading nkrol elements of this array contain the left kronecker - (row) indices. - Af : rank-2 array('d') with bounds (max(1,n+m),n+min(p,m)) - the leading nu-by-nu part of this array contains the coefficient - matrix Af of the reduced pencil. the remainder of the leading - (n+m)-by-(n+min(p,m)) part is used as internal workspace. - Bf : rank-2 array('d') with bounds (max(1,n+p),n+m) - The leading nu-by-nu part of this array contains the coefficient - matrix Bf of the reduced pencil. the remainder of the leading - (n+p)-by-(n+m) part is used as internal workspace. - lzwork_opt : int - The optimal value of lzwork. + Parameters + ---------- + n : int + The number of state variables. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system. + B : (n, m) array_like + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : (p, n) array_like + The leading p-by-n part of this array must contain the state/output + matrix C of the system. + D : (p, m) array_like + The leading p-by-m part of this array must contain the direct + transmission matrix D of the system. + equil : {'S', 'N'}, optional + Specifies whether the user wishes to balance the compound matrix + as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + Default is `N`. + tol : float, optional + A tolerance used in rank decisions to determine the effective rank, + which is defined as the order of the largest leading (or trailing) + triangular submatrix in the QR (or RQ) factorization with column + (or row) pivoting whose estimated condition number is less than 1/tol. + If tol is set to less than SQRT((N+P)*(N+M))*EPS + then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, + where EPS is the machine precision (see LAPACK Library + Routine DLAMCH). + Default is 0.0. + lzwork : int, optional + The length of the internal cache array ZWORK. The default value is + calculated to + MAX( 1, + MIN(P,M) + MAX(3*M-1,N), + MIN(P,N) + MAX(3*P-1,N+P,N+M), + MIN(M,N) + MAX(3*M-1,N+M) ) + For optimum performance lzwork should be larger. + If lzwork = -1, then a workspace query is assumed; + the routine only calculates the optimal size of the + ZWORK array, and returns this value in lzwork_opt + Default is None. + + Returns + ------- + nu : int + The number of (finite) invariant zeros. + rank : int + The normal rank of the transfer function matrix. + dinfz : int + The maximum degree of infinite elementary divisors. + nkror : int + The number of right Kronecker indices. + nkrol : int + The number of left Kronecker indices. + infz : (n, ) ndarray + The leading dinfz elements of infz contain information on the + infinite elementary divisors as follows: the system has infz(i) + infinite elementary divisors of degree i, where i = 1,2,...,dinfz. + kronr : (max(n,m)+1, ) ndarray + the leading nkror elements of this array contain the right kronecker + (column) indices. + kronl : (max(n,p)+1, ) ndarray + the leading nkrol elements of this array contain the left kronecker + (row) indices. + Af : (max(1,n+m), n+min(p,m)) ndarray + the leading nu-by-nu part of this array contains the coefficient + matrix Af of the reduced pencil. the remainder of the leading + (n+m)-by-(n+min(p,m)) part is used as internal workspace. + Bf : (max(1,n+p), n+m) ndarray + The leading nu-by-nu part of this array contains the coefficient + matrix Bf of the reduced pencil. the remainder of the leading + (n+p)-by-(n+m) part is used as internal workspace. + lzwork_opt : int + The optimal value of lzwork. """ hidden = ' (hidden by the wrapper)' arg_list = ['equil', 'n', 'm', 'p', @@ -657,77 +676,79 @@ def ab09ad(dico,job,equil,n,m,p,A,B,C,nr=None,tol=0,ldwork=None): (A, B, C) by using either the square-root or the balancing-free square- root Balance & truncate (B & T) model reduction method. - Required arguments: - dico : {'D', 'C'} input string(len=1) - Indicate whether the system is discrete `D` or continuous `C` - job : {'B', 'N'} input string(len=1) - Balance `B` or not `N` - equil : {'S', 'N'} input string(len=1) - Scale `S` or not `N` - n : input int - The number of state variables. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state - dynamics matrix A of the system. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input/state - matrix B of the system. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the - state/output matrix C of the system. - - Optional arguments: - nr := None input int - `nr` is the desired order of the resulting reduced order - system. ``0 <= nr <= n``. Automatically determined by `tol` if - ``nr is None`` and returned. See return object `nr`. - tol := 0 input double precision - If ``nr is None``, `tol`contains the tolerance for determining the - order of the reduced system. For model reduction, th recommended - value is ``tol = c * HNORM(A, B, C)``, where `c` is a constan in the - interval ``[0.00001, 0.001]`` and ``HNORM(A, B, C)`` is the - Hankel-Norm of the given sysstem (computed in ``HSV(1)``). For - computing a minimal realization, the recommended value is - ``tol = n * eps * HNORM(A, B, C)``, where `eps` is the machine - precision (see LAPACK Library Routine `DLAMCH`). This value is - used by default if ``tol <= 0`` on entry. If `nr` is specified, - the value of `tol` is ignored. - ldwork := None input int - The length of the cache array. The default value is - ``n*(2*n+max(n,m,p)+5) + n*(n+1)/2 ~= 3.5*n**2 + 5*n``, - a larger value should lead to better performance. - - Return objects : - nr : output int - `nr` is the order of the resulting reduced order model. - `nr` is set as follows: - If on input ``nr is not None``, `nr` is equal to ``MIN(nr,NMIN)``, - where `nr` is the desired order on entry and `NMIN` is the order - of a minimal realization of the given system; `NMIN` is - determined as the number of Hankel singular values greater - than ``n*eps*HNORM(A,B,C)``, where `eps` is the machine - precision (see LAPACK Library Routine DLAMCH) and - ``HNORM(A,B,C)`` is the Hankel norm of the system (computed - in ``HSV(1)``); - If on input ``nr is None``, `nr` is equal to the number of Hankel - singular values greater than ``MAX(tol,n*eps*HNORM(A,B,C))``. - Ar : rank-2 array('d') with bounds ``(nr,nr)`` - This array contains the state dynamics matrix `Ar` of the reduced - order system. - Br : rank-2 array('d') with bounds ``(nr,m)`` - Tthis array contains the input/state matrix `Br` of the reduced - order system. - Cr : rank-2 array('d') with bounds ``(p,nr)`` - This array contains the state/output matrix `Cr` of the reduced - order system. - hsv : output double precision array, dimension ``(n)`` - If ``INFO = 0``, it contains the Hankel singular values of - the original system ordered decreasingly. ``HSV(1)`` is the - Hankel norm of the system. + Parameters + ---------- + dico : {'D', 'C'} + Indicate whether the system is discrete `D` or continuous `C` + job : {'B', 'N'} + Balance `B` or not `N` + equil : {'S', 'N'} + Scale `S` or not `N` + n : int + The number of state variables. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system. + B : (n, m) array_like + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : (p, n) array_like + The leading p-by-n part of this array must contain the + state/output matrix C of the system. + nr : int, optional + `nr` is the desired order of the resulting reduced order + system. ``0 <= nr <= n``. Automatically determined by `tol` if + ``nr is None`` and returned. See return object `nr`. + Default is None. + tol : float, optional + If ``nr is None``, `tol`contains the tolerance for determining the + order of the reduced system. For model reduction, th recommended + value is ``tol = c * HNORM(A, B, C)``, where `c` is a constan in the + interval ``[0.00001, 0.001]`` and ``HNORM(A, B, C)`` is the + Hankel-Norm of the given sysstem (computed in ``HSV(1)``). For + computing a minimal realization, the recommended value is + ``tol = n * eps * HNORM(A, B, C)``, where `eps` is the machine + precision (see LAPACK Library Routine `DLAMCH`). This value is + used by default if ``tol <= 0`` on entry. If `nr` is specified, + the value of `tol` is ignored. Default is `0.0`. + ldwork : int, optional + The length of the cache array. The default value is + ``n*(2*n+max(n,m,p)+5) + n*(n+1)/2 ~= 3.5*n**2 + 5*n``, + a larger value should lead to better performance. + Default is None. + + Returns + ------- + nr : int + `nr` is the order of the resulting reduced order model. + `nr` is set as follows: + If on input ``nr is not None``, `nr` is equal to ``MIN(nr,NMIN)``, + where `nr` is the desired order on entry and `NMIN` is the order + of a minimal realization of the given system; `NMIN` is + determined as the number of Hankel singular values greater + than ``n*eps*HNORM(A,B,C)``, where `eps` is the machine + precision (see LAPACK Library Routine DLAMCH) and + ``HNORM(A,B,C)`` is the Hankel norm of the system (computed + in ``HSV(1)``); + If on input ``nr is None``, `nr` is equal to the number of Hankel + singular values greater than ``MAX(tol,n*eps*HNORM(A,B,C))``. + Ar : (nr, nr) ndarray + This array contains the state dynamics matrix `Ar` of the reduced + order system. + Br : (nr, m) ndarray + This array contains the input/state matrix `Br` of the reduced + order system. + Cr : (p, nr) ndarray + This array contains the state/output matrix `Cr` of the reduced + order system. + hsv : (n, ) ndarray + If ``INFO = 0``, it contains the Hankel singular values of + the original system ordered decreasingly. ``HSV(1)`` is the + Hankel norm of the system. Raises ------ @@ -783,81 +804,83 @@ def ab09ax(dico,job,n,m,p,A,B,C,nr=None,tol=0.0,ldwork=None): ``Ar = TI * A * T , Br = TI * B , Cr = C * T`` . - Required arguments : - dico : {'D', 'C'} input string(len=1) - Indicate whether the system is discrete `D` or continuous `C` - job : {'B', 'N'} input string(len=1) - Balance `B` or not `N` - n : input int - The number of state variables. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state - dynamics matrix A of the system *in real Schur form.* - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input/state - matrix B of the system. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the - state/output matrix C of the system. - - Optional arguments: - nr := None input int - `nr` is the desired order of the resulting reduced order - system. ``0 <= nr <= n``. Automatically determined by `tol` if - ``nr is None`` and returned. See return object `nr`. - tol := 0 input double precision - If ``nr is None``, `tol`contains the tolerance for determining the - order of the reduced system. For model reduction, the recommended - value is ``tol = c * HNORM(A, B, C)``, where `c` is a constant in - the interval ``[0.00001, 0.001]`` and ``HNORM(A, B, C)`` is - the Hankel-Norm of the given sysstem (computed in ``HSV(1)``). For - computing a minimal realization, the recommended value is - ``tol = n * eps * HNORM(A, B, C)``, where `eps` is the machine - precision (see LAPACK Library Routine `DLAMCH`). This value is - used by default if ``tol <= 0`` on entry. If `nr` is specified, - the value of `tol` is ignored. - ldwork := None input int - The length of the cache array. The default value is - ``n*(2*n+max(n,m,p)+5) + n*(n+1)/2 ~= 3.5*n**2 + 5*n``, - a larger value should lead to better performance. - - Return objects : - nr : output int - `nr` is the order of the resulting reduced order model. - `nr` is set as follows: - If on input ``nr is not None``, `nr` is equal to ``MIN(nr,NMIN)``, - where `nr` is the desired order on entry and `NMIN` is the order - of a minimal realization of the given system; `NMIN` is - determined as the number of Hankel singular values greater - than ``n*eps*HNORM(A,B,C)``, where `eps` is the machine - precision (see LAPACK Library Routine DLAMCH) and - ``HNORM(A,B,C)`` is the Hankel norm of the system (computed - in ``HSV(1)``); - If on input ``nr is None``, `nr` is equal to the number of Hankel - singular values greater than ``MAX(tol,n*eps*HNORM(A,B,C))``. - Ar : rank-2 array('d') with bounds ``(nr,nr)`` - This array contains the state dynamics matrix `Ar` of the reduced - order system. - Br : rank-2 array('d') with bounds ``(nr,m)`` - Tthis array contains the input/state matrix `Br` of the reduced - order system. - Cr : rank-2 array('d') with bounds ``(p,nr)`` - This array contains the state/output matrix `Cr` of the reduced - order system. - hsv : output double precision array, dimension ``(n)`` - If ``INFO = 0``, it contains the Hankel singular values of - the original system ordered decreasingly. ``HSV(1)`` is the - Hankel norm of the system. - T : rank-2 array('d') with bounds ``(n,nr)`` - This array contains the right truncation matrix `T` of the reduced - order system. - Ti : rank-2 array('d') with bounds ``(nr,n)`` - This array contains the left truncation matrix `Ti` of the reduced - order system. + Parameters + ---------- + dico : {'D', 'C'} + Indicate whether the system is discrete `D` or continuous `C` + job : {'B', 'N'} + Balance `B` or not `N` + n : int + The number of state variables. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system *in real Schur form.* + B : (n, m) array_like + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : (p, n) array_like + The leading p-by-n part of this array must contain the + state/output matrix C of the system. + nr : int, optional + `nr` is the desired order of the resulting reduced order + system. ``0 <= nr <= n``. Automatically determined by `tol` if + ``nr is None`` and returned. See return object `nr`. + Default is None. + tol : float, optional + If ``nr is None``, `tol`contains the tolerance for determining the + order of the reduced system. For model reduction, the recommended + value is ``tol = c * HNORM(A, B, C)``, where `c` is a constant in + the interval ``[0.00001, 0.001]`` and ``HNORM(A, B, C)`` is + the Hankel-Norm of the given sysstem (computed in ``HSV(1)``). For + computing a minimal realization, the recommended value is + ``tol = n * eps * HNORM(A, B, C)``, where `eps` is the machine + precision (see LAPACK Library Routine `DLAMCH`). This value is + used by default if ``tol <= 0`` on entry. If `nr` is specified, + the value of `tol` is ignored. Default is `0.0`. + ldwork : int, optional + The length of the cache array. The default value is + ``n*(2*n+max(n,m,p)+5) + n*(n+1)/2 ~= 3.5*n**2 + 5*n``, + a larger value should lead to better performance. + Default is None. + + Returns + ------- + nr : int + `nr` is the order of the resulting reduced order model. + `nr` is set as follows: + If on input ``nr is not None``, `nr` is equal to ``MIN(nr,NMIN)``, + where `nr` is the desired order on entry and `NMIN` is the order + of a minimal realization of the given system; `NMIN` is + determined as the number of Hankel singular values greater + than ``n*eps*HNORM(A,B,C)``, where `eps` is the machine + precision (see LAPACK Library Routine DLAMCH) and + ``HNORM(A,B,C)`` is the Hankel norm of the system (computed + in ``HSV(1)``); + If on input ``nr is None``, `nr` is equal to the number of Hankel + singular values greater than ``MAX(tol,n*eps*HNORM(A,B,C))``. + Ar : (nr, nr) ndarray + This array contains the state dynamics matrix `Ar` of the reduced + order system. + Br : (nr, m) ndarray + Tthis array contains the input/state matrix `Br` of the reduced + order system. + Cr : (p, nr) ndarray + This array contains the state/output matrix `Cr` of the reduced + order system. + hsv : (n, ) ndarray + If ``INFO = 0``, it contains the Hankel singular values of + the original system ordered decreasingly. ``HSV(1)`` is the + Hankel norm of the system. + T : (n, nr) ndarray + This array contains the right truncation matrix `T` of the reduced + order system. + Ti : (nr, n) ndarray + This array contains the left truncation matrix `Ti` of the reduced + order system. Raises ------ @@ -905,100 +928,101 @@ def ab09bd(dico,job,equil,n,m,p,A,B,C,D,nr=None,tol1=0,tol2=0,ldwork=None): Perturbation Approximation (SPA) model reduction method. Must supply either nr or tolerance values. - Arguments - Mode Parameters - dico - Specifies the type of the original system as follows: - = 'C': continuous-time system; - = 'D': discrete-time system. - job - Specifies the model reduction approach to be used - as follows: - = 'B': use the square-root SPA method; - = 'N': use the balancing-free square-root SPA method. - equil - Specifies whether the user wishes to preliminarily - equilibrate the triplet (A,B,C) as follows: - = 'S': perform equilibration (scaling); - = 'N': do not perform equilibration. - - Required arguments - n : input int - The order of the original state-space representation, i.e. - the order of the matrix A. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - On entry, the leading n-by-n part of this array must - contain the state dynamics matrix A. - B : input rank-2 array('d') with bounds (n,m) - On entry, the leading n-by-m part of this array must - contain the original input/state matrix B. - C : input rank-2 array('d') with bounds (p,n) - On entry, the leading p-by-n part of this array must - contain the original state/output matrix C. - D : input rank-2 array('d') with bounds (p,m) - On entry, the leading p-by-m part of this array must - contain the original input/output matrix D. - - Optional arguments : - nr :=None input int - nr is the desired order of - the resulting reduced order system. 0 <= nr <= n. - tol1 :=0 input double precision - If ordsel = 'A', tol1 contains the tolerance for - determining the order of reduced system. - For model reduction, the recommended value is - tol1 = c*hnorm(A,B,C), where c is a constant in the - interval [0.00001,0.001], and hnorm(A,B,C) is the - Hankel-norm of the given system (computed in hsv(1)). - For computing a minimal realization, the recommended - value is tol1 = n*eps*hnorm(A,B,C), where eps is the - machine precision (see LAPACK Library Routine DLAMCH). - This value is used by default if tol1 <= 0 on entry. - If ordsel = 'F', the value of tol1 is ignored. - tol2 :=0 input double precision - The tolerance for determining the order of a minimal - realization of the given system. The recommended value is - tol2 = n*eps*hnorm(A,B,C). This value is used by default - if tol2 <= 0 on entry. - If tol2 > 0, then tol2 <= tol1. - ldwork := None input int - The length of the cache array. The default value is n + 3*max(m,p), - for better performance should be larger. - - Return objects - nr : output int - nr is the order of the resulting reduced order model. - nr is set as follows: - if ordsel = 'F', nr is equal to min(nr,nmin), where nr - is the desired order on entry and nmin is the order of a - minimal realization of the given system; nmin is - determined as the number of Hankel singular values greater - than n*eps*hnorm(A,B,C), where eps is the machine - precision (see LAPACK Library Routine DLAMCH) and - hnorm(A,B,C) is the Hankel norm of the system (computed - in hsv(1)); - if ordsel = 'A', nr is equal to the number of Hankel - singular values greater than max(tol1,n*eps*hnorm(A,B,C)). - Ar : rank-2 array('d') with bounds (nr,nr) - the leading nr-by-nr part of this array contains the - state dynamics matrix Ar of the reduced order system. - Br : rank-2 array('d') with bounds (nr,m) - the leading nr-by-m part of this array contains the - input/state matrix Br of the reduced order system. - Cr : rank-2 array('d') with bounds (p,nr) - the leading p-by-nr part of this array contains the - state/output matrix Cr of the reduced order system. - Dr : rank-2 array('d') with bounds (p,m) - the leading p-by-m part of this array contains the - input/output matrix Dr of the reduced order system. - hsv : output double precision array, dimension (n) - If info = 0, it contains the Hankel singular values of - the original system ordered decreasingly. hsv(1) is the - Hankel norm of the system. + Parameters + ---------- + dico : {'C', 'D'} + Specifies the type of the original system as follows: + = 'C': continuous-time system; + = 'D': discrete-time system. + job : {'B', 'N'} + Specifies the model reduction approach to be used + as follows: + = 'B': use the square-root SPA method; + = 'N': use the balancing-free square-root SPA method. + equil : {'S', 'N'} + Specifies whether the user wishes to preliminarily + equilibrate the triplet (A,B,C) as follows: + = 'S': perform equilibration (scaling); + = 'N': do not perform equilibration. + n : int + The order of the original state-space representation, i.e. + the order of the matrix A. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + On entry, the leading n-by-n part of this array must + contain the state dynamics matrix A. + B : (n, m) array_like + On entry, the leading n-by-m part of this array must + contain the original input/state matrix B. + C : (p, n) array_like + On entry, the leading p-by-n part of this array must + contain the original state/output matrix C. + D : (p, m) array_like + On entry, the leading p-by-m part of this array must + contain the original input/output matrix D. + nr : int, optional + nr is the desired order of + the resulting reduced order system. 0 <= nr <= n. + Default is None. + tol1 : float, optional + If ordsel = 'A', tol1 contains the tolerance for + determining the order of reduced system. + For model reduction, the recommended value is + tol1 = c*hnorm(A,B,C), where c is a constant in the + interval [0.00001,0.001], and hnorm(A,B,C) is the + Hankel-norm of the given system (computed in hsv(1)). + For computing a minimal realization, the recommended + value is tol1 = n*eps*hnorm(A,B,C), where eps is the + machine precision (see LAPACK Library Routine DLAMCH). + This value is used by default if tol1 <= 0 on entry. + If ordsel = 'F', the value of tol1 is ignored. + Default is `0.0`. + tol2 : float, optional + The tolerance for determining the order of a minimal + realization of the given system. The recommended value is + tol2 = n*eps*hnorm(A,B,C). This value is used by default + if tol2 <= 0 on entry. + If tol2 > 0, then tol2 <= tol1. + Default is `0.0`. + ldwork : int, optional + The length of the cache array. The default value is n + 3*max(m,p), + for better performance should be larger. + Default is None. + + Returns + ------- + nr : int + nr is the order of the resulting reduced order model. + nr is set as follows: + if ordsel = 'F', nr is equal to min(nr,nmin), where nr + is the desired order on entry and nmin is the order of a + minimal realization of the given system; nmin is + determined as the number of Hankel singular values greater + than n*eps*hnorm(A,B,C), where eps is the machine + precision (see LAPACK Library Routine DLAMCH) and + hnorm(A,B,C) is the Hankel norm of the system (computed + in hsv(1)); + if ordsel = 'A', nr is equal to the number of Hankel + singular values greater than max(tol1,n*eps*hnorm(A,B,C)). + Ar : (nr, nr) ndarray + the leading nr-by-nr part of this array contains the + state dynamics matrix Ar of the reduced order system. + Br : (nr, m) ndarray + the leading nr-by-m part of this array contains the + input/state matrix Br of the reduced order system. + Cr : (p, nr) ndarray + the leading p-by-nr part of this array contains the + state/output matrix Cr of the reduced order system. + Dr : (p, m) ndarray + the leading p-by-m part of this array contains the + input/output matrix Dr of the reduced order system. + hsv : (n, ) ndarray + If info = 0, it contains the Hankel singular values of + the original system ordered decreasingly. hsv(1) is the + Hankel norm of the system. Raises ------ @@ -1049,119 +1073,120 @@ def ab09md(dico,job,equil,n,m,p,A,B,C,alpha=None,nr=None,tol=0,ldwork=None): or the balancing-free square-root Balance & Truncate (B & T) model reduction method for the ALPHA-stable part of the system. - Arguments - Mode Parameters - dico - Specifies the type of the original system as follows: - = 'C': continuous-time system; - = 'D': discrete-time system. - job - Specifies the model reduction approach to be used - as follows: - = 'B': use the square-root Balance & Truncate method; - = 'N': use the balancing-free square-root - Balance & Truncate method. - equil - Specifies whether the user wishes to preliminarily - equilibrate the triplet (A,B,C) as follows: - = 'S': perform equilibration (scaling); - = 'N': do not perform equilibration. - - Required arguments - n : input int - The order of the original state-space representation, i.e. - the order of the matrix A. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d'), dimension (n,n) - On entry, the leading N-by-N part of this array must - contain the state dynamics matrix A. - B : input rank-2 array('d'), dimension (n,m) - On entry, the leading N-by-M part of this array must - contain the original input/state matrix B. - C : input rank-2 array('d'), dimension (p,n) - On entry, the leading P-by-N part of this array must - contain the original state/output matrix C. - - Optional arguments - alpha :=None input double precision - Specifies the alpha-stability boundary for the eigenvalues - of the state dynamics matrix A. For a continuous-time - system (dico = 'C'), alpha <= 0 is the boundary value for - the real parts of eigenvalues, while for a discrete-time - system (dico = 'D'), 0 <= alpha <= 1 represents the - boundary value for the moduli of eigenvalues. - The alpha-stability domain does not include the boundary. - nr := None input int - On entry with ordsel = 'F', nr is the desired order of the - resulting reduced order system. 0 <= nr <= n. - tol :=0 input double precision - If ordsel = 'A', tol contains the tolerance for - determining the order of reduced system. - For model reduction, the recommended value is - tol = c*hnorm(As,Bs,Cs), where c is a constant in the - interval [0.00001,0.001], and hnorm(As,Bs,Cs) is the - Hankel-norm of the alpha-stable part of the given system - (computed in hsv(1)). - If tol <= 0 on entry, the used default value is - tol = ns*eps*hnorm(As,Bs,Cs), where ns is the number of - alpha-stable eigenvalues of A and eps is the machine - precision (see LAPACK Library Routine DLAMCH). - This value is appropriate to compute a minimal realization - of the alpha-stable part. - If ordsel = 'F', the value of tol is ignored. - ldwork :=None input int - The length of the array dwork. - ldwork >= max(1,n*(2*n+max(n,m,p)+5) + n*(n+1)/2). - For optimum performance ldwork should be larger. - - Return objects - nr : output int - On exit, if info = 0, nr is the order of the resulting - reduced order model. For a system with nu alpha-unstable - eigenvalues and ns alpha-stable eigenvalues (nu+ns = n), - nr is set as follows: if ordsel = 'F', nr is equal to - nu+min(max(0,nr-nu),nmin), where nr is the desired order - on entry, and nmin is the order of a minimal realization - of the alpha-stable part of the given system; nmin is - determined as the number of Hankel singular values greater - than ns*eps*hnorm(As,Bs,Cs), where eps is the machine - precision (see LAPACK Library Routine DLAMCH) and - hnorm(As,Bs,Cs) is the Hankel norm of the alpha-stable - part of the given system (computed in hsv(1)); - if ordsel = 'A', nr is the sum of nu and the number of - Hankel singular values greater than - max(tol,ns*eps*hnorm(As,Bs,Cs)). - Ar : rank-2 array('d') with bounds (nr,nr) - On exit, if info = 0, the leading nr-by-nr part of this - array contains the state dynamics matrix Ar of the reduced - order system. - The resulting A has a block-diagonal form with two blocks. - For a system with nu alpha-unstable eigenvalues and - ns alpha-stable eigenvalues (nu+ns = n), the leading - nu-by-nu block contains the unreduced part of A - corresponding to alpha-unstable eigenvalues in an - upper real Schur form. - The trailing (nr+ns-n)-by-(nr+ns-n) block contains - the reduced part of A corresponding to alpha-stable - eigenvalues. - Br : rank-2 array('d') with bounds (nr,m) - On exit, if info = 0, the leading nr-by-m part of this - array contains the input/state matrix Br of the reduced - order system. - Cr : rank-2 array('d') with bounds (p,nr) - On exit, if info = 0, the leading p-by-nr part of this - array contains the state/output matrix Cr of the reduced - order system. - ns : output int - The dimension of the alpha-stable subsystem. - hsv : output double precision array, dimension (n) - If info = 0, the leading ns elements of hsv contain the - Hankel singular values of the alpha-stable part of the - original system ordered decreasingly. - hsv(1) is the Hankel norm of the alpha-stable subsystem. + Parameters + ---------- + dico : {'C', 'D'} + Specifies the type of the original system as follows: + = 'C': continuous-time system; + = 'D': discrete-time system. + job : {'B', 'N'} + Specifies the model reduction approach to be used + as follows: + = 'B': use the square-root Balance & Truncate method; + = 'N': use the balancing-free square-root + Balance & Truncate method. + equil : {'S', 'N'} + Specifies whether the user wishes to preliminarily + equilibrate the triplet (A,B,C) as follows: + = 'S': perform equilibration (scaling); + = 'N': do not perform equilibration. + n : int + The order of the original state-space representation, i.e. + the order of the matrix A. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + On entry, the leading N-by-N part of this array must + contain the state dynamics matrix A. + B : (n, m) array_like + On entry, the leading N-by-M part of this array must + contain the original input/state matrix B. + C : (p, n) array_like + On entry, the leading P-by-N part of this array must + contain the original state/output matrix C. + alpha : float, optional + Specifies the alpha-stability boundary for the eigenvalues + of the state dynamics matrix A. For a continuous-time + system (dico = 'C'), alpha <= 0 is the boundary value for + the real parts of eigenvalues, while for a discrete-time + system (dico = 'D'), 0 <= alpha <= 1 represents the + boundary value for the moduli of eigenvalues. + The alpha-stability domain does not include the boundary. + Default is None. + nr : int, optional + On entry with ordsel = 'F', nr is the desired order of the + resulting reduced order system. 0 <= nr <= n. + Default is None. + tol : float, optional + If ordsel = 'A', tol contains the tolerance for + determining the order of reduced system. + For model reduction, the recommended value is + tol = c*hnorm(As,Bs,Cs), where c is a constant in the + interval [0.00001,0.001], and hnorm(As,Bs,Cs) is the + Hankel-norm of the alpha-stable part of the given system + (computed in hsv(1)). + If tol <= 0 on entry, the used default value is + tol = ns*eps*hnorm(As,Bs,Cs), where ns is the number of + alpha-stable eigenvalues of A and eps is the machine + precision (see LAPACK Library Routine DLAMCH). + This value is appropriate to compute a minimal realization + of the alpha-stable part. + If ordsel = 'F', the value of tol is ignored. + Default is `0.0`. + ldwork : int, optional + The length of the array dwork. + ldwork >= max(1,n*(2*n+max(n,m,p)+5) + n*(n+1)/2). + For optimum performance ldwork should be larger. + Default is None. + + Returns + ------- + nr : int + On exit, if info = 0, nr is the order of the resulting + reduced order model. For a system with nu alpha-unstable + eigenvalues and ns alpha-stable eigenvalues (nu+ns = n), + nr is set as follows: if ordsel = 'F', nr is equal to + nu+min(max(0,nr-nu),nmin), where nr is the desired order + on entry, and nmin is the order of a minimal realization + of the alpha-stable part of the given system; nmin is + determined as the number of Hankel singular values greater + than ns*eps*hnorm(As,Bs,Cs), where eps is the machine + precision (see LAPACK Library Routine DLAMCH) and + hnorm(As,Bs,Cs) is the Hankel norm of the alpha-stable + part of the given system (computed in hsv(1)); + if ordsel = 'A', nr is the sum of nu and the number of + Hankel singular values greater than + max(tol,ns*eps*hnorm(As,Bs,Cs)). + Ar : (nr, nr) array_like + On exit, if info = 0, the leading nr-by-nr part of this + array contains the state dynamics matrix Ar of the reduced + order system. + The resulting A has a block-diagonal form with two blocks. + For a system with nu alpha-unstable eigenvalues and + ns alpha-stable eigenvalues (nu+ns = n), the leading + nu-by-nu block contains the unreduced part of A + corresponding to alpha-unstable eigenvalues in an + upper real Schur form. + The trailing (nr+ns-n)-by-(nr+ns-n) block contains + the reduced part of A corresponding to alpha-stable + eigenvalues. + Br : (nr, m) array_like + On exit, if info = 0, the leading nr-by-m part of this + array contains the input/state matrix Br of the reduced + order system. + Cr : (p, nr) array_like + On exit, if info = 0, the leading p-by-nr part of this + array contains the state/output matrix Cr of the reduced + order system. + ns : int + The dimension of the alpha-stable subsystem. + hsv : (n, ) array_like + If info = 0, the leading ns elements of hsv contain the + Hankel singular values of the alpha-stable part of the + original system ordered decreasingly. + hsv(1) is the Hankel norm of the alpha-stable subsystem. Raises ------ @@ -1218,115 +1243,116 @@ def ab09nd(dico,job,equil,n,m,p,A,B,C,D,alpha=None,nr=None,tol1=0,tol2=0,ldwork= Perturbation Approximation (SPA) model reduction method for the alpha-stable part of the system. - Arguments - Mode Parameters - dico - Specifies the type of the original system as follows: - = 'C': continuous-time system; - = 'D': discrete-time system. - job - Specifies the model reduction approach to be used - as follows: - = 'B': use the square-root SPA method; - = 'N': use the balancing-free square-root SPA method. - equil - Specifies whether the user wishes to preliminarily - equilibrate the triplet (A,B,C) as follows: - = 'S': perform equilibration (scaling); - = 'N': do not perform equilibration. - - Required arguments - n : input int - The order of the original state-space representation, i.e. - the order of the matrix A. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - On entry, the leading n-by-n part of this array must - contain the state dynamics matrix A. - B : input rank-2 array('d') with bounds (n,m) - On entry, the leading n-by-m part of this array must - contain the original input/state matrix B. - C : input rank-2 array('d') with bounds (p,n) - On entry, the leading p-by-n part of this array must - contain the original state/output matrix C. - D : input rank-2 array('d') with bounds (p,m) - On entry, the leading p-by-m part of this array must - contain the original input/output matrix D. - - Optional arguments - alpha :=None input double precision - Specifies the alpha-stability boundary for the eigenvalues - of the state dynamics matrix A. For a continuous-time - system (dico = 'C'), alpha <= 0 is the boundary value for - the real parts of eigenvalues, while for a discrete-time - system (dico = 'D'), 0 <= alpha <= 1 represents the - boundary value for the moduli of eigenvalues. - The alpha-stability domain does not include the boundary. - nr :=None input int - nr is the desired order of - the resulting reduced order system. 0 <= nr <= n. - tol1 :=0 input double precision - If ordsel = 'A', tol1 contains the tolerance for - determining the order of reduced system. - For model reduction, the recommended value is - tol1 = c*hnorm(As,Bs,Cs), where c is a constant in the - interval [0.00001,0.001], and hnorm(As,Bs,Cs) is the - Hankel-norm of the alpha-stable part of the given system - (computed in hsv(1)). - If tol1 <= 0 on entry, the used default value is - tol1 = ns*eps*hnorm(As,Bs,Cs), where NS is the number of - alpha-stable eigenvalues of A and eps is the machine - precision (see LAPACK Library Routine DLAMCH). - This value is appropriate to compute a minimal realization - of the alpha-stable part. - If ordsel = 'F', the value of tol1 is ignored. - tol2 :=0 input double precision - The tolerance for determining the order of a minimal - realization of the alpha-stable part of the given system. - The recommended value is tol2 = ns*eps*hnorm(As,Bs,Cs). - This value is used by default if tol2 <= 0 on entry. - If tol2 > 0, then tol2 <= tol1. - ldwork := None input int - The length of the array dwork. - ldwork >= max(1,n*(2*n+max(n,m,p)+5) + n*(n+1)/2). - For optimum performance ldwork should be larger. - - Return objects - nr : output int - nr is the order of the resulting reduced order model. - nr is set as follows: - if ordsel = 'F', nr is equal to min(nr,nmin), where nr - is the desired order on entry and nmin is the order of a - minimal realization of the given system; nmin is - determined as the number of Hankel singular values greater - than n*eps*hnorm(A,B,C), where eps is the machine - precision (see LAPACK Library Routine DLAMCH) and - hnorm(A,B,C) is the Hankel norm of the system (computed - in hsv(1)); - if ordsel = 'A', nr is equal to the number of Hankel - singular values greater than max(TOL1,n*eps*hnorm(A,B,C)). - Ar : rank-2 array('d') with bounds (nr,nr) - the leading nr-by-nr part of this array contains the - state dynamics matrix Ar of the reduced order system. - Br : rank-2 array('d') with bounds (nr,m) - the leading nr-by-m part of this array contains the - input/state matrix Br of the reduced order system. - Cr : rank-2 array('d') with bounds (p,nr) - the leading p-by-nr part of this array contains the - state/output matrix Cr of the reduced order system. - Dr : rank-2 array('d') with bounds (p,m) - the leading p-by-m part of this array contains the - input/output matrix Dr of the reduced order system. - ns : output int - The dimension of the alpha-stable subsystem. - hsv : output double precision array, dimension (n) - If info = 0, it contains the Hankel singular values of - the original system ordered decreasingly. hsv(1) is the - Hankel norm of the system. + Parameters + ---------- + dico : {'C', 'D'} + Specifies the type of the original system as follows: + = 'C': continuous-time system; + = 'D': discrete-time system. + job : {'B', 'N'} + Specifies the model reduction approach to be used + as follows: + = 'B': use the square-root SPA method; + = 'N': use the balancing-free square-root SPA method. + equil : {'S', 'N'} + Specifies whether the user wishes to preliminarily + equilibrate the triplet (A,B,C) as follows: + = 'S': perform equilibration (scaling); + = 'N': do not perform equilibration. + n : int + The order of the original state-space representation, i.e. + the order of the matrix A. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + On entry, the leading n-by-n part of this array must + contain the state dynamics matrix A. + B : (n, m) array_like + On entry, the leading n-by-m part of this array must + contain the original input/state matrix B. + C : (p, n) array_like + On entry, the leading p-by-n part of this array must + contain the original state/output matrix C. + D : (p, m) array_like + On entry, the leading p-by-m part of this array must + contain the original input/output matrix D. + alpha : float, optional + Specifies the alpha-stability boundary for the eigenvalues + of the state dynamics matrix A. For a continuous-time + system (dico = 'C'), alpha <= 0 is the boundary value for + the real parts of eigenvalues, while for a discrete-time + system (dico = 'D'), 0 <= alpha <= 1 represents the + boundary value for the moduli of eigenvalues. + The alpha-stability domain does not include the boundary. + Default is None. + nr : int, optional + nr is the desired order of + the resulting reduced order system. 0 <= nr <= n. + Default is None. + tol1 : float, optional + If ordsel = 'A', tol1 contains the tolerance for + determining the order of reduced system. + For model reduction, the recommended value is + tol1 = c*hnorm(As,Bs,Cs), where c is a constant in the + interval [0.00001,0.001], and hnorm(As,Bs,Cs) is the + Hankel-norm of the alpha-stable part of the given system + (computed in hsv(1)). + If tol1 <= 0 on entry, the used default value is + tol1 = ns*eps*hnorm(As,Bs,Cs), where NS is the number of + alpha-stable eigenvalues of A and eps is the machine + precision (see LAPACK Library Routine DLAMCH). + This value is appropriate to compute a minimal realization + of the alpha-stable part. + If ordsel = 'F', the value of tol1 is ignored. + Default is `0.0`. + tol2 : float, optional + The tolerance for determining the order of a minimal + realization of the alpha-stable part of the given system. + The recommended value is tol2 = ns*eps*hnorm(As,Bs,Cs). + This value is used by default if tol2 <= 0 on entry. + If tol2 > 0, then tol2 <= tol1. + Default is `0.0`. + ldwork : int, optional + The length of the array dwork. + ldwork >= max(1,n*(2*n+max(n,m,p)+5) + n*(n+1)/2). + For optimum performance ldwork should be larger. + Default is None. + Returns + ------- + nr : int + nr is the order of the resulting reduced order model. + nr is set as follows: + if ordsel = 'F', nr is equal to min(nr,nmin), where nr + is the desired order on entry and nmin is the order of a + minimal realization of the given system; nmin is + determined as the number of Hankel singular values greater + than n*eps*hnorm(A,B,C), where eps is the machine + precision (see LAPACK Library Routine DLAMCH) and + hnorm(A,B,C) is the Hankel norm of the system (computed + in hsv(1)); + if ordsel = 'A', nr is equal to the number of Hankel + singular values greater than max(TOL1,n*eps*hnorm(A,B,C)). + Ar : (nr, nr) ndarray + the leading nr-by-nr part of this array contains the + state dynamics matrix Ar of the reduced order system. + Br : (nr, m) ndarray + the leading nr-by-m part of this array contains the + input/state matrix Br of the reduced order system. + Cr : (p, nr) ndarray + the leading p-by-nr part of this array contains the + state/output matrix Cr of the reduced order system. + Dr : (p, m) ndarray + the leading p-by-m part of this array contains the + input/output matrix Dr of the reduced order system. + ns : int + The dimension of the alpha-stable subsystem. + hsv : (n, ) ndarray + If info = 0, it contains the Hankel singular values of + the original system ordered decreasingly. hsv(1) is the + Hankel norm of the system. Raises ------ @@ -1391,21 +1417,21 @@ def ab13bd(dico, jobn, n, m, p, A, B, C, D, tol = 0.0): jobn : {'H', 'L'} H2-norm 'H' or L2-norm 'L' to be computed. n : int - The number of state variables. n >= 0. + The number of state variables. n >= 0. m : int - The number of system inputs. m >= 0. + The number of system inputs. m >= 0. p : int - The number of system outputs. p >= 0. - A : (n,n) ndarray + The number of system outputs. p >= 0. + A : (n, n) ndarray The leading n-by-n part of this array must contain the state dynamics matrix A of the system. - B : (n,m) ndarray + B : (n, m) ndarray The leading n-by-m part of this array must contain the input/state matrix B of the system. - C : (p,n) ndarray + C : (p, n) ndarray The leading p-by-n part of this array must contain the state/output matrix C of the system. - D : (p,m) ndarray + D : (p, m) ndarray The leading p-by-m part of this array must contain the direct transmission matrix D of the system. tol : float, optional @@ -1478,65 +1504,66 @@ def ab13dd(dico, jobe, equil, jobd, n, m, p, A, E, B, C, D, tol = 1e-10): imaginary axis, or the unit circle, respectively. It is assumed that the matrix E is nonsingular. - Required arguments: - dico : {'D', 'C'} input string(len=1) - Indicate whether the system is discrete 'D' or continuous 'C'. - jobe : {'G', 'I'} input string(len=1) - Specifies whether E is a general square or an identity - matrix, as follows: - = 'G': E is a general square matrix; - = 'I': E is the identity matrix. - equil : {'S', 'N'} input string(len=1) - Specifies whether the user wishes to preliminarily - equilibrate the system (A,E,B,C) or (A,B,C), as follows: - = 'S': perform equilibration (scaling); - = 'N': do not perform equilibration. - jobd : {'D', 'Z'} input string(len=1) - Specifies whether or not a non-zero matrix D appears in - the given state space model: - = 'D': D is present; - = 'Z': D is assumed a zero matrix. - n : input int - The number of state variables. n >= 0. - m : input int - The number of system inputs. m >= 0. - p : input int - The number of system outputs. p >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the state - dynamics matrix A of the system. - E : input rank-2 array('d') with bounds (n,n) - If jobe = 'G', the leading N-by-N part of this array must - contain the descriptor matrix E of the system. - If jobe = 'I', then E is assumed to be the identity - matrix and is not referenced. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the input/state - matrix B of the system. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the state/output - matrix C of the system. - D : input rank-2 array('d') with bounds (p,m) - The leading p-by-m part of this array must contain the direct - transmission matrix D of the system. - - Optional arguments: - tol : Tolerance used to set the accuracy in determining the - norm. 0 <= tol < 1. - - Return objects: - gpeak : float - The L-infinity norm of the system, i.e., the peak gain - of the frequency response (as measured by the largest - singular value in the MIMO case). - fpeak : float - The frequency where the gain of the frequency response - achieves its peak value gpeak, i.e., - - || G ( j*fpeak ) || = gpeak , if dico = 'C', or - - j*fpeak - || G ( e ) || = gpeak , if dico = 'D'. + Parameters + ---------- + dico : {'D', 'C'} + Indicate whether the system is discrete 'D' or continuous 'C'. + jobe : {'G', 'I'} + Specifies whether E is a general square or an identity + matrix, as follows: + = 'G': E is a general square matrix; + = 'I': E is the identity matrix. + equil : {'S', 'N'} + Specifies whether the user wishes to preliminarily + equilibrate the system (A,E,B,C) or (A,B,C), as follows: + = 'S': perform equilibration (scaling); + = 'N': do not perform equilibration. + jobd : {'D', 'Z'} + Specifies whether or not a non-zero matrix D appears in + the given state space model: + = 'D': D is present; + = 'Z': D is assumed a zero matrix. + n : int + The number of state variables. n >= 0. + m : int + The number of system inputs. m >= 0. + p : int + The number of system outputs. p >= 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the state + dynamics matrix A of the system. + E : (n, n) array_like + If jobe = 'G', the leading N-by-N part of this array must + contain the descriptor matrix E of the system. + If jobe = 'I', then E is assumed to be the identity + matrix and is not referenced. + B : (n, m) array_like + The leading n-by-m part of this array must contain the input/state + matrix B of the system. + C : (p, n) array_like + The leading p-by-n part of this array must contain the state/output + matrix C of the system. + D : (p, m) array_like + The leading p-by-m part of this array must contain the direct + transmission matrix D of the system. + tol : float + Tolerance used to set the accuracy in determining the norm. + 0 <= tol < 1. Default tol=1e-10. + + Returns + ------- + gpeak : float + The L-infinity norm of the system, i.e., the peak gain + of the frequency response (as measured by the largest + singular value in the MIMO case). + fpeak : float + The frequency where the gain of the frequency response + achieves its peak value gpeak, i.e., + + || G ( j*fpeak ) || = gpeak , if dico = 'C', or + + j*fpeak + || G ( e ) || = gpeak , if dico = 'D'. Raises ------ @@ -1606,9 +1633,9 @@ def ab13ed(n, A, tol = 9.0): ---------- n : int The order of the matrix A. ``n >= 0.`` - A : (n,n) array_like + A : (n, n) array_like The leading n-by-n part of this array must contain the matrix A. - tol : float optional + tol : float, optional Specifies the accuracy with which low and high approximate beta(A). If the user sets tol to be less than sqrt(eps), where eps is the machine precision (see LAPACK Library @@ -1649,41 +1676,27 @@ def ab13fd(n, A, tol = 0.0): smallest singular value of (A - jwI), taken over all real w. The value of w corresponding to the minimum is also computed. - Required arguments: - n : input int - The order of the matrix A. n >= 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the matrix A. - - Optional arguments: - tol : Specifies the accuracy with which beta(A) is to be - calculated. (See the Numerical Aspects section below.) - If the user sets tol to be less than eps, where eps is the - machine precision (see LAPACK Library Routine DLAMCH), - then the tolerance is taken to be eps. - - Return objects: - beta : float - The computed value of beta(A), which actually is an upper - bound. - omega : float - The value of w such that the smallest singular value of - (A - jwI) equals beta(A). - - Numerical Aspects: - In the presence of rounding errors, the computed function value - beta satisfies - beta(A) <= beta + epsilon, - beta/(1+tol) - delta <= max(beta(A), sqrt(2*n*eps)*norm(A)), - where norm(A) is the Frobenius norm of A, - epsilon = p(n) * eps * norm(A), - and - delta = p(n) * sqrt(eps) * norm(A), - and p(n) is a low degree polynomial. It is recommended to choose - tol greater than sqrt(eps). Although rounding errors can cause - AB13FD to fail for smaller values of tol, nevertheless, it usually - succeeds. Regardless of success or failure, the first inequality - holds. + Parameters + ---------- + n : int + The order of the matrix A. n >= 0. + A : (n, n), array_like + The leading n-by-n part of this array must contain the matrix A. + tol : float, optional + Specifies the accuracy with which beta(A) is to be + calculated. (See the Numerical Aspects section below.) + If the user sets tol to be less than eps, where eps is the + machine precision (see LAPACK Library Routine DLAMCH), + then the tolerance is taken to be eps. + + Returns + ------- + beta : float + The computed value of beta(A), which actually is an upper + bound. + omega : float + The value of w such that the smallest singular value of + (A - jwI) equals beta(A). Raises ------ @@ -1697,6 +1710,22 @@ def ab13fd(n, A, tol = 0.0): :info = 1: Failed to compute beta(A) within the specified tolerance. Nevertheless, the returned value is an upper bound on beta(A); + + Notes + ----- + In the presence of rounding errors, the computed function value + beta satisfies + beta(A) <= beta + epsilon, + beta/(1+tol) - delta <= max(beta(A), sqrt(2*n*eps)*norm(A)), + where norm(A) is the Frobenius norm of A, + epsilon = p(n) * eps * norm(A), + and + delta = p(n) * sqrt(eps) * norm(A), + and p(n) is a low degree polynomial. It is recommended to choose + tol greater than sqrt(eps). Although rounding errors can cause + AB13FD to fail for smaller values of tol, nevertheless, it usually + succeeds. Regardless of success or failure, the first inequality + holds. """ hidden = ' (hidden by the wrapper)' arg_list = ['n', 'A', 'lda' + hidden, 'beta' + hidden, 'omega' + hidden, 'tol', @@ -1715,40 +1744,34 @@ def ab13md(Z, nblock, itype, x=None): Parameters ---------- - Z : (n,n) complex array - Matrix to find structured singular value upper bound of - - nblock : (m,) integer array - The size of the block diagonals of the uncertainty structure; - i.e., nblock(i)=p means that the ith block is pxp. - - itype : (m,) integer array - The type of each block diagonal uncertainty defined in nblock. - itype(i)==1 means that the ith block is real, while itype(i)==2 - means the the ith block is complex. Real blocks must be 1x1, - i.e., if itype(i)==1, nblock(i) must be 1. - - x : (q,) real array or None - If not None, must be the output of a previous call to ab13md. - The previous call must have been with the same values of n, - nblock, and itype; and the previous call's Z should be "close" - to the current call's Z. - - q is determined by the block structure; see SLICOT AB13MD for - details. + Z : (n, n) array_like + Matrix to find structured singular value upper bound of + nblock : (m, ) array_like + The size of the block diagonals of the uncertainty structure; + i.e., nblock(i)=p means that the ith block is pxp. + itype : (m, ) array_like + The type of each block diagonal uncertainty defined in nblock. + itype(i)==1 means that the ith block is real, while itype(i)==2 + means the the ith block is complex. Real blocks must be 1x1, + i.e., if itype(i)==1, nblock(i) must be 1. + x : (q, ) array_like, optional + If not None, must be the output of a previous call to ab13md. + The previous call must have been with the same values of n, + nblock, and itype; and the previous call's Z should be "close" + to the current call's Z. + q is determined by the block structure; see SLICOT AB13MD for + details. Default is None. Returns ------- mubound : non-negative real scalar - Upper bound on structure singular value for given arguments - - d, g : (n,) real arrays - Real arrays such that if D=np.diag(g), G=np.diag(G), and ZH = Z.T.conj(), then - ZH @ D**2 @ Z + 1j * (G@Z - ZH@G) - mu**2 * D**2 - will be negative semi-definite. - - xout : (q,) real array - For use as ``x`` argument in subsequent call to ``ab13md``. + Upper bound on structure singular value for given arguments + d, g : (n, ) ndarray + Real arrays such that if D=np.diag(g), G=np.diag(G), and ZH = Z.T.conj(), then + ZH @ D**2 @ Z + 1j * (G@Z - ZH@G) - mu**2 * D**2 + will be negative semi-definite. + xout : (q, ) ndarray + For use as ``x`` argument in subsequent call to ``ab13md``. For scalar Z and real uncertainty (ntype=1, itype=1), returns 0 instead of abs(Z). @@ -1831,75 +1854,75 @@ def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): and left Kronecker indices, and the multiplicities of infinite eigenvalues. - Required arguments: - l : input int - The number of rows of matrices A, B, and E. l >= 0. - n : input int - The number of columns of matrices A, E, and C. n >= 0. - m : input int - The number of columns of matrix B. m >= 0. - p : input int - The number of rows of matrix C. p >= 0. - A : rank-2 array('d') with bounds (l,n) - The leading l-by-n part of this array must - contain the state dynamics matrix A of the system. - E : rank-2 array('d') with bounds (l,n) - The leading l-by-n part of this array must - contain the descriptor matrix E of the system. - B : rank-2 array('d') with bounds (l,m) - The leading l-by-m part of this array must - contain the input/state matrix B of the system. - C : rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must - contain the state/output matrix C of the system. - D : rank-2 array('d') with bounds (p,m) - The leading p-by-m part of this array must contain the - direct transmission matrix D of the system. - Optional arguments: - equil := 'N' input string(len=1) - Specifies whether the user wishes to balance the system - matrix as follows: - = 'S': Perform balancing (scaling); - = 'N': Do not perform balancing. - tol := 0 input float - A tolerance used in rank decisions to determine the - effective rank, which is defined as the order of the - largest leading (or trailing) triangular submatrix in the - QR (or RQ) factorization with column (or row) pivoting - whose estimated condition number is less than 1/TOL. - If the user sets TOL <= 0, then default tolerances are - used instead, as follows: TOLDEF = L*N*EPS in TG01FD - (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS - in the rest, where EPS is the machine precision - (see LAPACK Library routine DLAMCH). TOL < 1. - ldwork : input int - The length of the cache array. - ldwork >= max( 4*(l,n), ldw ), if equil = 'S', - ldwork >= ldw, if equil = 'N', where - ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)). - For optimum performance ldwork should be larger. - Return objects: - Af : rank-2 array('d') - the leading NFZ-by-NFZ part of this array - contains the matrix Af of the reduced pencil. - Ef : rank-2 array('d') - the leading NFZ-by-NFZ part of this array - contains the matrix Ef of the reduced pencil. - nrank : output int - The normal rank of the system pencil. - niz : output int - The number of infinite zeros. - infz : rank-1 array('i') - The leading DINFZ elements of infz contain information - on the infinite elementary divisors as follows: - the system has infz(i) infinite elementary divisors of - degree i in the Smith form, where i = 1,2,...,DINFZ. - kronr : rank-1 array('i') - The leading NKROR elements of this array contain the - right Kronecker (column) indices. - infe : rank-1 array('i') - The leading NINFE elements of infe contain the - multiplicities of infinite eigenvalues. + Parameters + ---------- + l : int + The number of rows of matrices A, B, and E. l >= 0. + n : int + The number of columns of matrices A, E, and C. n >= 0. + m : int + The number of columns of matrix B. m >= 0. + p : int + The number of rows of matrix C. p >= 0. + A : (l, n) array_like + The leading l-by-n part of this array must + contain the state dynamics matrix A of the system. + E : (l, n) array_like + The leading l-by-n part of this array must + contain the descriptor matrix E of the system. + B : (l, m) array_like + The leading l-by-m part of this array must + contain the input/state matrix B of the system. + C : (p, n) array_like + The leading p-by-n part of this array must + contain the state/output matrix C of the system. + D : (p, m) array_like + The leading p-by-m part of this array must contain the + direct transmission matrix D of the system. + equil : {'S', 'N'}, optional + Specifies whether the user wishes to balance the system + matrix as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + Default is `N` + tol : float, optional + A tolerance used in rank decisions to determine the + effective rank, which is defined as the order of the + largest leading (or trailing) triangular submatrix in the + QR (or RQ) factorization with column (or row) pivoting + whose estimated condition number is less than 1/TOL. + If the user sets TOL <= 0, then default tolerances are + used instead, as follows: TOLDEF = L*N*EPS in TG01FD + (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS + in the rest, where EPS is the machine precision + (see LAPACK Library routine DLAMCH). TOL < 1. + Default is 0. + ldwork : int, optional + The length of the cache array. + ldwork >= max( 4*(l,n), ldw ), if equil = 'S', + ldwork >= ldw, if equil = 'N', where + ldw = max(l+p,m+n)*(m+n) + max(1,5*max(l+p,m+n)). + For optimum performance ldwork should be larger. + Default is None. + + Returns + ------- + Af : (nfz, nfz) ndarray + the leading NFZ-by-NFZ part of this array + contains the matrix Af of the reduced pencil. + Ef : (nfz, nfz) ndarray + the leading NFZ-by-NFZ part of this array + contains the matrix Ef of the reduced pencil. + nrank : int + The normal rank of the system pencil. + niz : int + The number of infinite zeros. + infz : (n+1, ) ndarray + Contains information on the infinite elementary divisors. + kronr : (n+m+1, ) ndarray + Contains the right Kronecker (column) indices. + infe : (1+min(l+p,n+m), ) ndarray + Contains the multiplicities of infinite eigenvalues. """ hidden = ' (hidden by the wrapper)' arg_list = ['equil', 'l', 'n', 'm', 'p', From c62a10a7424a554c7b29dd51d018c451b585c951 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sat, 9 Sep 2023 15:24:45 +0200 Subject: [PATCH 366/405] Add sb10jd routines __init__.py --- slycot/__init__.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index 120bdedb..caeda4bf 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -54,12 +54,12 @@ # Nonlinear Systems (0/16 wrapped) - # Synthesis routines ((16+1)/131 wrapped), sb03md57 is not part of slicot + # Synthesis routines ((17+1)/131 wrapped), sb03md57 is not part of slicot from .synthesis import (sb01bd, sb02md, sb02mt, sb02od, sb03md, sb03md57, sb03od, sb04md, sb04qd, - sb10ad, sb10dd, sb10fd, sb10hd, sb10yd, + sb10ad, sb10dd, sb10fd, sb10hd, sb10jd, sb10yd, sg02ad, sg03ad, sg03bd) From cbd4435f1995ea47f92be14eae623e2dbd729c2d Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sat, 26 Aug 2023 21:10:30 +0200 Subject: [PATCH 367/405] Change synthesis.py docstrings to numpydoc style --- slycot/synthesis.py | 39 +++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/slycot/synthesis.py b/slycot/synthesis.py index 5f4e06e2..2b9fbf9b 100644 --- a/slycot/synthesis.py +++ b/slycot/synthesis.py @@ -58,9 +58,10 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): := 'C': continuous-time system; := 'D': discrete-time system. tol : float, optional - The absolute tolerance level below which the elements of A or B are - considered zero (used for controllability tests). - If tol <= 0 the default value is used. + The absolute tolerance level below which the elements of A or B are + considered zero (used for controllability tests). + If tol <= 0 the default value is used. + Default is `0.0`. ldwork : int, optional The length of the cache array. The default value is max(1,5*m,5*n,2*n+4*m), for optimum performance it should be larger. @@ -128,7 +129,6 @@ def sb01bd(n,m,np,alpha,A,B,w,dico,tol=0.0,ldwork=None): Example ------- - >>> import numpy as np >>> import slycot >>> A = np.array([[0, 1, 0], [0, 0, 1], [-2, 1, 3]]) @@ -281,8 +281,6 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): Raises ------ - SlycotParameterError - :info = -i: the i-th argument had an illegal value; SlycotArithmeticError :info = 1: Matrix A is (numerically) singular in discrete- @@ -304,7 +302,6 @@ def sb02md(n,A,G,Q,dico,hinv='D',uplo='U',scal='N',sort='S',ldwork=None): Example ------- - >>> import numpy as np >>> import slycot >>> A = np.array([[0, 1], [0, 0]]) @@ -622,7 +619,6 @@ def sb02od(n,m,A,B,Q,R,dico,p=None,L=None,fact='N',uplo='U',sort='S',tol=0.0,ldw Example ------- - >>> import numpy as np >>> import slycot >>> A = np.array([[0, 1], [0, 0]]) @@ -707,7 +703,7 @@ def sb03md57(A, U=None, C=None, C : (n, n) array_like If job = 'X' or 'B', this array must contain the symmetric matrix C. If job = 'S', C is not referenced. - dico : {'C', 'D'} + dico : {'C', 'D'}, optional Specifies the equation from which X is to be determined as follows: := 'C': Equation (1), continuous-time case; := 'D': Equation (2), discrete-time case. @@ -905,7 +901,7 @@ def sb03od(n,m,A,Q,B,dico,fact='N',trans='N',ldwork=None): For optimum performance ldwork should sometimes be larger. Returns - _______ + ------- U : (n, n) ndarray The leading n-by-n part of this array contains the upper triangular Cholesky factor U of the solution @@ -1019,6 +1015,9 @@ def sb04md(n,m,A,B,C,ldwork=None): Matrix B C : (n, m) array_like Matrix C + ldwork : int, optional + The length of the array DWORK. + Default is None. Returns ------- @@ -1068,6 +1067,9 @@ def sb04qd(n,m,A,B,C,ldwork=None): Matrix B C : (n, m) array_like Matrix C + ldwork : int, optional + The length of the array DWORK. + Default is None. Returns ------- @@ -1743,9 +1745,9 @@ def sb10yd(discfl,flag,lendat,rfrdat,ifrdat,omega,n,tol,ldwork=None): n : int On entry, the desired order of the system to be fitted. n <= lendat-1. - tol : int, optional + tol : int The length of the cache array. - ldwork : int + ldwork : int, optional With None it will be automatically calculated. For details see SLICOT help. @@ -2206,6 +2208,7 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; LDR >= 1 if JOBB = 'G'. + L : (n, M) array_like If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of this array must contain the cross weighting matrix L. @@ -2217,6 +2220,7 @@ def sg02ad(dico,jobb,fact,uplo,jobl,scal,sort,acc,N,M,P,A,E,B,Q,R,L,ldwork=None, LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. + For optimum performance LDWORK should be larger. Default: ``max(7*(2*n+1)+16,16*n)`` tol : float, optional @@ -2432,7 +2436,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): than one). Parameters - __________ + ---------- n : int The order of the matrix A. n >= 0. m : int @@ -2495,11 +2499,13 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): on entry or not: := 'N': Factorization is not supplied; := 'F': Factorization is supplied. + Default is 'N'. trans : {'N', 'T'}, optional Specifies whether the transposed equation is to be solved or not: := 'N': op(A) = A, op(E) = E; := 'T': op(A) = A**T, op(E) = E**T. + Default is 'N'. ldwork : int, optional The dimension of the array dwork:: @@ -2508,7 +2514,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): For good performance, ldwork should be larger. Returns - _______ + ------- U : (n, n) ndarray The leading n-by-b part of this array contains the Cholesky factor U of the solution matrix X of the @@ -2521,6 +2527,7 @@ def sg03bd(n,m,A,E,Q,Z,B,dico,fact='N',trans='N',ldwork=None): If INFO = 0, 3, 5, 6, or 7, then ((j), j=1,...,n, are the eigenvalues of the matrix pencil A - lambda * E. + Default is None. Raises ------ @@ -2647,7 +2654,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): whose reciprocal condition numbers are less than tol are not allowed. If tol <= 0, then a default value equal to sqrt(eps) is used, where eps is the relative machine - precision. + precision. Default is `0.0`. ldwork : int, optional The dimension of the cache array:: @@ -2683,7 +2690,7 @@ def sb10fd(n,m,np,ncon,nmeas,gamma,A,B,C,D,tol=0.0,ldwork=None): if the default (None) value is used, the size for good performance is automatically used, when ldwork is set to zero, the minimum - cache size will be used. + cache size will be used. Default is None. Returns ------- From 91baf0ef8ffdc895ebb3be47bcef6a73c58318ab Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sun, 27 Aug 2023 10:42:34 +0200 Subject: [PATCH 368/405] Change math.py docstrings to numpydoc style --- slycot/math.py | 170 +++++++++++++++++++++++-------------------------- 1 file changed, 78 insertions(+), 92 deletions(-) diff --git a/slycot/math.py b/slycot/math.py index d7447047..5966458b 100644 --- a/slycot/math.py +++ b/slycot/math.py @@ -137,80 +137,80 @@ def mb03rd(n, A, X=None, jobx='U', sort='N', pmax=1.0, tol=0.0): Parameters ---------- - n : int - The order of the matrices `A` and `X`. `n` >= 0. - A : (n, n) array_like - The matrix `A` to be block-diagonalized, in real Schur form. - X : (n, n) array_like, optional - A given matrix `X`, for accumulation of transformations (only if - `jobx`='U'). Default value is identity matrix of order `n`. - jobx : {'N', 'U'}, optional - Specifies whether or not the transformations are - accumulated, as follows: - - := 'N': The transformations are not accumulated - := 'U': The transformations are accumulated in `Xr` (default) - - sort : {'N', 'S', 'C', 'B'}, optional - Specifies whether or not the diagonal blocks of the real - Schur form are reordered, as follows: - - := 'N': The diagonal blocks are not reordered (default); - := 'S': The diagonal blocks are reordered before each - step of reduction, so that clustered eigenvalues - appear in the same block; - := 'C': The diagonal blocks are not reordered, but the - "closest-neighbour" strategy is used instead of - the standard "closest to the mean" strategy - (see Notes_); - := 'B': The diagonal blocks are reordered before each - step of reduction, and the "closest-neighbour" - strategy is used (see Notes_). - - pmax : float, optional - An upper bound for the infinity norm of elementary - submatrices of the individual transformations used for - reduction (see Notes_). `pmax` >= 1.0 - tol : float, optional - The tolerance to be used in the ordering of the diagonal - blocks of the real Schur form matrix. - If the user sets `tol` > 0, then the given value of `tol` is - used as an absolute tolerance: a block `i` and a temporarily - fixed block 1 (the first block of the current trailing - submatrix to be reduced) are considered to belong to the - same cluster if their eigenvalues satisfy - - .. math:: | \\lambda_1 - \\lambda_i | <= tol. - - If the user sets `tol` < 0, then the given value of tol is - used as a relative tolerance: a block i and a temporarily - fixed block 1 are considered to belong to the same cluster - if their eigenvalues satisfy, for ``j = 1, ..., n`` - - .. math:: | \\lambda_1 - \\lambda_i | <= | tol | * \\max | \\lambda_j |. - - If the user sets `tol` = 0, then an implicitly computed, - default tolerance, defined by ``tol = SQRT( SQRT( EPS ) )`` - is used instead, as a relative tolerance, where `EPS` is - the machine precision (see LAPACK Library routine DLAMCH). - If `sort` = 'N' or 'C', this parameter is not referenced. + n : int + The order of the matrices `A` and `X`. `n` >= 0. + A : (n, n) array_like + The matrix `A` to be block-diagonalized, in real Schur form. + X : (n, n) array_like, optional + A given matrix `X`, for accumulation of transformations (only if + `jobx`='U'). Default value is identity matrix of order `n`. + jobx : {'N', 'U'}, optional + Specifies whether or not the transformations are + accumulated, as follows: + + := 'N': The transformations are not accumulated + := 'U': The transformations are accumulated in `Xr` (default) + + sort : {'N', 'S', 'C', 'B'}, optional + Specifies whether or not the diagonal blocks of the real + Schur form are reordered, as follows: + + := 'N': The diagonal blocks are not reordered (default); + := 'S': The diagonal blocks are reordered before each + step of reduction, so that clustered eigenvalues + appear in the same block; + := 'C': The diagonal blocks are not reordered, but the + "closest-neighbour" strategy is used instead of + the standard "closest to the mean" strategy + (see Notes_); + := 'B': The diagonal blocks are reordered before each + step of reduction, and the "closest-neighbour" + strategy is used (see Notes_). + + pmax : float, optional + An upper bound for the infinity norm of elementary + submatrices of the individual transformations used for + reduction (see Notes_). `pmax` >= 1.0 + tol : float, optional + The tolerance to be used in the ordering of the diagonal + blocks of the real Schur form matrix. + If the user sets `tol` > 0, then the given value of `tol` is + used as an absolute tolerance: a block `i` and a temporarily + fixed block 1 (the first block of the current trailing + submatrix to be reduced) are considered to belong to the + same cluster if their eigenvalues satisfy + + .. math:: | \\lambda_1 - \\lambda_i | <= tol. + + If the user sets `tol` < 0, then the given value of tol is + used as a relative tolerance: a block i and a temporarily + fixed block 1 are considered to belong to the same cluster + if their eigenvalues satisfy, for ``j = 1, ..., n`` + + .. math:: | \\lambda_1 - \\lambda_i | <= | tol | * \\max | \\lambda_j |. + + If the user sets `tol` = 0, then an implicitly computed, + default tolerance, defined by ``tol = SQRT( SQRT( EPS ) )`` + is used instead, as a relative tolerance, where `EPS` is + the machine precision (see LAPACK Library routine DLAMCH). + If `sort` = 'N' or 'C', this parameter is not referenced. Returns ------- - Ar : (n, n) ndarray - Contains the computed block-diagonal matrix, in real Schur - canonical form. The non-diagonal blocks are set to zero. - Xr : (n, n) ndarray or None - Contains the product of the given matrix `X` and the - transformation matrix that reduced `A` to block-diagonal - form. The transformation matrix is itself a product of - non-orthogonal similarity transformations having elements - with magnitude less than or equal to `pmax`. - If `jobx` = 'N', this array is returned as None - blsize : (n,) ndarray - The orders of the resulting diagonal blocks of the matrix `Ar`. - W : (n,) complex ndarray - Contains the complex eigenvalues of the matrix `A`. + Ar : (n, n) ndarray + Contains the computed block-diagonal matrix, in real Schur + canonical form. The non-diagonal blocks are set to zero. + Xr : (n, n) ndarray or None + Contains the product of the given matrix `X` and the + transformation matrix that reduced `A` to block-diagonal + form. The transformation matrix is itself a product of + non-orthogonal similarity transformations having elements + with magnitude less than or equal to `pmax`. + If `jobx` = 'N', this array is returned as None + blsize : (n,) ndarray + The orders of the resulting diagonal blocks of the matrix `Ar`. + W : (n,) complex ndarray + Contains the complex eigenvalues of the matrix `A`. Notes ----- @@ -361,11 +361,9 @@ def mb03vd(n, ilo, ihi, A): Parameters ---------- - n : int The order of the square matrices A_1, A_2, ..., A_p. n >= 0. - ilo, ihi : int It is assumed that all matrices A_j, j = 2, ..., p, are already upper triangular in rows and columns [:ilo-1] and @@ -375,15 +373,12 @@ def mb03vd(n, ilo, ihi, A): If this is not the case, ilo and ihi should be set to 1 and n, respectively. 1 <= ilo <= max(1,n); min(ilo,n) <= ihi <= n. - A : ndarray A[:n,:n,:p] must contain the matrices of factors to be reduced; specifically, A[:,:,j-1] must contain A_j, j = 1, ..., p. - Returns ------- - HQ : ndarray 3D array with same shape as A. The upper triangle and the first subdiagonal of HQ[:n,:n,0] contain the upper Hessenberg @@ -396,16 +391,14 @@ def mb03vd(n, ilo, ihi, A): below the diagonal, with the j-th column of the array TAU represent the orthogonal matrix Q_j as a product of elementary reflectors. See FURTHER COMMENTS. - Tau : ndarray 2D array with shape (max(1, n-1), p). The leading n-1 elements in the j-th column contain the scalar factors of the elementary reflectors used to form the matrix Q_j, j = 1, ..., p. See FURTHER COMMENTS. - Further Comments - ---------------- - + Notes + ----- Each matrix Q_j is represented as a product of (ihi-ilo) elementary reflectors, @@ -478,26 +471,21 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): Parameters ---------- - n : int The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. - ilo, ihi : int The values of the indices ilo and ihi, respectively, used in the previous call of the SLICOT Library routine MB03VD. 1 <= ilo <= max(1,n); min(ilo,n) <= ihi <= n. - A : ndarray A[:n,:n,j-1] must contain the vectors which define the elementary reflectors used for reducing A_j, as returned by SLICOT Library routine MB03VD, j = 1, ..., p. - Tau : ndarray The leading N-1 elements in the j-th column must contain the scalar factors of the elementary reflectors used to form the matrix Q_j, as returned by SLICOT Library routine MB03VD. - ldwork : int, optional The length of the internal array DWORK. ldwork >= max(1, n). For optimum performance ldwork should be larger. @@ -505,11 +493,9 @@ def mb03vy(n, ilo, ihi, A, Tau, ldwork=None): Returns ------- - Q : ndarray 3D array with same shape as A. Q[:n,:n,j-1] contains the N-by-N orthogonal matrix Q_j, j = 1, ..., p. - """ hidden = ' (hidden by the wrapper)' @@ -561,7 +547,7 @@ def mb03wd(job, compz, n, ilo, ihi, iloz, ihiz, H, Q, ldwork=None): = 'E': Compute the eigenvalues only; = 'S': Compute the factors T_1, ..., T_p of the full Schur form, T = T_1*T_2*...*T_p. - compz : {'N', 'I', 'V'} + compz : {'N', 'I', 'V'} Indicates whether or not the user wishes to accumulate the matrices Z_1, ..., Z_p, as follows: = 'N': The matrices Z_1, ..., Z_p are not required; @@ -776,9 +762,10 @@ def mb05nd(a, delta, tol=1e-7): Square matrix delta : float The scalar value delta of the problem. - tol : float - Tolerance. A good value is sqrt(eps) - + tol : float, optional + Tolerance. A good value is sqrt(eps). + Default is 1e-7. + Returns ------- F : (n, n) ndarray @@ -831,7 +818,6 @@ def mc01td(dico, dp, p): = 'C': continuous-time case; = 'D': discrete-time case. - dp : int The degree of the polynomial `P(x)`. ``dp >= 0``. p : (dp+1, ) array_like From 356cd445fb88f3581514bfe2e9c6db9220ef76e9 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Thu, 31 Aug 2023 22:07:32 +0200 Subject: [PATCH 369/405] Add tg01ad, tg01fd routines to __init__.py --- slycot/__init__.py | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index caeda4bf..f2ba5270 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -62,15 +62,17 @@ sb10ad, sb10dd, sb10fd, sb10hd, sb10jd, sb10yd, sg02ad, sg03ad, sg03bd) - - # Transformation routines (10/77 wrapped) + + # Transformation routines (12/77 wrapped) from .transform import (tb01id, tb01pd, tb03ad, tb04ad, tb05ad, - tc01od, tc04ad, + tc01od, + tc04ad, td04ad, - tf01md, tf01rd) + tf01md, tf01rd, + tg01ad, tg01fd) # Utility routines (0/7 wrapped) From 8b9c1ec7a0527dbb9bdd473c83082e6a67318047 Mon Sep 17 00:00:00 2001 From: Johannes Kaisinger Date: Sun, 27 Aug 2023 11:32:22 +0200 Subject: [PATCH 370/405] Change transformation.py doscstrings to numpydoc style --- slycot/transform.py | 1342 ++++++++++++++++++++++--------------------- 1 file changed, 686 insertions(+), 656 deletions(-) diff --git a/slycot/transform.py b/slycot/transform.py index a3d298f9..43762b5a 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -43,55 +43,55 @@ def tb01id(n,m,p,maxred,a,b,c,job='A'): S = A, S = ( A B ) or S = ( A ) ( C ) - - Required arguments: - n : input int - The order of the matrix A, the number of rows of matrix B and - the number of columns of matrix C. It represents the dimension of - the state vector. n > 0. - m : input int - The number of columns of matrix B. It represents the dimension of - the input vector. m > 0. - p : input int - The number of rows of matrix C. It represents the dimension of - the output vector. p > 0. - maxred : input float - The maximum allowed reduction in the 1-norm of S (in an iteration) - if zero rows or columns are encountered. - If maxred > 0.0, maxred must be larger than one (to enable the norm - reduction). - If maxred <= 0.0, then the value 10.0 for maxred is used. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the system state - matrix A. - B : input rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array must contain the system input - matrix B. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the system output - matrix C. - Optional arguments: - job := 'A' input string(len=1) - Indicates which matrices are involved in balancing, as follows: - = 'A': All matrices are involved in balancing; - = 'B': B and A matrices are involved in balancing; - = 'C': C and A matrices are involved in balancing; - = 'N': B and C matrices are not involved in balancing. - Return objects: - s_norm : float - The 1-norm of the given matrix S is non-zero, the ratio between - the 1-norm of the given matrix and the 1-norm of the balanced matrix. - A : rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array contains the balanced matrix - inv(D)*A*D. - B : rank-2 array('d') with bounds (n,m) - The leading n-by-m part of this array contains the balanced matrix - inv(D)*B. - C : rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array contains the balanced matrix C*D. - scale : rank-1 array('d') with bounds (n) - The scaling factors applied to S. If D(j) is the scaling factor - applied to row and column j, then scale(j) = D(j), for j = 1,...,n. + Parameters + ---------- + n : int + The order of the matrix A, the number of rows of matrix B and + the number of columns of matrix C. It represents the dimension of + the state vector. n > 0. + m : int + The number of columns of matrix B. It represents the dimension of + the input vector. m > 0. + p : int + The number of rows of matrix C. It represents the dimension of + the output vector. p > 0. + maxred : float + The maximum allowed reduction in the 1-norm of S (in an iteration) + if zero rows or columns are encountered. + If maxred > 0.0, maxred must be larger than one (to enable the norm + reduction). + If maxred <= 0.0, then the value 10.0 for maxred is used. + A : (n, n) array_like + The leading n-by-n part of this array must contain the system state + matrix A. + B : (n, m) array_like + The leading n-by-m part of this array must contain the system input + matrix B. + C : (p, n) array_like + The leading p-by-n part of this array must contain the system output + matrix C. + job := {'A', 'B', 'C', 'N'}, optional + Indicates which matrices are involved in balancing, as follows: + = 'A': All matrices are involved in balancing; + = 'B': B and A matrices are involved in balancing; + = 'C': C and A matrices are involved in balancing; + = 'N': B and C matrices are not involved in balancing. + Returns + ------- + s_norm : float + The 1-norm of the given matrix S is non-zero, the ratio between + the 1-norm of the given matrix and the 1-norm of the balanced matrix. + A : (n, n) ndarray + The leading n-by-n part of this array contains the balanced matrix + inv(D)*A*D. + B : (n, m) ndarray + The leading n-by-m part of this array contains the balanced matrix + inv(D)*B. + C : (p ,n) ndarray + The leading p-by-n part of this array contains the balanced matrix C*D. + scale : rank-1 array('d') with bounds (n) + The scaling factors applied to S. If D(j) is the scaling factor + applied to row and column j, then scale(j) = D(j), for j = 1,...,n. """ hidden = ' (hidden by the wrapper)' arg_list = ['job', 'N', 'M', 'P', 'maxred', 'A', 'LDA'+hidden, 'B', @@ -100,6 +100,98 @@ def tb01id(n,m,p,maxred,a,b,c,job='A'): raise_if_slycot_error(out[-1], arg_list) return out[:-1] +def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): + """Ar, Br, Cr, nr = tb01pd(n,m,p,A,B,C,[job,equil,tol,ldwork]) + + To find a reduced (controllable, observable, or minimal) state- + space representation (Ar,Br,Cr) for any original state-space + representation (A,B,C). The matrix Ar is in upper block + Hessenberg form. + + Parameters + ---------- + n : int + Order of the State-space representation. + m : int + Number of inputs. + p : int + Number of outputs. + A : (n, n) array_like + State dynamics matrix. + B : (n, max(m,p)) array_like + The leading n-by-m part of this array must contain the original + input/state matrix B; the remainder of the leading n-by-max(m,p) + part is used as internal workspace. + C : (p, n) array_like + The leading p-by-n part of this array must contain the original + state/output matrix C; the remainder of the leading max(1,m,p)-by-n + part is used as internal workspace. + job : {'M', 'C', 'O'}, optional + Indicates whether the user wishes to remove the + uncontrollable and/or unobservable parts as follows: + = 'M': Remove both the uncontrollable and unobservable + parts to get a minimal state-space representation; + = 'C': Remove the uncontrollable part only to get a + controllable state-space representation; + = 'O': Remove the unobservable part only to get an + observable state-space representation. + Default is 'M'. + equil : {'S', 'N'}, optional + Specifies whether the user wishes to preliminarily balance + the triplet (A,B,C) as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + tol : float, optional + The tolerance to be used in rank determination when + transforming (A, B, C). If the user sets tol > 0, then + the given value of tol is used as a lower bound for the + reciprocal condition number. + Default is `1e-8`. + ldwork : int, optional + The length of the cache array. + ldwork >= max( 1, n + max(n, 3*m, 3*p)) + Default is None. + + Returns + ------- + Ar : (nr, nr) ndarray + Contains the upper block Hessenberg state dynamics matrix + Ar of a minimal, controllable, or observable realization + for the original system, depending on the value of JOB, + JOB = 'M', JOB = 'C', or JOB = 'O', respectively. + Br : (nr, m) ndarray + Contains the transformed input/state matrix Br of a + minimal, controllable, or observable realization for the + original system, depending on the value of JOB, JOB = 'M', + JOB = 'C', or JOB = 'O', respectively. If JOB = 'C', only + the first IWORK(1) rows of B are nonzero. + Cr : (p, nr) ndarray + Contains the transformed state/output matrix Cr of a + minimal, C controllable, or observable realization for the + original C system, depending on the value of JOB, JOB = + 'M', C JOB = 'C', or JOB = 'O', respectively. C If JOB = + 'M', or JOB = 'O', only the last IWORK(1) columns C (in + the first NR columns) of C are nonzero. + nr : int + The order of the reduced state-space representation + (Ar,Br,Cr) of a minimal, controllable, or observable + realization for the original system, depending on + JOB = 'M', JOB = 'C', or JOB = 'O'. + """ + hidden = ' (hidden by the wrapper)' + arg_list = ['job', 'equil', 'n','m','p','A','lda'+hidden,'B','ldb'+hidden, + 'C','ldc'+hidden,'nr','tol','iwork'+hidden,'dwork'+hidden, + 'ldwork','info'+hidden] + if ldwork is None: + ldwork = max(1, n+max(n,3*m,3*p)) + elif ldwork < max(1, n+max(n,3*m,3*p)): + raise SlycotParameterError("ldwork is too small", -15) + out = _wrapper.tb01pd(n=n,m=m,p=p,a=A,b=B,c=C, + job=job,equil=equil,tol=tol,ldwork=ldwork) + + raise_if_slycot_error(out[-1], arg_list) + return out[:-1] + def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): """ A_min,b_min,C_min,nr,index,pcoeff,qcoeff,vcoeff = tb03ad_l(n,m,p,A,B,C,D,leri,[equil,tol,ldwork]) @@ -116,90 +208,98 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): Additionally a minimal realization (A_min,B_min,C_min) of the original system (A,B,C) is returned. - Required arguments: - n : input int - The order of the state-space representation, i.e. the order of - the original state dynamics matrix A. n > 0. - m : input int - The number of system inputs. m > 0. - p : input int - The number of system outputs. p > 0. - A : input rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array must contain the original - state dynamics matrix A. - B : input rank-2 array('d') with bounds (n,max(m,p)) - The leading n-by-m part of this array must contain the original - input/state matrix B; the remainder of the leading n-by-max(m,p) - part is used as internal workspace. - C : input rank-2 array('d') with bounds (max(m,p),n) - The leading p-by-n part of this array must contain the original - state/output matrix C; the remainder of the leading max(m,p)-by-n - part is used as internal workspace. - D : input rank-2 array('d') with bounds (max(m,p),max(m,p)) - The leading p-by-m part of this array must contain the original - direct transmission matrix D; the remainder of the leading - max(m,p)-by-max(m,p) part is used as internal workspace. - leri : input string(len=1) - Indicates whether the left polynomial matrix representation or - the right polynomial matrix representation is required. - Optional arguments: - equil := 'N' input string(len=1) - Specifies whether the user wishes to balance the triplet (A,B,C), - before computing a minimal state-space representation, as follows: - = 'S': Perform balancing (scaling); - = 'N': Do not perform balancing. - tol := 0.0 input float - The tolerance to be used in rank determination when transforming - (A, B). If tol <= 0 a default value is used. - ldwork := max(2*n+3*max(m,p), p*(p+2)) input int - The length of the cache array. - ldwork >= max( n + max(n, 3*m, 3*p), pm*(pm + 2)) - where pm = p, if leri = 'L'; - pm = m, if leri = 'R'. - For optimum performance it should be larger. - Return objects: - A_min : rank-2 array('d') with bounds (n,n) - The leading nr-by-nr part of this array contains the upper block - Hessenberg state dynamics matrix A_min of a minimal realization for - the original system. - B_min : rank-2 array('d') with bounds (n,max(m,p)) - The leading nr-by-m part of this array contains the transformed - input/state matrix B_min. - C_min : rank-2 array('d') with bounds (max(m,p),n) - The leading p-by-nr part of this array contains the transformed - state/output matrix C_min. - nr : int - The order of the minimal state-space representation - (A_min,B_min,C_min). - index : rank-1 array('i') with bounds either (p) or (m) - If leri = 'L', index(i), i = 1,2,...,p, contains the maximum degree - of the polynomials in the i-th row of the denominator matrix P(s) - of the left polynomial matrix representation. These elements are - ordered so that index(1) >= index(2) >= ... >= index(p). - If leri = 'R', index(i), i = 1,2,...,m, contains the maximum degree - of the polynomials in the i-th column of the denominator matrix P(s) - of the right polynomial matrix representation. These elements are - ordered so that index(1) >= index(2) >= ... >= index(m). - pcoeff : rank-3 array('d') with bounds either (p,p,n+1) or (m,m,n+1) - If leri = 'L' then porm = p, otherwise porm = m. - The leading porm-by-porm-by-kpcoef part of this array contains - the coefficients of the denominator matrix P(s), where - kpcoef = max(index) + 1. - pcoeff(i,j,k) is the coefficient in s**(index(iorj)-k+1) of - polynomial (i,j) of P(s), where k = 1,2,...,kpcoef; if leri = 'L' - then iorj = I, otherwise iorj = J. Thus for leri = 'L', - P(s) = diag(s**index)*(pcoeff(.,.,1)+pcoeff(.,.,2)/s+...). - qcoeff : rank-3 array('d') with bounds (p,m,n + 1) or (max(m,p),max(m,p)) - If leri = 'L' then porp = m, otherwise porp = p. - If leri = 'L', the leading porm-by-porp-by-kpcoef part of this array - contains the coefficients of the numerator matrix Q(s). - If leri = 'R', the leading porp-by-porm-by-kpcoef part of this array - contains the coefficients of the numerator matrix Q(s). - qcoeff(i,j,k) is defined as for pcoeff(i,j,k). - vcoeff : rank-3 array('d') with bounds (p,n,n+1) or (m,n,n+1) - The leading porm-by-nr-by-kpcoef part of this array contains - the coefficients of the intermediate matrix V(s). - vcoeff(i,j,k) is defined as for pcoeff(i,j,k). + Parameters + ---------- + n : int + The order of the state-space representation, i.e. the order of + the original state dynamics matrix A. n > 0. + m : int + The number of system inputs. m > 0. + p : int + The number of system outputs. p > 0. + A : (n, n) array_like + The leading n-by-n part of this array must contain the original + state dynamics matrix A. + B : (n, max(m,p)) array_like + The leading n-by-m part of this array must contain the original + input/state matrix B; the remainder of the leading n-by-max(m,p) + part is used as internal workspace. + C : (max(m,p), n) + The leading p-by-n part of this array must contain the original + state/output matrix C; the remainder of the leading max(m,p)-by-n + part is used as internal workspace. + D : (max(m,p), max(m,p)) array_like + The leading p-by-m part of this array must contain the original + direct transmission matrix D; the remainder of the leading + max(m,p)-by-max(m,p) part is used as internal workspace. + leri : {'L', 'R'} + Indicates whether the left polynomial matrix representation or + the right polynomial matrix representation is required. + = 'L': A left matrix fraction is required; + = 'R': A right matrix fraction is required. + equil : {'S', 'N'}, optional + Specifies whether the user wishes to balance the triplet (A,B,C), + before computing a minimal state-space representation, as follows: + = 'S': Perform balancing (scaling); + = 'N': Do not perform balancing. + Default is `N`. + tol : float, optional + The tolerance to be used in rank determination when transforming + (A, B). If tol <= 0 a default value is used. + Default is `0.0`. + ldwork : int, optional + The length of the cache array. + ldwork >= max( n + max(n, 3*m, 3*p), pm*(pm + 2)) + where pm = p, if leri = 'L'; + pm = m, if leri = 'R'. + For optimum performance it should be larger. + Default is None. + + Returns + ------- + A_min : (n, n) ndarray + The leading nr-by-nr part of this array contains the upper block + Hessenberg state dynamics matrix A_min of a minimal realization for + the original system. + B_min : (n, max(m,p)) ndarray + The leading nr-by-m part of this array contains the transformed + input/state matrix B_min. + C_min : (max(m,p), n) ndarray + The leading p-by-nr part of this array contains the transformed + state/output matrix C_min. + nr : int + The order of the minimal state-space representation + (A_min,B_min,C_min). + index : (p, ) or (m, ) ndarray + If leri = 'L', index(i), i = 1,2,...,p, contains the maximum degree + of the polynomials in the i-th row of the denominator matrix P(s) + of the left polynomial matrix representation. These elements are + ordered so that index(1) >= index(2) >= ... >= index(p). + If leri = 'R', index(i), i = 1,2,...,m, contains the maximum degree + of the polynomials in the i-th column of the denominator matrix P(s) + of the right polynomial matrix representation. These elements are + ordered so that index(1) >= index(2) >= ... >= index(m). + pcoeff : (p, p, n+1) or (m, m, n+1) ndarray + If leri = 'L' then porm = p, otherwise porm = m. + The leading porm-by-porm-by-kpcoef part of this array contains + the coefficients of the denominator matrix P(s), where + kpcoef = max(index) + 1. + pcoeff(i,j,k) is the coefficient in s**(index(iorj)-k+1) of + polynomial (i,j) of P(s), where k = 1,2,...,kpcoef; if leri = 'L' + then iorj = I, otherwise iorj = J. Thus for leri = 'L', + P(s) = diag(s**index)*(pcoeff(.,.,1)+pcoeff(.,.,2)/s+...). + qcoeff : (p, m, n+1) or (max(m,p), max(m,p), n+1) ndarray + If leri = 'L' then porp = m, otherwise porp = p. + If leri = 'L', the leading porm-by-porp-by-kpcoef part of this array + contains the coefficients of the numerator matrix Q(s). + If leri = 'R', the leading porp-by-porm-by-kpcoef part of this array + contains the coefficients of the numerator matrix Q(s). + qcoeff(i,j,k) is defined as for pcoeff(i,j,k). + vcoeff : (p, n, n+1) or (m, n, n+1) ndarray + The leading porm-by-nr-by-kpcoef part of this array contains + the coefficients of the intermediate matrix V(s). + vcoeff(i,j,k) is defined as for pcoeff(i,j,k). + Raises ------ SlycotArithmeticError @@ -209,7 +309,6 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): :info == 2: A singular matrix was encountered during the computation of P(s). - """ hidden = ' (hidden by the wrapper)' arg_list = ['leri', 'equil', 'n', 'm', 'P', 'A', 'LDA'+hidden, 'B', @@ -233,58 +332,54 @@ def tb03ad(n,m,p,A,B,C,D,leri,equil='N',tol=0.0,ldwork=None): def tb04ad(n,m,p,A,B,C,D,tol1=0.0,tol2=0.0,ldwork=None): """ Ar,Br,Cr,nr,denom_degs,denom_coeffs,num_coeffs = tb04ad(n,m,p,A,B,C,D,[tol1,tol2,ldwork]) - Convert a state-space system to a tranfer function or matrix of transfer functions. + Convert a state-space system to a transfer function or matrix of transfer functions. The transfer function is given as rows over common denominators. - Required arguments - ------------------ - - n : integer - state dimension - m : integer - input dimension - p : integer - output dimension - A : rank-2 array, shape(n,n) - state dynamics matrix. - B : rank-2 array, shape (n,m) - input matrix - C : rank-2 array, shape (p,n) - output matri - D : rank-2 array, shape (p,m) - direct transmission matrix - - Optional arguments - ------------------ - - tol1 = 0.0: double - tolerance in determining the transfer function coefficients, - when set to 0, a default value is used - tol2 = 0.0: double - tolerance in separating out a controllable/observable subsystem - of (A,B,C), when set to 0, a default value is used - ldwork : int - The length of the cache array. The default values is - max(1,n*(n+1)+max(n*m+2*n+max(n,p),max(3*m,p))) - - Returns - ------- - - nr : int - state dimension of the controllable subsystem - Ar : rank-2 array, shape(nr,nr) - state dynamics matrix of the controllable subsystem - Br : rank-2 array, shape (nr,m) - input matrix of the controllable subsystem - Cr : rank-2 array, shape (p,nr) - output matri of the controllable subsystem - index : rank-1 array, shape (p) - array of orders of the denominator polynomials - dcoeff : rank-2 array, shape (p,max(index)+1) - array of denominator coefficients - ucoeff : rank-3 array, shape (p,m,max(index)+1) - array of numerator coefficients + Parameters + ---------- + n : int + state dimension + m : int + input dimension + p : int + output dimension + A : (n, n) array_like + state dynamics matrix. + B : (n, m) array_like + input matrix + C : (p, n) array_like + output matrix + D : (p, m) array_like + direct transmission matrix + tol1 : float, optional + tolerance in determining the transfer function coefficients, + when set to 0, a default value is used + Default is `0.0`. + tol2 : float, optional + tolerance in separating out a controllable/observable subsystem + of (A,B,C), when set to 0, a default value is used + Default is `0.0`. + ldwork : int, optional + The length of the cache array. The default values is + max(1,n*(n+1)+max(n*m+2*n+max(n,p),max(3*m,p))) + Default is None. + Returns + ------- + nr : int + state dimension of the controllable subsystem + Ar : (nr, nr) ndarray + state dynamics matrix of the controllable subsystem + Br : (nr, m) ndarray + input matrix of the controllable subsystem + Cr : (p, nr) ndarray + output matrix of the controllable subsystem + index : (p, ) ndarray + array of orders of the denominator polynomials + dcoeff : (p, max(index)+1) ndarray + array of denominator coefficients + ucoeff : (p, m, max(index)+1) ndarray + array of numerator coefficients """ hidden = ' (hidden by the wrapper)' arg_list = ['rowcol','n','m','p','A','lda'+hidden,'B','ldb'+hidden,'C','ldc'+hidden,'D', 'ldd'+hidden, @@ -340,7 +435,7 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): m : int The number of inputs, i.e. the number of columns in the matrix B. - p : int + p : int The number of outputs, i.e. the number of rows in the matrix C. jomega : complex float @@ -349,14 +444,14 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): systems, this is j*omega, where omega is the frequency to be evaluated. For discrete time systems, freq = exp(j*omega*Ts) - A : (n,n) ndarray + A : (n, n) ndarray On entry, this array must contain the state transition matrix A. - B : (n,m) ndarray + B : (n, m) ndarray On entry, this array must contain the input/state matrix B. - C : (p,n) ndarray + C : (p, n) ndarray On entry, of this array must contain the state/output matrix C. - job : {'AG', 'NG', 'NH'} + job : {'AG', 'NG', 'NH'}, optional If job = 'AG' (i.e., 'all', 'general matrix'), the A matrix is first balanced. The balancing transformation is then appropriately applied to matrices B and C. The A matrix @@ -377,72 +472,61 @@ def tb05ad(n, m, p, jomega, A, B, C, job='NG'): Returns ------- - if job = 'AG': - -------------- - At: The A matrix which has been both balanced and - transformed to upper Hessenberg form. The balancing - transforms A according to - A1 = P^-1 * A * P. - The transformation to upper Hessenberg form then yields - At = Q^T * (P^-1 * A * P ) * Q. - Note that the lower triangle of At is in general not zero. - Rather, it contains information on the orthogonal matrix Q - used to transform A1 to Hessenberg form. See docs for lappack - DGEHRD(): - http://www.netlib.org/lapack/explore-3.1.1-html/dgehrd.f.html - However, it does not apparently contain information on P, the - matrix used in the balancing procedure. - - Bt: The matrix B transformed according to - Bt = Q^T * P^-1 * B. - - Ct: The matrix C transformed according to - Ct = C * P * Q - - rcond: RCOND contains an estimate of the reciprocal of the - condition number of matrix H with respect to inversion, where - H = (j*freq * I - A) - - g_jw: complex p-by-m array, which contains the frequency response - matrix G(freq). - - ev: Eigenvalues of the matrix A. - - hinvb : complex n-by-m array, which contains the product - -1 - H B. - - if job = 'NG': - -------------- - At: The matrix A transformed to upper Hessenberg form according - to - At = Q^T * A * Q. - The lower triangle is not zero. It containts info on the - orthoganal transformation. See docs for linpack DGEHRD() - http://www.netlib.org/lapack/explore-3.1.1-html/dgehrd.f.html - - Bt: The matrix B transformed according to - Bt = Q^T * B. - - Ct: The matrix C transformed according to - Ct = C * Q - g_jw: complex array with dim p-by-m which contains the frequency - response matrix G(freq). - - hinvb : complex array with dimension p-by-m. - This array contains the - -1 - product H B. - + if job = 'AG' + ------------- + At : The A matrix which has been both balanced and + transformed to upper Hessenberg form. The balancing + transforms A according to + A1 = P^-1 * A * P. + The transformation to upper Hessenberg form then yields + At = Q^T * (P^-1 * A * P ) * Q. + Note that the lower triangle of At is in general not zero. + Rather, it contains information on the orthogonal matrix Q + used to transform A1 to Hessenberg form. See docs for lappack + DGEHRD(): + http://www.netlib.org/lapack/explore-3.1.1-html/dgehrd.f.html + However, it does not apparently contain information on P, the + matrix used in the balancing procedure. + Bt : The matrix B transformed according to + Bt = Q^T * P^-1 * B. + Ct : The matrix C transformed according to + Ct = C * P * Q + rcond : RCOND contains an estimate of the reciprocal of the + condition number of matrix H with respect to inversion, where + H = (j*freq * I - A) + g_jw : complex p-by-m array, which contains the frequency response + matrix G(freq). + ev : Eigenvalues of the matrix A. + hinvb : complex n-by-m array, which contains the product + -1 + H B. + + if job = 'NG' + ------------- + At : The matrix A transformed to upper Hessenberg form according + to + At = Q^T * A * Q. + The lower triangle is not zero. It containts info on the + orthoganal transformation. See docs for linpack DGEHRD() + http://www.netlib.org/lapack/explore-3.1.1-html/dgehrd.f.html + Bt : The matrix B transformed according to + Bt = Q^T * B. + Ct : The matrix C transformed according to + Ct = C * Q + g_jw : complex array with dim p-by-m which contains the frequency + response matrix G(freq). + hinvb : complex array with dimension p-by-m. + This array contains the + -1 + product H B. if job = 'NH' - -------------- - g_jw: complex p-by-m array which contains the frequency - response matrix G(freq). - - hinvb : complex p-by-m array which contains the - -1 - product H B. + ------------- + g_jw : complex p-by-m array which contains the frequency + response matrix G(freq). + hinvb : complex p-by-m array which contains the + -1 + product H B. Raises ------ @@ -644,65 +728,70 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): respectively. - Required arguments: - m : input int - The number of system inputs. m > 0. - p := len(index) input int - The number of system outputs. p > 0. - index : input rank-1 array('i') with bounds (p) or (m) - If leri = 'L', index(i), i = 1,2,...,p, must contain the maximum - degree of the polynomials in the I-th row of the denominator matrix - P(s) of the given left polynomial matrix representation. - If leri = 'R', index(i), i = 1,2,...,m, must contain the maximum - degree of the polynomials in the I-th column of the denominator - matrix P(s) of the given right polynomial matrix representation. - pcoeff : input rank-3 array('d') with bounds (p,p,*) or (m,m,*) - If leri = 'L' then porm = p, otherwise porm = m. The leading - porm-by-porm-by-kpcoef part of this array must contain - the coefficients of the denominator matrix P(s). pcoeff(i,j,k) is - the coefficient in s**(index(iorj)-K+1) of polynomial (I,J) of P(s), - where k = 1,2,...,kpcoef and kpcoef = max(index) + 1; if leri = 'L' - then iorj = i, otherwise iorj = j. Thus for leri = 'L', - P(s) = diag(s**index)*(pcoeff(.,.,1)+pcoeff(.,.,2)/s+...). - If leri = 'R', pcoeff is modified by the routine but restored on exit. - qcoeff : input rank-3 array('d') with bounds (p,m,*) or (max(m,p),max(m,p),*) - If leri = 'L' then porp = m, otherwise porp = p. The leading - porm-by-porp-by-kpcoef part of this array must contain - the coefficients of the numerator matrix Q(s). - qcoeff(i,j,k) is defined as for pcoeff(i,j,k). - If leri = 'R', qcoeff is modified by the routine but restored on exit. - leri : input string(len=1) - Indicates whether a left polynomial matrix representation or a right - polynomial matrix representation is input as follows: - = 'L': A left matrix fraction is input; - = 'R': A right matrix fraction is input. - Optional arguments: - ldwork := max(m,p)*(max(m,p)+4) input int - The length of the cache array. ldwork >= max(m,p)*(max(m,p)+4) - For optimum performance it should be larger. - Return objects: - n : int - The order of the resulting state-space representation. - That is, n = sum(index). - rcond : float - The estimated reciprocal of the condition number of the leading row - (if leri = 'L') or the leading column (if leri = 'R') coefficient - matrix of P(s). - If rcond is nearly zero, P(s) is nearly row or column non-proper. - A : rank-2 array('d') with bounds (n,n) - The leading n-by-n part of this array contains the state dynamics matrix A. - B : rank-2 array('d') with bounds (n,max(m,p)) - The leading n-by-n part of this array contains the input/state matrix B; - the remainder of the leading n-by-max(m,p) part is used as internal - workspace. - C : rank-2 array('d') with bounds (max(m,p),n) - The leading p-by-n part of this array contains the state/output matrix C; - the remainder of the leading max(m,p)-by-n part is used as internal - workspace. - D : rank-2 array('d') with bounds (max(m,p),max(m,p)) - The leading p-by-m part of this array contains the direct transmission - matrix D; the remainder of the leading max(m,p)-by-max(m,p) part is - used as internal workspace. + Parameters + ---------- + m : int + The number of system inputs. m > 0. + p : int + The number of system outputs. p > 0. + lend(index) + index : (p) or (m) array_like + If leri = 'L', index(i), i = 1,2,...,p, must contain the maximum + degree of the polynomials in the I-th row of the denominator matrix + P(s) of the given left polynomial matrix representation. + If leri = 'R', index(i), i = 1,2,...,m, must contain the maximum + degree of the polynomials in the I-th column of the denominator + matrix P(s) of the given right polynomial matrix representation. + pcoeff : (p,p,*) or (m,m,*) array_like + If leri = 'L' then porm = p, otherwise porm = m. The leading + porm-by-porm-by-kpcoef part of this array must contain + the coefficients of the denominator matrix P(s). pcoeff(i,j,k) is + the coefficient in s**(index(iorj)-K+1) of polynomial (I,J) of P(s), + where k = 1,2,...,kpcoef and kpcoef = max(index) + 1; if leri = 'L' + then iorj = i, otherwise iorj = j. Thus for leri = 'L', + P(s) = diag(s**index)*(pcoeff(.,.,1)+pcoeff(.,.,2)/s+...). + If leri = 'R', pcoeff is modified by the routine but restored on exit. + qcoeff : (p, m, *) or (max(m,p), max(m,p), *) array_like + If leri = 'L' then porp = m, otherwise porp = p. The leading + porm-by-porp-by-kpcoef part of this array must contain + the coefficients of the numerator matrix Q(s). + qcoeff(i,j,k) is defined as for pcoeff(i,j,k). + If leri = 'R', qcoeff is modified by the routine but restored on exit. + leri : {'L', 'R'} + Indicates whether a left polynomial matrix representation or a right + polynomial matrix representation is input as follows: + = 'L': A left matrix fraction is input; + = 'R': A right matrix fraction is input. + ldwork : int, optional + The length of the cache array. ldwork >= max(m,p)*(max(m,p)+4) + For optimum performance it should be larger. + Default is None. + + Returns + ------- + n : int + The order of the resulting state-space representation. + That is, n = sum(index). + rcond : float + The estimated reciprocal of the condition number of the leading row + (if leri = 'L') or the leading column (if leri = 'R') coefficient + matrix of P(s). + If rcond is nearly zero, P(s) is nearly row or column non-proper. + A : (n, n) ndarray + The leading n-by-n part of this array contains the state dynamics matrix A. + B : rank-2 array('d') with bounds (n,max(m,p)) + The leading n-by-n part of this array contains the input/state matrix B; + the remainder of the leading n-by-max(m,p) part is used as internal + workspace. + C : (max(m,p), n) ndarray + The leading p-by-n part of this array contains the state/output matrix C; + the remainder of the leading max(m,p)-by-n part is used as internal + workspace. + D : (max(m,p), max(m,p)) ndarray + The leading p-by-m part of this array contains the direct transmission + matrix D; the remainder of the leading max(m,p)-by-max(m,p) part is + used as internal workspace. + Raises ------ SlycotArithmeticError @@ -730,7 +819,6 @@ def tc04ad(m,p,index,pcoeff,qcoeff,leri,ldwork=None): raise_if_slycot_error(out[-1], arg_list, tc04ad.__doc__, locals()) return out[:-1] - def tc01od(m,p,indlin,pcoeff,qcoeff,leri): """ pcoeff,qcoeff = tc01od_l(m,p,indlim,pcoeff,qcoeff,leri) @@ -739,39 +827,41 @@ def tc01od(m,p,indlin,pcoeff,qcoeff,leri): polynomial matrix representations are of the form Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively. - Required arguments: - m : input int - The number of system inputs. m > 0. - p : input int - The number of system outputs. p > 0. - indlim : input int - The highest value of k for which pcoeff(.,.,k) and qcoeff(.,.,k) - are to be transposed. - k = kpcoef + 1, where kpcoef is the maximum degree of the polynomials - in P(s). indlim > 0. - pcoeff : input rank-3 array('d') with bounds (p,p,indlim) or (m,m,indlim) - If leri = 'L' then porm = p, otherwise porm = m. - On entry, the leading porm-by-porm-by-indlim part of this array - must contain the coefficients of the denominator matrix P(s). - pcoeff(i,j,k) is the coefficient in s**(indlim-k) of polynomial - (i,j) of P(s), where k = 1,2,...,indlim. - qcoeff : input rank-3 array('d') with bounds (max(m,p),max(m,p),indlim) - On entry, the leading p-by-m-by-indlim part of this array must - contain the coefficients of the numerator matrix Q(s). - qcoeff(i,j,k) is the coefficient in s**(indlim-k) of polynomial - (i,j) of Q(s), where k = 1,2,...,indlim. - leri : input string(len=1) - Return objects: - pcoeff : rank-3 array('d') with bounds (p,p,indlim) - On exit, the leading porm-by-porm-by-indlim part of this array - contains the coefficients of the denominator matrix P'(s) of - the dual system. - qcoeff : rank-3 array('d') with bounds (max(m,p),max(m,p),indlim) - On exit, the leading m-by-p-by-indlim part of the array contains - the coefficients of the numerator matrix Q'(s) of the dual system. - info : int - = 0: successful exit; - < 0: if info = -i, the i-th argument had an illegal value. + Parameters + ---------- + m : int + The number of system inputs. m > 0. + p : int + The number of system outputs. p > 0. + indlim : int + The highest value of k for which pcoeff(.,.,k) and qcoeff(.,.,k) + are to be transposed. + k = kpcoef + 1, where kpcoef is the maximum degree of the polynomials + in P(s). indlim > 0. + pcoeff : (p, p, indlim) or (m, m, indlim) array_like + If leri = 'L' then porm = p, otherwise porm = m. + On entry, the leading porm-by-porm-by-indlim part of this array + must contain the coefficients of the denominator matrix P(s). + pcoeff(i,j,k) is the coefficient in s**(indlim-k) of polynomial + (i,j) of P(s), where k = 1,2,...,indlim. + qcoeff : (max(m,p), max(m,p), indlim) array_like + On entry, the leading p-by-m-by-indlim part of this array must + contain the coefficients of the numerator matrix Q(s). + qcoeff(i,j,k) is the coefficient in s**(indlim-k) of polynomial + (i,j) of Q(s), where k = 1,2,...,indlim. + leri : {'L', 'R'} + = 'L': A left matrix fraction is input; + = 'R': A right matrix fraction is input. + + Returns + ------- + pcoeff : (p, p, indlim) ndarray + On exit, the leading porm-by-porm-by-indlim part of this array + contains the coefficients of the denominator matrix P'(s) of + the dual system. + qcoeff : (max(m,p), max(m,p), indlim) ndarray + On exit, the leading m-by-p-by-indlim part of the array contains + the coefficients of the numerator matrix Q'(s) of the dual system. """ hidden = ' (hidden by the wrapper)' arg_list = ['leri', 'M', 'P', 'indlim', 'pcoeff', 'LDPCO1'+hidden, @@ -793,32 +883,35 @@ def tf01md(n,m,p,N,A,B,C,D,u,x0): To compute the output sequence of a linear time-invariant open-loop system given by its discrete-time state-space model - Required arguments: - n : input int - Order of the State-space representation. - m : input int - Number of inputs. - p : input int - Number of outputs. - N : input int - Number of output samples to be computed. - A : input rank-2 array('d') with bounds (n,n) - State dynamics matrix. - B : input rank-2 array('d') with bounds (n,m) - Input/state matrix. - C : input rank-2 array('d') with bounds (p,n) - State/output matrix. - D : input rank-2 array('d') with bounds (p,m) - Direct transmission matrix. - u : input rank-2 array('d') with bounds (m,N) - Input signal. - x0 : input rank-1 array('d') with bounds (n) - Initial state, at time 0. - Return objects: - xf : rank-1 array('d') with bounds (n) - Final state, at time N+1. - y : rank-2 array('d') with bounds (p,N) - Output signal. + Parameters + ---------- + n : int + Order of the State-space representation. + m : int + Number of inputs. + p : int + Number of outputs. + N : int + Number of output samples to be computed. + A : (n, n) array_like + State dynamics matrix. + B : (n, m) array_like + Input/state matrix. + C : (p, n) array_like + State/output matrix. + D : (p, m) array_like + Direct transmission matrix. + u : (m, n) + Input signal. + x0 : (n, ) array_like + Initial state, at time 0. + + Returns + ------- + xf : (n) ndarray + Final state, at time n+1. + y : (p, n) ndarray + Output signal. """ hidden = ' (hidden by the wrapper)' arg_list = ['n','m','p','ny','A','lda'+hidden,'B','ldb'+hidden, @@ -839,28 +932,31 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): All matrices are treated as dense, and hence TF01RD is not intended for large sparse problems. + Parameters + ---------- + n : int + Order of the State-space representation. + m : int + Number of inputs. + p : int + Number of outputs. + N : int + Number of Markov parameters to be computed. + A : (n, n) array_like + State dynamics matrix. + B : (n, m) array_like + Input/state matrix. + C : (p, n) array_like + State/output matrix. + ldwork : int, optional + The length of the array DWORK. + ldwork >= max(1, 2*n*p). - Required arguments: - n : input int - Order of the State-space representation. - m : input int - Number of inputs. - p : input int - Number of outputs. - N : input int - Number of Markov parameters to be computed. - A : input rank-2 array('d') with bounds (n,n) - State dynamics matrix. - B : input rank-2 array('d') with bounds (n,m) - Input/state matrix. - C : input rank-2 array('d') with bounds (p,n) - State/output matrix. - Optional arguments: - ldwork := 2*na*nc input int - Return objects: - H : rank-2 array('d') with bounds (p,N*m) - H[:,(k-1)*m : k*m] contains the k-th Markov parameter, - for k = 1,2...N. + Returns + ------- + H : (p, N*m) ndarray + H[:,(k-1)*m : k*m] contains the k-th Markov parameter, + for k = 1,2...N. """ hidden = ' (hidden by the wrapper)' arg_list = ['n','m','p','N','A','lda'+hidden,'B','ldb'+hidden,'C', @@ -873,86 +969,6 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): raise_if_slycot_error(out[-1], arg_list) return out[0] -def tb01pd(n, m, p, A, B, C, job='M', equil='S', tol=1e-8, ldwork=None): - """Ar, Br, Cr, nr = tb01pd(n,m,p,A,B,C,[job,equil,tol,ldwork]) - - To find a reduced (controllable, observable, or minimal) state- - space representation (Ar,Br,Cr) for any original state-space - representation (A,B,C). The matrix Ar is in upper block - Hessenberg form. - - Required arguments: - n : input int - Order of the State-space representation. - m : input int - Number of inputs. - p : input int - Number of outputs. - A : input rank-2 array('d') with bounds (n,n) - State dynamics matrix. - B : input rank-2 array('d') with bounds (n,max(m,p)) - The leading n-by-m part of this array must contain the original - input/state matrix B; the remainder of the leading n-by-max(m,p) - part is used as internal workspace. - C : input rank-2 array('d') with bounds (p,n) - The leading p-by-n part of this array must contain the original - state/output matrix C; the remainder of the leading max(1,m,p)-by-n - part is used as internal workspace. - Optional arguments: - job : input char*1 - Indicates whether the user wishes to remove the - uncontrollable and/or unobservable parts as follows: - = 'M': Remove both the uncontrollable and unobservable - parts to get a minimal state-space representation; - = 'C': Remove the uncontrollable part only to get a - controllable state-space representation; - = 'O': Remove the unobservable part only to get an - observable state-space representation. - equil : input char*1 - Specifies whether the user wishes to preliminarily balance - the triplet (A,B,C) as follows: - = 'S': Perform balancing (scaling); - = 'N': Do not perform balancing. - Return objects: - Ar : output rank-2 array('d') with bounds (nr,nr) - Contains the upper block Hessenberg state dynamics matrix - Ar of a minimal, controllable, or observable realization - for the original system, depending on the value of JOB, - JOB = 'M', JOB = 'C', or JOB = 'O', respectively. - Br : output rank-2 array('d') with bounds (nr,m) - Contains the transformed input/state matrix Br of a - minimal, controllable, or observable realization for the - original system, depending on the value of JOB, JOB = 'M', - JOB = 'C', or JOB = 'O', respectively. If JOB = 'C', only - the first IWORK(1) rows of B are nonzero. - Cr : output rank-2 array('d') with bounds (p,nr) - - Contains the transformed state/output matrix Cr of a - minimal, C controllable, or observable realization for the - original C system, depending on the value of JOB, JOB = - 'M', C JOB = 'C', or JOB = 'O', respectively. C If JOB = - 'M', or JOB = 'O', only the last IWORK(1) columns C (in - the first NR columns) of C are nonzero. - nr : output int - The order of the reduced state-space representation - (Ar,Br,Cr) of a minimal, controllable, or observable - realization for the original system, depending on - JOB = 'M', JOB = 'C', or JOB = 'O'. - """ - hidden = ' (hidden by the wrapper)' - arg_list = ['job', 'equil', 'n','m','p','A','lda'+hidden,'B','ldb'+hidden, - 'C','ldc'+hidden,'nr','tol','iwork'+hidden,'dwork'+hidden, - 'ldwork','info'+hidden] - if ldwork is None: - ldwork = max(1, n+max(n,3*m,3*p)) - elif ldwork < max(1, n+max(n,3*m,3*p)): - raise SlycotParameterError("ldwork is too small", -15) - out = _wrapper.tb01pd(n=n,m=m,p=p,a=A,b=B,c=C, - job=job,equil=equil,tol=tol,ldwork=ldwork) - - raise_if_slycot_error(out[-1], arg_list) - return out[:-1] - def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): """ A,E,B,C,lscale,rscale = tg01ad(l,n,m,p,A,E,B,C,[thresh,job]) @@ -981,64 +997,69 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): S = ( A-lambda E ). ( C ) - Required arguments: - l : input int - The number of rows of matrices A, B, and E. l >= 0. - n : input int - The number of columns of matrices A, E, and C. n >= 0. - m : input int - The number of columns of matrix B. m >= 0. - p : input int - The number of rows of matrix C. P >= 0. - A : rank-2 array('d') with bounds (l,n) - The leading L-by-N part of this array must - contain the state dynamics matrix A. - E : rank-2 array('d') with bounds (l,n) - The leading L-by-N part of this array must - contain the descriptor matrix E. - B : rank-2 array('d') with bounds (l,m) - The leading L-by-M part of this array must - contain the input/state matrix B. - The array B is not referenced if M = 0. - C : rank-2 array('d') with bounds (p,n) - The leading P-by-N part of this array must - contain the state/output matrix C. - The array C is not referenced if P = 0. - Optional arguments: - job := 'A' input string(len=1) - Indicates which matrices are involved in balancing, as - follows: - = 'A': All matrices are involved in balancing; - = 'B': B, A and E matrices are involved in balancing; - = 'C': C, A and E matrices are involved in balancing; - = 'N': B and C matrices are not involved in balancing. - thresh := 0.0 input float - Threshold value for magnitude of elements: - elements with magnitude less than or equal to - THRESH are ignored for balancing. THRESH >= 0. - Return objects: - A : rank-2 array('d') with bounds (l,n) - The leading L-by-N part of this array contains - the balanced matrix Dl*A*Dr. - E : rank-2 array('d') with bounds (l,n) - The leading L-by-N part of this array contains - the balanced matrix Dl*E*Dr. - B : rank-2 array('d') with bounds (l,m) - If M > 0, the leading L-by-M part of this array - contains the balanced matrix Dl*B. - The array B is not referenced if M = 0. - C : rank-2 array('d') with bounds (p,n) - If P > 0, the leading P-by-N part of this array - contains the balanced matrix C*Dr. - The array C is not referenced if P = 0. - lscale : rank-1 array('d') with bounds (l) - The scaling factors applied to S from left. If Dl(j) is - the scaling factor applied to row j, then - SCALE(j) = Dl(j), for j = 1,...,L. - rscale : rank-1 array('d') with bounds (n) - The scaling factors applied to S from right. If Dr(j) is - the scaling factor applied to column j, then - SCALE(j) = Dr(j), for j = 1,...,N. + + Parameters + ---------- + l : int + The number of rows of matrices A, B, and E. l >= 0. + n : int + The number of columns of matrices A, E, and C. n >= 0. + m : int + The number of columns of matrix B. m >= 0. + p : int + The number of rows of matrix C. P >= 0. + A : (l, n) array_like + The leading L-by-N part of this array must + contain the state dynamics matrix A. + E : (l, n) array_like + The leading L-by-N part of this array must + contain the descriptor matrix E. + B : (l, m) array_like + The leading L-by-M part of this array must + contain the input/state matrix B. + The array B is not referenced if M = 0. + C : (p, n) array_like + The leading P-by-N part of this array must + contain the state/output matrix C. + The array C is not referenced if P = 0. + job : {'A', 'B', 'C', 'N'}, optional + Indicates which matrices are involved in balancing, as + follows: + = 'A': All matrices are involved in balancing; + = 'B': B, A and E matrices are involved in balancing; + = 'C': C, A and E matrices are involved in balancing; + = 'N': B and C matrices are not involved in balancing. + Default is 'A'. + thresh : float, optional + Threshold value for magnitude of elements: + elements with magnitude less than or equal to + THRESH are ignored for balancing. THRESH >= 0. + Default is `0.0`. + + Returns + ------- + A : (l, n) ndarray + The leading L-by-N part of this array contains + the balanced matrix Dl*A*Dr. + E : (l, n) ndarray + The leading L-by-N part of this array contains + the balanced matrix Dl*E*Dr. + B : (l, m) ndarray + If M > 0, the leading L-by-M part of this array + contains the balanced matrix Dl*B. + The array B is not referenced if M = 0. + C : (p, n) ndarray + If P > 0, the leading P-by-N part of this array + contains the balanced matrix C*Dr. + The array C is not referenced if P = 0. + lscale : (l, ) ndarray + The scaling factors applied to S from left. If Dl(j) is + the scaling factor applied to row j, then + SCALE(j) = Dl(j), for j = 1,...,L. + rscale : (n, ) ndarray + The scaling factors applied to S from right. If Dr(j) is + the scaling factor applied to column j, then + SCALE(j) = Dr(j), for j = 1,...,N. """ hidden = ' (hidden by the wrapper)' @@ -1072,132 +1093,141 @@ def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ld The left and/or right orthogonal transformations performed to reduce E and A22 can be optionally accumulated. - Required arguments: - l : input int - The number of rows of matrices A, B, and E. l >= 0. - n : input int - The number of columns of matrices A, E, and C. n >= 0. - m : input int - The number of columns of matrix B. m >= 0. - p : input int - The number of rows of matrix C. p >= 0. - A : rank-2 array('d') with bounds (l,n) - The leading l-by-n part of this array must - contain the state dynamics matrix A. - E : rank-2 array('d') with bounds (l,n) - The leading l-by-n part of this array must - contain the descriptor matrix E. - B : rank-2 array('d') with bounds (l,m) - The leading L-by-M part of this array must - contain the input/state matrix B. - C : rank-2 array('d') with bounds (p,n) - The leading P-by-N part of this array must - contain the state/output matrix C. - Optional arguments: - Q : rank-2 array('d') with bounds (l,l) - If COMPQ = 'N': Q is not referenced. - If COMPQ = 'I': Q need not be set. - If COMPQ = 'U': The leading l-by-l part of this - array must contain an orthogonal matrix - Q1. - Z : rank-2 array('d') with bounds (n,n) - If COMPZ = 'N': Z is not referenced. - If COMPZ = 'I': Z need not be set. - If COMPZ = 'U': The leading n-by-n part of this - array must contain an orthogonal matrix - Z1. - compq := 'N' input string(len=1) - = 'N': do not compute Q. - = 'I': Q is initialized to the unit matrix, and the - orthogonal matrix Q is returned. - = 'U': Q must contain an orthogonal matrix Q1 on entry, - and the product Q1*Q is returned. - compz := 'N' input string(len=1) - = 'N': do not compute Z. - = 'I': Z is initialized to the unit matrix, and the - orthogonal matrix Z is returned. - = 'U': Z must contain an orthogonal matrix Z1 on entry, - and the product Z1*Z is returned. - joba := 'N' input string(len=1) - = 'N': do not reduce A22. - = 'R': reduce A22 to a SVD-like upper triangular form. - = 'T': reduce A22 to an upper trapezoidal form. - tol := 0 input float - The tolerance to be used in determining the rank of E - and of A22. If the user sets TOL > 0, then the given - value of TOL is used as a lower bound for the - reciprocal condition numbers of leading submatrices - of R or R22 in the QR decompositions E * P = Q * R of E - or A22 * P22 = Q22 * R22 of A22. - A submatrix whose estimated condition number is less than - 1/TOL is considered to be of full rank. If the user sets - TOL <= 0, then an implicitly computed, default tolerance, - defined by TOLDEF = L*N*EPS, is used instead, where - EPS is the machine precision (see LAPACK Library routine - DLAMCH). TOL < 1. - ldwork : input int - The length of the cache array. - ldwork >= MAX( 1, n+p, MIN(l,n)+MAX(3*n-1,m,l) ). - For optimal performance, ldwork should be larger. - Return objects: - A : rank-2 array('d') with bounds (l,n) - On entry, the leading L-by-N part of this array must - contain the state dynamics matrix A. - On exit, the leading L-by-N part of this array contains - the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix - is in the form - - ( A11 * * ) - Q'*A*Z = ( * Ar X ) , - ( * 0 0 ) - - where A11 is a RANKE-by-RANKE matrix and Ar is a - RNKA22-by-RNKA22 invertible upper triangular matrix. - If JOBA = 'R' then A has the above form with X = 0. - E : rank-2 array('d') with bounds (l,n) - The leading L-by-N part of this array contains - the transformed matrix Q'*E*Z. - - ( Er 0 ) - Q'*E*Z = ( ) , - ( 0 0 ) - - where Er is a RANKE-by-RANKE upper triangular invertible - matrix. - B : rank-2 array('d') with bounds (l,m) - The leading L-by-M part of this array contains - the transformed matrix Q'*B. - C : rank-2 array('d') with bounds (p,n) - The leading P-by-N part of this array contains - the transformed matrix C*Z. - Q : rank-2 array('d') with bounds (l,l) - If COMPQ = 'N': Q is not referenced. - If COMPQ = 'I': The leading L-by-L part of this - array contains the orthogonal matrix Q, - where Q' is the product of Householder - transformations which are applied to A, - E, and B on the left. - If COMPQ = 'U': The leading L-by-L part of this - array contains the orthogonal matrix - Q1*Q. - Z : rank-2 array('d') with bounds (n,n) - If COMPZ = 'N': Z is not referenced. - If COMPZ = 'I': The leading N-by-N part of this - array contains the orthogonal matrix Z, - which is the product of Householder - transformations applied to A, E, and C - on the right. - If COMPZ = 'U': The leading N-by-N part of this - array contains the orthogonal matrix - Z1*Z. - ranke : output int - The estimated rank of matrix E, and thus also the order - of the invertible upper triangular submatrix Er. - rnka22 : output int - If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of - matrix A22, and thus also the order of the invertible - upper triangular submatrix Ar. - If JOBA = 'N', then RNKA22 is not referenced. + Parameters + ---------- + l : int + The number of rows of matrices A, B, and E. l >= 0. + n : int + The number of columns of matrices A, E, and C. n >= 0. + m : int + The number of columns of matrix B. m >= 0. + p : int + The number of rows of matrix C. p >= 0. + A : (l, n) array_like + The leading l-by-n part of this array must + contain the state dynamics matrix A. + E : (l, n) array_like + The leading l-by-n part of this array must + contain the descriptor matrix E. + B : (l, m) array_like + The leading L-by-M part of this array must + contain the input/state matrix B. + C : (p, n) array_like + The leading P-by-N part of this array must + contain the state/output matrix C. + Q : (l, l) array_like, optional + If COMPQ = 'N': Q is not referenced. + If COMPQ = 'I': Q need not be set. + If COMPQ = 'U': The leading l-by-l part of this + array must contain an orthogonal matrix + Q1. + Default is None. + Z : (n, n) array_like, optional + If COMPZ = 'N': Z is not referenced. + If COMPZ = 'I': Z need not be set. + If COMPZ = 'U': The leading n-by-n part of this + array must contain an orthogonal matrix + Z1. + Default is None. + compq : {'N', 'I', 'U'}, optional + = 'N': do not compute Q. + = 'I': Q is initialized to the unit matrix, and the + orthogonal matrix Q is returned. + = 'U': Q must contain an orthogonal matrix Q1 on entry, + and the product Q1*Q is returned. + Default is 'N'. + compz : {'N', 'I', 'U'}, optional + = 'N': do not compute Z. + = 'I': Z is initialized to the unit matrix, and the + orthogonal matrix Z is returned. + = 'U': Z must contain an orthogonal matrix Z1 on entry, + and the product Z1*Z is returned. + Default is 'N'. + joba : {'N', 'R', 'T'}, optional + = 'N': do not reduce A22. + = 'R': reduce A22 to a SVD-like upper triangular form. + = 'T': reduce A22 to an upper trapezoidal form. + Default is 'N'. + tol : float, optional + The tolerance to be used in determining the rank of E + and of A22. If the user sets TOL > 0, then the given + value of TOL is used as a lower bound for the + reciprocal condition numbers of leading submatrices + of R or R22 in the QR decompositions E * P = Q * R of E + or A22 * P22 = Q22 * R22 of A22. + A submatrix whose estimated condition number is less than + 1/TOL is considered to be of full rank. If the user sets + TOL <= 0, then an implicitly computed, default tolerance, + defined by TOLDEF = L*N*EPS, is used instead, where + EPS is the machine precision (see LAPACK Library routine + DLAMCH). TOL < 1. + Default is `0.0`. + ldwork : int, optional + The length of the cache array. + ldwork >= MAX( 1, n+p, MIN(l,n)+MAX(3*n-1,m,l) ). + For optimal performance, ldwork should be larger. + Default is None. + + Returns + ------- + A : (l, n) ndarray + On entry, the leading L-by-N part of this array must + contain the state dynamics matrix A. + On exit, the leading L-by-N part of this array contains + the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix + is in the form + + ( A11 * * ) + Q'*A*Z = ( * Ar X ) , + ( * 0 0 ) + + where A11 is a RANKE-by-RANKE matrix and Ar is a + RNKA22-by-RNKA22 invertible upper triangular matrix. + If JOBA = 'R' then A has the above form with X = 0. + E : (l, n) ndarray + The leading L-by-N part of this array contains + the transformed matrix Q'*E*Z. + + ( Er 0 ) + Q'*E*Z = ( ) , + ( 0 0 ) + + where Er is a RANKE-by-RANKE upper triangular invertible + matrix. + B : (l, m) ndarray + The leading L-by-M part of this array contains + the transformed matrix Q'*B. + C : (p, n) ndarray + The leading P-by-N part of this array contains + the transformed matrix C*Z. + ranke : int + The estimated rank of matrix E, and thus also the order + of the invertible upper triangular submatrix Er. + rnka22 : int + If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of + matrix A22, and thus also the order of the invertible + upper triangular submatrix Ar. + If JOBA = 'N', then RNKA22 is not referenced. + Q : (l, l) ndarray + If COMPQ = 'N': Q is not referenced. + If COMPQ = 'I': The leading L-by-L part of this + array contains the orthogonal matrix Q, + where Q' is the product of Householder + transformations which are applied to A, + E, and B on the left. + If COMPQ = 'U': The leading L-by-L part of this + array contains the orthogonal matrix + Q1*Q. + Z : (n, n) ndarray + If COMPZ = 'N': Z is not referenced. + If COMPZ = 'I': The leading N-by-N part of this + array contains the orthogonal matrix Z, + which is the product of Householder + transformations applied to A, E, and C + on the right. + If COMPZ = 'U': The leading N-by-N part of this + array contains the orthogonal matrix + Z1*Z. """ hidden = ' (hidden by the wrapper)' From 6a375c88e1cb461f0074d90a16427d63a0e84b79 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Jan 2024 17:30:44 +0100 Subject: [PATCH 371/405] Follow SPEC 0 on 2024Q1 --- .github/conda-env/build-env.yml | 2 +- .github/workflows/slycot-build-and-test.yml | 14 +++++++------- conda-recipe/conda_build_config.yaml | 7 ++----- pyproject.toml | 9 ++++----- 4 files changed, 14 insertions(+), 18 deletions(-) diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml index f7597364..f747a77e 100644 --- a/.github/conda-env/build-env.yml +++ b/.github/conda-env/build-env.yml @@ -1,4 +1,4 @@ name: build-env dependencies: - boa - - numpy !=1.23.0 + - numpy diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 3f079c69..ed83c007 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -57,24 +57,24 @@ jobs: - 'ubuntu' - 'macos' python: - - '3.8' - - '3.11' + - '3.10' + - '3.12' bla_vendor: [ 'unset' ] include: - os: 'ubuntu' - python: '3.11' + python: '3.12' bla_vendor: 'Generic' - os: 'ubuntu' - python: '3.11' + python: '3.12' bla_vendor: 'OpenBLAS' - os: 'macos' - python: '3.11' + python: '3.12' bla_vendor: 'Apple' - os: 'macos' - python: '3.11' + python: '3.12' bla_vendor: 'Generic' - os: 'macos' - python: '3.11' + python: '3.12' bla_vendor: 'OpenBLAS' steps: diff --git a/conda-recipe/conda_build_config.yaml b/conda-recipe/conda_build_config.yaml index 26423158..baf81bec 100644 --- a/conda-recipe/conda_build_config.yaml +++ b/conda-recipe/conda_build_config.yaml @@ -5,13 +5,10 @@ # zip_keys Python/Numpy matrix to build for python: - 3.10.* *_cpython - - 3.11.* *_cpython -# 3.12 is already building in conda-forge/slycot-feedstock, but they did not publish everything yet -# - 3.12.* *_cpython + - 3.12.* *_cpython numpy: - - 1.22 - 1.23 -# - 1.23 + - 1.23 zip_keys: - diff --git a/pyproject.toml b/pyproject.toml index 0aff147f..c984562f 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -5,7 +5,7 @@ requires = [ "wheel", "scikit-build>=0.15", "cmake>=3.14", - "numpy!=1.23.0"] + "numpy >= 1.23.1"] build-backend = "setuptools.build_meta" [project] @@ -25,10 +25,9 @@ classifiers = [ "Programming Language :: C", "Programming Language :: Fortran", "Programming Language :: Python", - "Programming Language :: Python :: 3.8", - "Programming Language :: Python :: 3.9", "Programming Language :: Python :: 3.10", "Programming Language :: Python :: 3.11", + "Programming Language :: Python :: 3.12", "Topic :: Software Development", "Topic :: Scientific/Engineering", "Operating System :: Microsoft :: Windows", @@ -36,9 +35,9 @@ classifiers = [ "Operating System :: Unix", "Operating System :: MacOS", ] -requires-python = ">=3.8" +requires-python = ">=3.10" dependencies = [ - "numpy", + "numpy >= 1.23.1", ] dynamic = ["version"] From 9ad09e9d69541deb05506c9177d2d803904aaabf Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Jan 2024 18:23:51 +0100 Subject: [PATCH 372/405] pull in conda-forge python312 migration pinning --- conda-recipe/conda_build_config.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/conda-recipe/conda_build_config.yaml b/conda-recipe/conda_build_config.yaml index baf81bec..6c968691 100644 --- a/conda-recipe/conda_build_config.yaml +++ b/conda-recipe/conda_build_config.yaml @@ -1,6 +1,6 @@ # https://github.com/conda-forge/blas-feedstock/issues/106#issuecomment-1771747983 # https://github.com/conda-forge/conda-forge-pinning-feedstock/blob/main/recipe/conda_build_config.yaml - +# https://github.com/conda-forge/conda-forge-pinning-feedstock/blob/main/recipe/migrations/python312.yaml # zip_keys Python/Numpy matrix to build for python: @@ -8,7 +8,7 @@ python: - 3.12.* *_cpython numpy: - 1.23 - - 1.23 + - 1.26 zip_keys: - From dd1901e3394946cea6ec1ff9cc19663cdfa7ff46 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Jan 2024 22:50:54 +0100 Subject: [PATCH 373/405] don't check control deprecation warnings --- .github/scripts/run-tests.sh | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/.github/scripts/run-tests.sh b/.github/scripts/run-tests.sh index 0c12237e..41f74da0 100644 --- a/.github/scripts/run-tests.sh +++ b/.github/scripts/run-tests.sh @@ -11,11 +11,14 @@ echo "::endgroup::" echo "::group::python-control unit tests" pushd ${python_control_srcdir:=./python-control} -# test_root_locus_zoom, test_sisotool: problems with the toolbar for MPL backends, not relevant to Slycot +# problems with the toolbar for MPL backends, not relevant to Slycot +donttest="test_root_locus_zoom or test_sisotool" +# don't care about deprecation warnings here +donttest="$donttest or test_default_deprecation" pytest control/tests \ --cov=$slycot_libdir \ --cov-config=${slycot_srcdir}/.coveragerc \ - -k "not (test_root_locus_zoom or test_sisotool)" + -k "not ($donttest)" mv .coverage ${slycot_srcdir}/.coverage.control popd echo "::endgroup::" From 7340cf8fde6b83284315e05f2b78141a34f8e752 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 8 Jan 2024 22:21:53 +0100 Subject: [PATCH 374/405] replace coveralls-python with coveralls github-action --- .github/conda-env/test-env.yml | 1 - .github/scripts/run-tests.sh | 1 + .github/workflows/slycot-build-and-test.yml | 31 +++++++++------------ 3 files changed, 14 insertions(+), 19 deletions(-) diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml index 8ab7abdd..bdc01362 100644 --- a/.github/conda-env/test-env.yml +++ b/.github/conda-env/test-env.yml @@ -7,4 +7,3 @@ dependencies: - pytest-cov - pytest-timeout - coverage - - coveralls >= 3.3 diff --git a/.github/scripts/run-tests.sh b/.github/scripts/run-tests.sh index 41f74da0..2ba81756 100644 --- a/.github/scripts/run-tests.sh +++ b/.github/scripts/run-tests.sh @@ -34,4 +34,5 @@ cd ${slycot_srcdir} echo " ${slycot_libdir}" >> .coveragerc coverage combine coverage report +coverage xml echo "::endgroup::" diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index ed83c007..1279647c 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -279,7 +279,7 @@ jobs: - name: Install Wheel run: | python -m pip install --upgrade pip - pip install matplotlib scipy pytest pytest-cov pytest-timeout coverage coveralls + pip install matplotlib scipy pytest pytest-cov pytest-timeout coverage pip install slycot-wheels/${{ matrix.packagekey }}/slycot*.whl pip show slycot - name: Slycot and python-control tests @@ -287,13 +287,11 @@ jobs: env: JOBNAME: wheel ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: report coverage - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - COVERALLS_FLAG_NAME: wheel-${{ matrix.packagekey }}-${{matrix.blas_lib}} - COVERALLS_PARALLEL: true - working-directory: slycot-src - # https://github.com/TheKevJames/coveralls-python/issues/252 - run: coveralls --service=github + uses: coverallsapp/github-action@v2 + with: + flag-name: wheel-${{ matrix.packagekey }}-${{matrix.blas_lib}} + parallel: true + file: slycot-src/coverage.xml test-conda: name: Test conda ${{ matrix.packagekey }}, ${{matrix.blas_lib}} BLAS lib ${{ matrix.failok }} @@ -363,14 +361,12 @@ jobs: run: JOBNAME="$JOBNAME" bash slycot-src/.github/scripts/run-tests.sh env: JOBNAME: conda ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - - name: Report coverage - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - COVERALLS_FLAG_NAME: conda-${{ matrix.packagekey }}-${{matrix.blas_lib}} - COVERALLS_PARALLEL: true - working-directory: slycot-src - # https://github.com/TheKevJames/coveralls-python/issues/252 - run: coveralls --service=github + - name: report coverage + uses: coverallsapp/github-action@v2 + with: + flag-name: wheel-${{ matrix.packagekey }}-${{matrix.blas_lib}} + parallel: true + file: slycot-src/coverage.xml coveralls-final: name: Finalize parallel coveralls @@ -381,7 +377,6 @@ jobs: runs-on: ubuntu-latest steps: - name: Coveralls Finished - uses: coverallsapp/github-action@master + uses: coverallsapp/github-action@v2 with: - github-token: ${{ secrets.GITHUB_TOKEN }} parallel-finished: true From 39db9d296aab07b26d63ff74b2e427a2ae3f199f Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 8 Jan 2024 22:04:26 +0100 Subject: [PATCH 375/405] clean CMake install python files directives --- MANIFEST.in | 1 - slycot/CMakeLists.txt | 9 --------- slycot/tests/CMakeLists.txt | 23 ----------------------- 3 files changed, 33 deletions(-) delete mode 100644 slycot/tests/CMakeLists.txt diff --git a/MANIFEST.in b/MANIFEST.in index b8c04e7c..cd90447e 100644 --- a/MANIFEST.in +++ b/MANIFEST.in @@ -7,7 +7,6 @@ include CMakeLists.txt include pyproject.toml include conda-recipe/* include slycot/CMakeLists.txt -include slycot/tests/CMakeLists.txt include slycot/*.py include slycot/src/*.f include slycot/tests/*.py diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index eb49edd1..37b4d34d 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -630,12 +630,6 @@ set(F2PYSOURCE_DEPS src/transform.pyf src/synthesis.pyf src/_helper.pyf) -set(PYSOURCE - - __init__.py examples.py exceptions.py - analysis.py math.py synthesis.py transform.py -) - set(SLYCOT_MODULE "_wrapper") set(GENERATED_MODULE @@ -681,6 +675,3 @@ endif() python_extension_module(${SLYCOT_MODULE}) install(TARGETS ${SLYCOT_MODULE} LIBRARY DESTINATION slycot) -install(FILES ${PYSOURCE} DESTINATION slycot) - -add_subdirectory(tests) diff --git a/slycot/tests/CMakeLists.txt b/slycot/tests/CMakeLists.txt deleted file mode 100644 index 80d751da..00000000 --- a/slycot/tests/CMakeLists.txt +++ /dev/null @@ -1,23 +0,0 @@ -set(PYSOURCE - - __init__.py - test_ab01.py - test_ab04md.py - test_ab08n.py - test_ag08bd.py - test_examples.py - test_exceptions.py - test_mb.py - test_mc.py - test_sb.py - test_analysis.py - test_transform.py - test_sg02ad.py - test_sg03ad.py - test_tb05ad.py - test_td04ad.py - test_tg01ad.py - test_tg01fd.py ) - -install(FILES ${PYSOURCE} - DESTINATION slycot/tests) From a0ee90ca83048a6b6128b411d06934017aef729e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Sun, 7 Jan 2024 22:43:52 +0100 Subject: [PATCH 376/405] cover docstring parser standard info = -i cases --- slycot/tests/test_exceptions.py | 49 +++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/slycot/tests/test_exceptions.py b/slycot/tests/test_exceptions.py index b370c34e..28614ce5 100644 --- a/slycot/tests/test_exceptions.py +++ b/slycot/tests/test_exceptions.py @@ -93,6 +93,55 @@ def test_unhandled_info_iwarn(): assert wm[1].message.info == 0 +def test_info_standard_i(): + """Test the handling of standard "`info = -i` + + Raises + ------ + SlycotError + :info = -i: Non-standard msg, info is {info}, -i is -{i} + """ + # No i in check_vars: keep silent + raise_if_slycot_error(-1, docstring=test_info_standard_i.__doc__, + checkvars={'a': 1}) + # -i does not match + raise_if_slycot_error(-1, docstring=test_info_standard_i.__doc__, + checkvars={'i': 2}) + # -i matches, raise the error + with pytest.raises(SlycotError) as ex_info: + raise_if_slycot_error(-1, docstring=test_info_standard_i.__doc__, + checkvars={'i': 1}) + assert str(ex_info.value) == "\nNon-standard msg, info is -1, -i is -1" + + +def test_infospec_nameerror(): + """Test infospec with unknown variable. + + Raises + ------ + SlycotError + :info = v: We do not know {v} + """ + with pytest.raises(RuntimeError) as ex_info: + raise_if_slycot_error(-1, docstring=test_infospec_nameerror.__doc__, + checkvars={'a': 1}) + assert str(ex_info.value) == "Unknown variable in infospec: info = v" + + +def test_infospec_syntaxerror(): + """Test invalid infospec. + + Raises + ------ + SlycotError + :info i: Invalid expression + """ + with pytest.raises(RuntimeError) as ex_info: + raise_if_slycot_error(-1, docstring=test_infospec_syntaxerror.__doc__, + checkvars={'i': 1}) + assert str(ex_info.value) == "Invalid infospec: info i" + + # Test code for test_xerbla_override CODE = """ import sys From 23d5ef6d0ad7df4af382ddddf06ab91be41f2213 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 5 Mar 2024 12:35:11 +0100 Subject: [PATCH 377/405] Update to SLICOT v5.9 --- slycot/src/SLICOT-Reference | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/SLICOT-Reference b/slycot/src/SLICOT-Reference index 979f39d7..795051cb 160000 --- a/slycot/src/SLICOT-Reference +++ b/slycot/src/SLICOT-Reference @@ -1 +1 @@ -Subproject commit 979f39d7863628407b0f9cae6804efc2833849ab +Subproject commit 795051cbc2a1d4766753e9ab3bac13eaf731f8d6 From c6e6b7c18980b996d93b4078500b115ba37017ef Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Tue, 5 Mar 2024 12:56:30 +0100 Subject: [PATCH 378/405] Update CMakeLists.txt and init with new SLICOT routine count --- slycot/CMakeLists.txt | 12 ++++++++++++ slycot/__init__.py | 4 ++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/slycot/CMakeLists.txt b/slycot/CMakeLists.txt index 37b4d34d..dc2c59b1 100644 --- a/slycot/CMakeLists.txt +++ b/slycot/CMakeLists.txt @@ -58,6 +58,7 @@ src/SLICOT-Reference/src/AB13DD.f src/SLICOT-Reference/src/AB13DX.f src/SLICOT-Reference/src/AB13ED.f src/SLICOT-Reference/src/AB13FD.f +src/SLICOT-Reference/src/AB13HD.f src/SLICOT-Reference/src/AB13ID.f src/SLICOT-Reference/src/AB13MD.f src/SLICOT-Reference/src/AB8NXZ.f @@ -105,6 +106,8 @@ src/SLICOT-Reference/src/MA01AD.f src/SLICOT-Reference/src/MA01BD.f src/SLICOT-Reference/src/MA01BZ.f src/SLICOT-Reference/src/MA01CD.f +src/SLICOT-Reference/src/MA01DD.f +src/SLICOT-Reference/src/MA01DZ.f src/SLICOT-Reference/src/MA02AD.f src/SLICOT-Reference/src/MA02AZ.f src/SLICOT-Reference/src/MA02BD.f @@ -131,6 +134,8 @@ src/SLICOT-Reference/src/MA02OD.f src/SLICOT-Reference/src/MA02OZ.f src/SLICOT-Reference/src/MA02PD.f src/SLICOT-Reference/src/MA02PZ.f +src/SLICOT-Reference/src/MA02RD.f +src/SLICOT-Reference/src/MA02SD.f src/SLICOT-Reference/src/MB01KD.f src/SLICOT-Reference/src/MB01LD.f src/SLICOT-Reference/src/MB01MD.f @@ -322,7 +327,13 @@ src/SLICOT-Reference/src/MB04QF.f src/SLICOT-Reference/src/MB04QS.f src/SLICOT-Reference/src/MB04QU.f src/SLICOT-Reference/src/MB04RB.f +src/SLICOT-Reference/src/MB04RD.f +src/SLICOT-Reference/src/MB04RS.f +src/SLICOT-Reference/src/MB04RT.f src/SLICOT-Reference/src/MB04RU.f +src/SLICOT-Reference/src/MB04RV.f +src/SLICOT-Reference/src/MB04RW.f +src/SLICOT-Reference/src/MB04RZ.f src/SLICOT-Reference/src/MB04SU.f src/SLICOT-Reference/src/MB04TB.f src/SLICOT-Reference/src/MB04TS.f @@ -613,6 +624,7 @@ src/SLICOT-Reference/src/UD01MD.f src/SLICOT-Reference/src/UD01MZ.f src/SLICOT-Reference/src/UD01ND.f src/SLICOT-Reference/src/UE01MD.f +src/SLICOT-Reference/src/zelctg.f src/SLICOT-Reference/src/delctg.f src/SLICOT-Reference/src/select.f diff --git a/slycot/__init__.py b/slycot/__init__.py index f2ba5270..c1243ea5 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -27,7 +27,7 @@ # U : Utility Routines - # Analysis routines (18/60 wrapped) + # Analysis routines (18/61 wrapped) from .analysis import (ab01nd, ab04md, ab05md, ab05nd, @@ -47,7 +47,7 @@ # Identification routines (0/15 wrapped) - # Mathematical routines (8/281 wrapped) + # Mathematical routines (8/291 wrapped) from .math import (mb02ed, mb03rd, mb03vd, mb03vy, mb03wd, mb05md, mb05nd, mc01td) From 88bf7217dba4511c39e8334d288bec394a77f90f Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Thu, 4 Apr 2024 22:36:17 +0200 Subject: [PATCH 379/405] Update conda index command (#234) * See also python-control/python-control#981 --- .github/workflows/slycot-build-and-test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 1279647c..60b978c6 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -174,7 +174,7 @@ jobs: mkdir -p "slycot-conda-pkgs/${conda_platform}" cp "${conda_pkg}" "slycot-conda-pkgs/${conda_platform}/" done - conda index --no-progress ./slycot-conda-pkgs + python -m conda_index ./slycot-conda-pkgs - name: Save to local conda pkg channel uses: actions/upload-artifact@v3 with: From 9f3a18b795d5c736817b7a9c1aacccfde3fa1d92 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Tue, 3 Sep 2024 22:28:39 -0700 Subject: [PATCH 380/405] CI: update macos gfortran version --- .github/workflows/slycot-build-and-test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 60b978c6..93d9651a 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -113,7 +113,7 @@ jobs: echo "bla_vendor option ${{ matrix.bla_vendor }} not supported" exit 1 ;; esac - echo "FC=gfortran-11" >> $GITHUB_ENV + echo "FC=gfortran-14" >> $GITHUB_ENV - name: Build wheel env: BLA_VENDOR: ${{ matrix.bla_vendor }} From 1930e335776dc4c1a2822e079f25217c3c86e234 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Tue, 3 Sep 2024 22:43:29 -0700 Subject: [PATCH 381/405] CI: update OpenBLAS path for macos, build-pip --- .github/workflows/slycot-build-and-test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 93d9651a..b2ac6961 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -106,8 +106,8 @@ jobs: unset | Generic | Apple ) ;; # Found in system OpenBLAS ) brew install openblas - echo "BLAS_ROOT=/usr/local/opt/openblas/" >> $GITHUB_ENV - echo "LAPACK_ROOT=/usr/local/opt/openblas/" >> $GITHUB_ENV + echo "LDFLAGS=-L/opt/homebrew/opt/openblas/lib" >> $GITHUB_ENV + echo "CPPFLAGS=-I/opt/homebrew/opt/openblas/include" >> $GITHUB_ENV ;; *) echo "bla_vendor option ${{ matrix.bla_vendor }} not supported" From a1418cfd3e81022cfbc93a161ab08f4a6ee8c782 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Tue, 3 Sep 2024 16:28:42 -0700 Subject: [PATCH 382/405] CI: upgrade upload-artifact, download-artifact Following deprecation notice at https://github.blog/changelog/2024-04-16-deprecation-notice-v3-of-the-artifact-actions/ --- .github/workflows/slycot-build-and-test.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index b2ac6961..5fc4cf28 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -126,7 +126,7 @@ jobs: mkdir -p ${wheeldir} cp ./slycot*.whl ${wheeldir}/ - name: Save wheel - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: slycot-wheels path: slycot-wheels @@ -176,7 +176,7 @@ jobs: done python -m conda_index ./slycot-conda-pkgs - name: Save to local conda pkg channel - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: slycot-conda-pkgs path: slycot-conda-pkgs @@ -192,7 +192,7 @@ jobs: - name: Checkout Slycot uses: actions/checkout@v3 - name: Download wheels (if any) - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: slycot-wheels path: slycot-wheels @@ -210,7 +210,7 @@ jobs: - name: Checkout Slycot uses: actions/checkout@v3 - name: Download conda packages - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: slycot-conda-pkgs path: slycot-conda-pkgs @@ -272,7 +272,7 @@ jobs: exit 1 ;; esac - name: Download wheels - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: slycot-wheels path: slycot-wheels @@ -331,7 +331,7 @@ jobs: channel-priority: strict auto-activate-base: false - name: Download conda packages - uses: actions/download-artifact@v3 + uses: actions/download-artifact@v4 with: name: slycot-conda-pkgs path: slycot-conda-pkgs From c47b63fdc8b3e7d05f8d28a3207ddb857b846489 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Tue, 3 Sep 2024 17:00:05 -0700 Subject: [PATCH 383/405] CI: unique upload names given immutability Reference: https://github.com/actions/download-artifact/blob/fa0a91b85d4f404e444e00e005971372dc801d16/docs/MIGRATION.md#multiple-uploads-to-the-same-named-artifact --- .github/workflows/slycot-build-and-test.yml | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 5fc4cf28..9fbd030d 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -128,8 +128,9 @@ jobs: - name: Save wheel uses: actions/upload-artifact@v4 with: - name: slycot-wheels + name: slycot-wheels-${{ matrix.os }}-${{ matrix.python }}-${{ matrix.bla_vendor }} path: slycot-wheels + retention-days: 5 build-conda: name: Build conda, ${{ matrix.os }} @@ -178,8 +179,9 @@ jobs: - name: Save to local conda pkg channel uses: actions/upload-artifact@v4 with: - name: slycot-conda-pkgs + name: slycot-conda-pkgs-${{ matrix.os }}-${{ matrix.python }} path: slycot-conda-pkgs + retention-days: 5 create-wheel-test-matrix: name: Create wheel test matrix @@ -189,6 +191,11 @@ jobs: outputs: matrix: ${{ steps.set-matrix.outputs.matrix }} steps: + - name: Merge artifacts + uses: actions/upload-artifact/merge@v4 + with: + name: slycot-wheels + pattern: slycot-wheels-* - name: Checkout Slycot uses: actions/checkout@v3 - name: Download wheels (if any) @@ -207,6 +214,11 @@ jobs: outputs: matrix: ${{ steps.set-matrix.outputs.matrix }} steps: + - name: Merge artifacts + uses: actions/upload-artifact/merge@v4 + with: + name: slycot-conda-pkgs + pattern: slycot-conda-pkgs-* - name: Checkout Slycot uses: actions/checkout@v3 - name: Download conda packages From 8897879592dd7f0889b0f09158469feae8fdcbc2 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Mon, 23 Dec 2024 10:59:12 +0200 Subject: [PATCH 384/405] Add unit tests for AB09ND Add SLICOT reference example test, and iwork error regression test. --- slycot/tests/test_ab09nd.py | 93 +++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 slycot/tests/test_ab09nd.py diff --git a/slycot/tests/test_ab09nd.py b/slycot/tests/test_ab09nd.py new file mode 100644 index 00000000..dd08097a --- /dev/null +++ b/slycot/tests/test_ab09nd.py @@ -0,0 +1,93 @@ +# ab09nd - model order reduction + +import numpy as np +from slycot import ab09nd + +# SLICOT reference test; see SLICOT-Reference/examples/AB09ND.dat, AB09ND.res, TAB09ND.f +def test_slicot_ref(): + n = 7 + m = 2 + p = 3 + nr = None # Slycot uses None for ordsel = 'A' + alpha = -0.6 + tol1 = 1e-1 + tol2 = 1e-14 + dico = 'C' + job = 'N' + equil = 'N' + + a = np.array([[-0.04165, 0.0000, 4.9200, -4.9200, 0.0000, 0.0000, 0.0000], + [-5.2100, -12.500, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000], + [0.0000, 3.3300, -3.3300, 0.0000, 0.0000, 0.0000, 0.0000], + [0.5450, 0.0000, 0.0000, 0.0000, -0.5450, 0.0000, 0.0000], + [0.0000, 0.0000, 0.0000, 4.9200, -0.04165, 0.0000, 4.9200], + [0.0000, 0.0000, 0.0000, 0.0000, -5.2100, -12.500, 0.0000], + [0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 3.3300, -3.3300]]) + + b = np.array([[0.0000, 0.0000], + [12.500, 0.0000], + [0.0000, 0.0000], + [0.0000, 0.0000], + [0.0000, 0.0000], + [0.0000, 12.500], + [0.0000, 0.0000]]) + + c = np.array([[1.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000], + [0.0000, 0.0000, 0.0000, 1.0000, 0.0000, 0.0000, 0.0000], + [0.0000, 0.0000, 0.0000, 0.0000, 1.0000, 0.0000, 0.0000]]) + + d = np.zeros((3,2)) + + nr, ar, br, cr, dr, ns, hsv = \ + ab09nd(dico, job, equil, n, m, p, a, b, c, d, alpha, nr, tol1, tol2) + + # reference values + ref_nr = 5 + ref_hsv = np.array([1.9178, 0.8621, 0.7666, 0.0336, 0.0246]) + ref_ar = np.array([[-0.5181, -1.1084, 0.0000, 0.0000, 0.0000], + [ 8.8157, -0.5181, 0.0000, 0.0000, 0.0000], + [ 0.0000, 0.0000, 0.5847, 0.0000, 1.9230], + [ 0.0000, 0.0000, 0.0000, -1.6606, 0.0000], + [ 0.0000, 0.0000, -4.3823, 0.0000, -3.2922]]) + + ref_br = np.array([[-1.2837, 1.2837], + [-0.7522, 0.7522], + [-0.6379, -0.6379], + [ 2.0656, -2.0656], + [-3.9315, -3.9315]]) + + ref_cr = np.array([[-0.1380, -0.6445, -0.6416, -0.6293, 0.2526], + [ 0.6246, 0.0196, 0.0000, 0.4107, 0.0000], + [ 0.1380, 0.6445, -0.6416, 0.6293, 0.2526]]) + + ref_dr = np.array([[ 0.0582, -0.0090], + [ 0.0015, -0.0015], + [-0.0090, 0.0582]]) + + assert nr == ref_nr + + np.testing.assert_array_almost_equal(hsv[:nr], ref_hsv, decimal=4) + np.testing.assert_array_almost_equal(ar, ref_ar, decimal=4) + np.testing.assert_array_almost_equal(br, ref_br, decimal=4) + np.testing.assert_array_almost_equal(cr, ref_cr, decimal=4) + np.testing.assert_array_almost_equal(dr, ref_dr, decimal=4) + + +# gh-242 regression test +# iwork was incorrectly sized +def test_gh242_regression(): + n = 67 + m = 1 + p = 1 + + a = -np.eye(n) + b = np.zeros((n, m)) + c = np.zeros((p, n)) + d = np.array([[42.24]]) + + nr, ar, br, cr, dr, ns, hsv = \ + ab09nd(dico='C', job='B', equil='S', n=a.shape[0], + m=b.shape[1], p=c.shape[0], A=a, B=b, C=c, D=d) + + assert nr == 0 + np.testing.assert_equal(d, dr) From 8db9343ebc0322bc956d922574aa6365713af9e0 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Mon, 23 Dec 2024 11:04:22 +0200 Subject: [PATCH 385/405] Correct iwork size expression for ab09nd --- slycot/src/analysis.pyf | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slycot/src/analysis.pyf b/slycot/src/analysis.pyf index 1789d893..d161e16f 100644 --- a/slycot/src/analysis.pyf +++ b/slycot/src/analysis.pyf @@ -315,7 +315,7 @@ subroutine ab09nd(dico,job,equil,ordsel,n,m,p,nr,alpha,a,lda,b,ldb,c,ldc,d,ldd,n double precision intent(out),dimension(n),depend(n) :: hsv double precision :: tol1 =0.0 double precision :: tol2 =0.0 - integer intent(hide,cache),dimension(max(m,p)) :: iwork + integer intent(hide,cache),dimension(max(1,2*n)) :: iwork double precision intent(hide,cache),dimension(ldwork) :: dwork integer optional :: ldwork = max(1,n*(2*n+max(n,max(m,p))+5)+n*(n+1)/2) integer intent(out) :: iwarn From 9c1039fee1bcd9d200935e356c07ed6db28f6cca Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 23 Dec 2024 11:49:42 +0100 Subject: [PATCH 386/405] New Ubuntu: libopenblas package changed --- .github/workflows/slycot-build-and-test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 9fbd030d..10cfc0e6 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -261,7 +261,7 @@ jobs: sudo apt-get -y update case ${{ matrix.blas_lib }} in Generic ) sudo apt-get -y install libblas3 liblapack3 ;; - unset | OpenBLAS ) sudo apt-get -y install libopenblas-base ;; + unset | OpenBLAS ) sudo apt-get -y install libopenblas0 ;; *) echo "BLAS ${{ matrix.blas_lib }} not supported for wheels on Ubuntu" exit 1 ;; From a7c0232bca5a2dd38cdfc47a1c0184262162097e Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 23 Dec 2024 12:14:36 +0100 Subject: [PATCH 387/405] Remove deprecated mambaforge --- .github/workflows/slycot-build-and-test.yml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 10cfc0e6..a5443aa6 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -154,13 +154,12 @@ jobs: fetch-depth: 0 submodules: 'recursive' - name: Setup Conda - uses: conda-incubator/setup-miniconda@v2 + uses: conda-incubator/setup-miniconda@v3 with: python-version: ${{ matrix.python }} activate-environment: build-env environment-file: .github/conda-env/build-env.yml miniforge-version: latest - miniforge-variant: Mambaforge channel-priority: strict auto-update-conda: false auto-activate-base: false @@ -333,11 +332,10 @@ jobs: if: matrix.os == 'macos' run: brew install coreutils - name: Setup Conda - uses: conda-incubator/setup-miniconda@v2 + uses: conda-incubator/setup-miniconda@v3 with: python-version: ${{ matrix.python }} miniforge-version: latest - miniforge-variant: Mambaforge activate-environment: test-env environment-file: slycot-src/.github/conda-env/test-env.yml channel-priority: strict From 85b6153c36e5873b147b612d3ef0b96ca3d82bf7 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 23 Dec 2024 14:09:21 +0100 Subject: [PATCH 388/405] Update bash command --- .github/workflows/slycot-build-and-test.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index a5443aa6..db656548 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -164,7 +164,7 @@ jobs: auto-update-conda: false auto-activate-base: false - name: Conda build - shell: bash -l {0} + shell: bash -el {0} run: | set -e conda mambabuild conda-recipe @@ -316,7 +316,7 @@ jobs: defaults: run: - shell: bash -l {0} + shell: bash -el {0} steps: - name: Checkout Slycot @@ -368,7 +368,7 @@ jobs: mamba install -c ./slycot-conda-pkgs slycot conda list - name: Slycot and python-control tests - run: JOBNAME="$JOBNAME" bash slycot-src/.github/scripts/run-tests.sh + run: JOBNAME="$JOBNAME" bash -el slycot-src/.github/scripts/run-tests.sh env: JOBNAME: conda ${{ matrix.packagekey }} ${{ matrix.blas_lib }} - name: report coverage From d0b4fadbadfe3e8affa8461f5b8afd775a22a3d3 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 23 Dec 2024 14:13:44 +0100 Subject: [PATCH 389/405] replace mamba with conda Once again they broke something: https://github.com/conda-incubator/setup-miniconda/issues/371 --- .github/workflows/slycot-build-and-test.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index db656548..1c542d12 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -167,7 +167,7 @@ jobs: shell: bash -el {0} run: | set -e - conda mambabuild conda-recipe + conda build conda-recipe # preserve directory structure for custom conda channel find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do conda_platform=$(basename $(dirname "${conda_pkg}")) @@ -350,22 +350,22 @@ jobs: set -e case ${{ matrix.blas_lib }} in unset ) # the conda-forge default (os dependent) - mamba install libblas libcblas liblapack + conda install libblas libcblas liblapack ;; Generic ) - mamba install 'libblas=*=*netlib' 'libcblas=*=*netlib' 'liblapack=*=*netlib' + conda install 'libblas=*=*netlib' 'libcblas=*=*netlib' 'liblapack=*=*netlib' echo "libblas * *netlib" >> $CONDA_PREFIX/conda-meta/pinned ;; OpenBLAS ) - mamba install 'libblas=*=*openblas' openblas + conda install 'libblas=*=*openblas' openblas echo "libblas * *openblas" >> $CONDA_PREFIX/conda-meta/pinned ;; Intel10_64lp ) - mamba install 'libblas=*=*mkl' mkl + conda install 'libblas=*=*mkl' mkl echo "libblas * *mkl" >> $CONDA_PREFIX/conda-meta/pinned ;; esac - mamba install -c ./slycot-conda-pkgs slycot + conda install -c ./slycot-conda-pkgs slycot conda list - name: Slycot and python-control tests run: JOBNAME="$JOBNAME" bash -el slycot-src/.github/scripts/run-tests.sh From af3fe2ddf54b788e240d4c0a221f4f20759e1d94 Mon Sep 17 00:00:00 2001 From: Ben Greiner Date: Mon, 23 Dec 2024 14:47:16 +0100 Subject: [PATCH 390/405] macos runners are now arm64. There is no Intel MKL on Arm --- .github/scripts/set-conda-test-matrix.py | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/.github/scripts/set-conda-test-matrix.py b/.github/scripts/set-conda-test-matrix.py index 954480cb..2e0b9568 100644 --- a/.github/scripts/set-conda-test-matrix.py +++ b/.github/scripts/set-conda-test-matrix.py @@ -10,10 +10,8 @@ 'win': 'windows', } -blas_implementations = ['unset', 'Generic', 'OpenBLAS', 'Intel10_64lp'] - -combinations = {'ubuntu': blas_implementations, - 'macos': blas_implementations, +combinations = {'ubuntu': ['unset', 'Generic', 'OpenBLAS', 'Intel10_64lp'], + 'macos': ['unset', 'Generic', 'OpenBLAS'], 'windows': ['unset', 'Intel10_64lp'], } From f305cc5199e243e0977c5c6dff401da919aae567 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 19 Jan 2025 11:52:34 +0200 Subject: [PATCH 391/405] Run "ruff check" on source in Github action --- .github/workflows/slycot-build-and-test.yml | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 1c542d12..4050bad9 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -12,6 +12,24 @@ on: jobs: + ruff-lint: + name: Static lint checks with ruff + runs-on: ubuntu-latest + steps: + - name: Checkout Slycot + uses: actions/checkout@v3 + with: + fetch-depth: 0 + submodules: 'recursive' + - name: Set up Python + uses: actions/setup-python@v4 + with: + python-version: '3.11' + - name: Run ruff check + run: | + pip install ruff + ruff check slycot + build-sdist: # Super fast sniff build. If this fails, don't start the other jobs name: Build sdist on Ubuntu From 897858449be1b8488a2b6b2f7a94b21efd9d8c85 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 19 Jan 2025 11:54:28 +0200 Subject: [PATCH 392/405] Make source `ruff check`-clean Removed unused imports. Removed unused variables in test: these were cut-and-paste from other tests, and not needed for the tests in questions. Other minor fixes. --- slycot/__init__.py | 11 +++++++++++ slycot/analysis.py | 4 ++-- slycot/examples.py | 5 ++--- slycot/exceptions.py | 4 ++-- slycot/tests/test_ab13bd.py | 2 +- slycot/tests/test_ab13md.py | 2 +- slycot/tests/test_mb.py | 28 ---------------------------- slycot/tests/test_sb.py | 2 +- slycot/tests/test_tb05ad.py | 2 -- slycot/tests/test_tg01ad.py | 2 +- slycot/tests/test_tg01fd.py | 4 ++-- slycot/transform.py | 4 ++-- 12 files changed, 25 insertions(+), 45 deletions(-) diff --git a/slycot/__init__.py b/slycot/__init__.py index c1243ea5..6cb415d0 100644 --- a/slycot/__init__.py +++ b/slycot/__init__.py @@ -79,6 +79,17 @@ from .version import __version__ + __all__ = [ + ab01nd, ab04md, ab05md, ab05nd, ab07nd, ab08nd, ab08nz, + ab09ad, ab09ax, ab09bd, ab09md, ab09nd, ab13bd, ab13dd, + ab13ed, ab13fd, ab13md, ag08bd, mb02ed, mb03rd, mb03vd, + mb03vy, mb03wd, mb05md, mb05nd, mc01td, sb01bd, sb02md, + sb02mt, sb02od, sb03md, sb03md57, sb03od, sb04md, sb04qd, + sb10ad, sb10dd, sb10fd, sb10hd, sb10jd, sb10yd, sg02ad, + sg03ad, sg03bd, tb01id, tb01pd, tb03ad, tb04ad, tb05ad, + tc01od, tc04ad, td04ad, tf01md, tf01rd, tg01ad, tg01fd, + __version__ + ] def test(): import pytest diff --git a/slycot/analysis.py b/slycot/analysis.py index 230eedb9..e4c7a6a0 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1827,7 +1827,7 @@ def ab13md(Z, nblock, itype, x=None): else: fact='F' if len(x) != m+mr-1: - raise ValueError(f'Require len(x)==m+mr-1, but' + raise ValueError('Require len(x)==m+mr-1, but' + f' len(x)={len(x)}, m={m}, mr={mr}') x = np.concatenate([x,np.zeros(2*m-1-len(x))]) @@ -1838,7 +1838,7 @@ def ab13md(Z, nblock, itype, x=None): return bound, d, g, x[:m+mr-1] -def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): +def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): # noqa: E741 """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) To extract from the system pencil diff --git a/slycot/examples.py b/slycot/examples.py index cf306913..9e41a256 100644 --- a/slycot/examples.py +++ b/slycot/examples.py @@ -33,7 +33,6 @@ def sb02md_example(): print('rcond =', out[1]) def sb03md_example(): - from numpy import zeros A = array([ [3, 1, 1], [1, 3, 0], [0, 0, 3]]) @@ -47,7 +46,7 @@ def sb03md_example(): print('scaling factor:', out[3]) def ab08nd_example(): - from numpy import zeros, size + from numpy import zeros from scipy.linalg import eigvals A = array([ [1, 0, 0, 0, 0, 0], [0, 1, 0, 0, 0, 0], @@ -153,7 +152,7 @@ def mc01td_example(): print('The polynomial has', out[2], 'unstable zeros') def sb02od_example(): - from numpy import zeros, shape, dot, ones + from numpy import dot, ones A = array([ [0, 1], [0, 0]]) B = array([ [0], diff --git a/slycot/exceptions.py b/slycot/exceptions.py index f08bb3f6..a91a8390 100644 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -77,7 +77,7 @@ def _parse_docsection(section_name, docstring, checkvars): continue section_indent = next(docline).index("-") - for l in docline: + for l in docline: # noqa: E741 # ignore blank lines if not l.strip(): continue @@ -121,7 +121,7 @@ def _parse_docsection(section_name, docstring, checkvars): break # docstring body_indent = len(mmatch.group(1)) message += mmatch.group(2) + '\n' - for l in docline: + for l in docline: # noqa: E741 if l and not l[:body_indent].isspace(): break # message body message += l[body_indent:] + '\n' diff --git a/slycot/tests/test_ab13bd.py b/slycot/tests/test_ab13bd.py index dd2a735a..ed4f6b92 100644 --- a/slycot/tests/test_ab13bd.py +++ b/slycot/tests/test_ab13bd.py @@ -2,7 +2,7 @@ # ab08n* tests import numpy as np -from numpy.testing import assert_allclose, assert_array_equal, assert_equal +from numpy.testing import assert_allclose, assert_array_equal from scipy import linalg, signal from slycot import analysis diff --git a/slycot/tests/test_ab13md.py b/slycot/tests/test_ab13md.py index 5a30f5ba..ac933e1f 100644 --- a/slycot/tests/test_ab13md.py +++ b/slycot/tests/test_ab13md.py @@ -1,6 +1,6 @@ import numpy as np import pytest -from numpy.testing import assert_allclose, assert_array_less +from numpy.testing import assert_allclose from slycot import ab13md diff --git a/slycot/tests/test_mb.py b/slycot/tests/test_mb.py index 5dc5dcd5..745d382a 100644 --- a/slycot/tests/test_mb.py +++ b/slycot/tests/test_mb.py @@ -2,8 +2,6 @@ # test_mb.py - test suite for linear algebra commands # bnavigator , Aug 2019 -import sys - import numpy as np import pytest from numpy.testing import assert_allclose @@ -96,19 +94,6 @@ def test_mb02ed_parameter_errors(): [1.0000, 2.0000], ] ) - X = np.array( - [ - [0.2408, 0.4816], - [0.1558, 0.3116], - [0.1534, 0.3068], - [0.2302, 0.4603], - [0.1467, 0.2934], - [0.1537, 0.3075], - [0.2349, 0.4698], - [0.1498, 0.2995], - [0.1653, 0.3307], - ] - ) # Test for wrong parameter typet with pytest.raises(expected_exception=SlycotParameterError, match='typet must be either "R" or "C"') as cm: @@ -162,19 +147,6 @@ def test_mb02ed_matrix_error(): [1.0000, 2.0000], ] ) - X = np.array( - [ - [0.2408, 0.4816], - [0.1558, 0.3116], - [0.1534, 0.3068], - [0.2302, 0.4603], - [0.1467, 0.2934], - [0.1537, 0.3075], - [0.2349, 0.4698], - [0.1498, 0.2995], - [0.1653, 0.3307], - ] - ) with pytest.raises(SlycotArithmeticError, match = "The reduction algorithm failed. " diff --git a/slycot/tests/test_sb.py b/slycot/tests/test_sb.py index e6f97a07..ceccad3b 100644 --- a/slycot/tests/test_sb.py +++ b/slycot/tests/test_sb.py @@ -7,7 +7,7 @@ from slycot import synthesis from slycot.exceptions import (SlycotArithmeticError, SlycotParameterError, - SlycotResultWarning, raise_if_slycot_error) + SlycotResultWarning) from .test_exceptions import assert_docstring_parse diff --git a/slycot/tests/test_tb05ad.py b/slycot/tests/test_tb05ad.py index 900a49a2..e940c45f 100644 --- a/slycot/tests/test_tb05ad.py +++ b/slycot/tests/test_tb05ad.py @@ -1,8 +1,6 @@ # =================================================== # tb05ad tests -import sys - import numpy as np import pytest from numpy.testing import assert_almost_equal diff --git a/slycot/tests/test_tg01ad.py b/slycot/tests/test_tg01ad.py index 864d41be..885f4c1c 100644 --- a/slycot/tests/test_tg01ad.py +++ b/slycot/tests/test_tg01ad.py @@ -2,7 +2,7 @@ # tg01ad tests import numpy as np -from numpy.testing import assert_almost_equal, assert_equal, assert_raises +from numpy.testing import assert_almost_equal from slycot import transform diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py index 902d1ef2..5b960362 100644 --- a/slycot/tests/test_tg01fd.py +++ b/slycot/tests/test_tg01fd.py @@ -2,7 +2,7 @@ # tg01fd tests import numpy as np -from numpy.testing import assert_almost_equal, assert_equal, assert_raises +from numpy.testing import assert_almost_equal, assert_equal from slycot import transform @@ -76,7 +76,7 @@ def test1_tg01fd(): def test2_tg01fd(): """ verify that Q and Z output with compq and compz set to 'U' equals the dot product of Q and Z input and Q and Z output with compq and compz set to 'I' """ - l = 30 + l = 30 # noqa: E741 n = 30 m = 70 p = 44 diff --git a/slycot/transform.py b/slycot/transform.py index 43762b5a..660e90ec 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -969,7 +969,7 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): raise_if_slycot_error(out[-1], arg_list) return out[0] -def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): +def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): # noqa: E741 """ A,E,B,C,lscale,rscale = tg01ad(l,n,m,p,A,E,B,C,[thresh,job]) To balance the matrices of the system pencil @@ -1069,7 +1069,7 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): raise_if_slycot_error(info, arg_list) return A,E,B,C,lscale,rscale -def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): +def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): # noqa: E741 """ A,E,B,C,ranke,rnka22,Q,Z = tg01fd(l,n,m,p,A,E,B,C,[Q,Z,compq,compz,joba,tol,ldwork]) To compute for the descriptor system (A-lambda E,B,C) From f1cb8890d9401948ecdbc251811c395a0bd6f2a9 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 1 Feb 2025 06:18:16 +0200 Subject: [PATCH 393/405] Disable Ruff 3741 project-wide --- pyproject.toml | 3 +++ slycot/analysis.py | 2 +- slycot/exceptions.py | 4 ++-- slycot/tests/test_tg01fd.py | 2 +- slycot/transform.py | 4 ++-- 5 files changed, 9 insertions(+), 6 deletions(-) diff --git a/pyproject.toml b/pyproject.toml index c984562f..dea6895f 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -51,3 +51,6 @@ write_to = "slycot/version.py" [tool.pytest.ini_options] # run the tests with compiled and installed package addopts = "--pyargs slycot" + +[tool.ruff.lint] +ignore = [ "E741" ] diff --git a/slycot/analysis.py b/slycot/analysis.py index e4c7a6a0..4d5383c4 100644 --- a/slycot/analysis.py +++ b/slycot/analysis.py @@ -1838,7 +1838,7 @@ def ab13md(Z, nblock, itype, x=None): return bound, d, g, x[:m+mr-1] -def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): # noqa: E741 +def ag08bd(l,n,m,p,A,E,B,C,D,equil='N',tol=0.0,ldwork=None): """ Af,Ef,nrank,niz,infz,kronr,infe,kronl = ag08bd(l,n,m,p,A,E,B,C,D,[equil,tol,ldwork]) To extract from the system pencil diff --git a/slycot/exceptions.py b/slycot/exceptions.py index a91a8390..f08bb3f6 100644 --- a/slycot/exceptions.py +++ b/slycot/exceptions.py @@ -77,7 +77,7 @@ def _parse_docsection(section_name, docstring, checkvars): continue section_indent = next(docline).index("-") - for l in docline: # noqa: E741 + for l in docline: # ignore blank lines if not l.strip(): continue @@ -121,7 +121,7 @@ def _parse_docsection(section_name, docstring, checkvars): break # docstring body_indent = len(mmatch.group(1)) message += mmatch.group(2) + '\n' - for l in docline: # noqa: E741 + for l in docline: if l and not l[:body_indent].isspace(): break # message body message += l[body_indent:] + '\n' diff --git a/slycot/tests/test_tg01fd.py b/slycot/tests/test_tg01fd.py index 5b960362..27bc9cb4 100644 --- a/slycot/tests/test_tg01fd.py +++ b/slycot/tests/test_tg01fd.py @@ -76,7 +76,7 @@ def test1_tg01fd(): def test2_tg01fd(): """ verify that Q and Z output with compq and compz set to 'U' equals the dot product of Q and Z input and Q and Z output with compq and compz set to 'I' """ - l = 30 # noqa: E741 + l = 30 n = 30 m = 70 p = 44 diff --git a/slycot/transform.py b/slycot/transform.py index 660e90ec..43762b5a 100644 --- a/slycot/transform.py +++ b/slycot/transform.py @@ -969,7 +969,7 @@ def tf01rd(n,m,p,N,A,B,C,ldwork=None): raise_if_slycot_error(out[-1], arg_list) return out[0] -def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): # noqa: E741 +def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): """ A,E,B,C,lscale,rscale = tg01ad(l,n,m,p,A,E,B,C,[thresh,job]) To balance the matrices of the system pencil @@ -1069,7 +1069,7 @@ def tg01ad(l,n,m,p,A,E,B,C,thresh=0.0,job='A'): # noqa: E741 raise_if_slycot_error(info, arg_list) return A,E,B,C,lscale,rscale -def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): # noqa: E741 +def tg01fd(l,n,m,p,A,E,B,C,Q=None,Z=None,compq='N',compz='N',joba='N',tol=0.0,ldwork=None): """ A,E,B,C,ranke,rnka22,Q,Z = tg01fd(l,n,m,p,A,E,B,C,[Q,Z,compq,compz,joba,tol,ldwork]) To compute for the descriptor system (A-lambda E,B,C) From 03bff7923ec4da59cecff8757d3673d0608f1573 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Sun, 16 Feb 2025 16:22:43 -0800 Subject: [PATCH 394/405] CI: explicitly include defaults channel Similar to changes from https://github.com/python-control/python-control/pull/1129 https://github.com/python-control/python-control/pull/1128 --- .github/workflows/slycot-build-and-test.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 4050bad9..f1d14d42 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -179,6 +179,7 @@ jobs: environment-file: .github/conda-env/build-env.yml miniforge-version: latest channel-priority: strict + channels: conda-forge,defaults auto-update-conda: false auto-activate-base: false - name: Conda build @@ -356,6 +357,7 @@ jobs: miniforge-version: latest activate-environment: test-env environment-file: slycot-src/.github/conda-env/test-env.yml + channels: conda-forge,defaults channel-priority: strict auto-activate-base: false - name: Download conda packages From 0ef94cee26ff48f6daadb3484bc192a8559ecff9 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Mon, 17 Feb 2025 13:35:47 -0800 Subject: [PATCH 395/405] CI: skip python-control/docstrings_test.py It is not useful when testing Slycot, and skipping it allows us to avoid installing numpydoc. --- .github/scripts/run-tests.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/scripts/run-tests.sh b/.github/scripts/run-tests.sh index 2ba81756..f9a8b9fa 100644 --- a/.github/scripts/run-tests.sh +++ b/.github/scripts/run-tests.sh @@ -18,6 +18,7 @@ donttest="$donttest or test_default_deprecation" pytest control/tests \ --cov=$slycot_libdir \ --cov-config=${slycot_srcdir}/.coveragerc \ + --ignore=control/tests/docstrings_test.py \ -k "not ($donttest)" mv .coverage ${slycot_srcdir}/.coverage.control popd From 81a578ac1a8627ada1a51617502bef1073aa5c36 Mon Sep 17 00:00:00 2001 From: "Scott C. Livingston" Date: Mon, 17 Feb 2025 15:09:16 -0800 Subject: [PATCH 396/405] CI: detect errors from set-...-test-matrix scripts --- .github/workflows/slycot-build-and-test.yml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index f1d14d42..9970af4d 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -222,7 +222,10 @@ jobs: name: slycot-wheels path: slycot-wheels - id: set-matrix - run: echo "matrix=$(python3 .github/scripts/set-pip-test-matrix.py)" >> $GITHUB_OUTPUT + run: | + TEMPFILE="$(mktemp)" + python3 .github/scripts/set-pip-test-matrix.py | tee $TEMPFILE + echo "matrix=$(cat $TEMPFILE)" >> $GITHUB_OUTPUT create-conda-test-matrix: name: Create conda test matrix @@ -245,7 +248,10 @@ jobs: name: slycot-conda-pkgs path: slycot-conda-pkgs - id: set-matrix - run: echo "matrix=$(python3 .github/scripts/set-conda-test-matrix.py)" >> $GITHUB_OUTPUT + run: | + TEMPFILE="$(mktemp)" + python3 .github/scripts/set-conda-test-matrix.py | tee $TEMPFILE + echo "matrix=$(cat $TEMPFILE)" >> $GITHUB_OUTPUT test-wheel: From d8318aeb5b2c5e31e9f8690b0980fb5cdce6741a Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 3 Aug 2025 16:11:41 +0200 Subject: [PATCH 397/405] Update license specification to latest packaging standards Fixes two SetuptoolsDeprecationWarnings: - License classifiers are deprecated. - `project.license` as a TOML table is deprecated. --- pyproject.toml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/pyproject.toml b/pyproject.toml index dea6895f..8ea3e90c 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -14,14 +14,11 @@ description = "A wrapper for the SLICOT control and systems library" readme = "README.rst" authors = [{ name = "Enrico Avventi et al." }] maintainers = [{ name = "Slycot developers", email = "python-control-discuss@lists.sourceforge.net"}] -license = {text = "GPL-2.0 AND BSD-3-Clause"} +license = "GPL-2.0 AND BSD-3-Clause" classifiers = [ "Development Status :: 4 - Beta", "Intended Audience :: Science/Research", "Intended Audience :: Developers", - "License :: OSI Approved", - "License :: OSI Approved :: GNU General Public License v2 (GPLv2)", - "License :: OSI Approved :: BSD License", "Programming Language :: C", "Programming Language :: Fortran", "Programming Language :: Python", From ac1076adf73e73c128d49d4681ab9d941ce166d1 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 6 Sep 2025 21:05:51 +0200 Subject: [PATCH 398/405] Update Conda recipe and associated Github workflow Recipe updates based on information gleaned from slycot-feedstock. --- .github/conda-env/build-env.yml | 4 - .github/conda-env/test-env.yml | 9 --- .github/workflows/slycot-build-and-test.yml | 30 ++------ conda-recipe/bld.bat | 2 - conda-recipe/conda_build_config.yaml | 85 +++++++++++---------- conda-recipe/meta.yaml | 8 +- 6 files changed, 55 insertions(+), 83 deletions(-) delete mode 100644 .github/conda-env/build-env.yml delete mode 100644 .github/conda-env/test-env.yml diff --git a/.github/conda-env/build-env.yml b/.github/conda-env/build-env.yml deleted file mode 100644 index f747a77e..00000000 --- a/.github/conda-env/build-env.yml +++ /dev/null @@ -1,4 +0,0 @@ -name: build-env -dependencies: - - boa - - numpy diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml deleted file mode 100644 index bdc01362..00000000 --- a/.github/conda-env/test-env.yml +++ /dev/null @@ -1,9 +0,0 @@ -name: test-env -dependencies: - # in addtion to package dependencies and explicit LAPACK/BLAS implementations installed in workflow - - scipy - - matplotlib - - pytest - - pytest-cov - - pytest-timeout - - coverage diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 9970af4d..d7697016 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -151,9 +151,8 @@ jobs: retention-days: 5 build-conda: - name: Build conda, ${{ matrix.os }} + name: Build conda, ${{ matrix.os }} ${{ matrix.python }} runs-on: ${{ matrix.os }}-latest - needs: build-sdist strategy: fail-fast: false matrix: @@ -162,8 +161,8 @@ jobs: - 'macos' - 'windows' python: - # this is not the packaged version, just the version conda-build runs on. - - '3.11' + - '3.10' + - '3.13' steps: - name: Checkout Slycot @@ -176,30 +175,13 @@ jobs: with: python-version: ${{ matrix.python }} activate-environment: build-env - environment-file: .github/conda-env/build-env.yml miniforge-version: latest + conda-build-version: 25.7.0 channel-priority: strict - channels: conda-forge,defaults - auto-update-conda: false - auto-activate-base: false - name: Conda build - shell: bash -el {0} run: | - set -e - conda build conda-recipe - # preserve directory structure for custom conda channel - find "${CONDA_PREFIX}/conda-bld" -maxdepth 2 -name 'slycot*.tar.bz2' | while read -r conda_pkg; do - conda_platform=$(basename $(dirname "${conda_pkg}")) - mkdir -p "slycot-conda-pkgs/${conda_platform}" - cp "${conda_pkg}" "slycot-conda-pkgs/${conda_platform}/" - done - python -m conda_index ./slycot-conda-pkgs - - name: Save to local conda pkg channel - uses: actions/upload-artifact@v4 - with: - name: slycot-conda-pkgs-${{ matrix.os }}-${{ matrix.python }} - path: slycot-conda-pkgs - retention-days: 5 + conda build conda-recipe --python ${{ matrix.python }} + create-wheel-test-matrix: name: Create wheel test matrix diff --git a/conda-recipe/bld.bat b/conda-recipe/bld.bat index 9f4db0b3..4b2811d0 100644 --- a/conda-recipe/bld.bat +++ b/conda-recipe/bld.bat @@ -1,5 +1,3 @@ -:: correct FC, apparently pointed to host prefix?? -set FC=%BUILD_PREFIX%\Library\bin\flang.exe set BLAS_ROOT=%PREFIX% set LAPACK_ROOT=%PREFIX% diff --git a/conda-recipe/conda_build_config.yaml b/conda-recipe/conda_build_config.yaml index 6c968691..e9a8871e 100644 --- a/conda-recipe/conda_build_config.yaml +++ b/conda-recipe/conda_build_config.yaml @@ -1,46 +1,47 @@ -# https://github.com/conda-forge/blas-feedstock/issues/106#issuecomment-1771747983 -# https://github.com/conda-forge/conda-forge-pinning-feedstock/blob/main/recipe/conda_build_config.yaml -# https://github.com/conda-forge/conda-forge-pinning-feedstock/blob/main/recipe/migrations/python312.yaml - -# zip_keys Python/Numpy matrix to build for -python: - - 3.10.* *_cpython - - 3.12.* *_cpython -numpy: - - 1.23 - - 1.26 - -zip_keys: - - - - python - - numpy - -# Compiler selection +MACOSX_DEPLOYMENT_TARGET: +- '11.0' # [osx] +MACOSX_SDK_VERSION: +- '11.0' # [osx] c_compiler: - - gcc # [linux] - - clang # [osx] - - vs2019 # [win and x86_64] - - vs2022 # [win and arm64] -c_compiler_version: # [unix] - - 12 # [linux] - - 16 # [osx] -fortran_compiler: # [unix or win64] - - gfortran # [linux64 or (osx and x86_64)] - - gfortran # [aarch64 or ppc64le or armv7l or s390x] - - flang # [win64] -fortran_compiler_version: # [unix or win64] - - 12 # [linux] - - 12 # [osx] - - 5 # [win64] - -# Pinning - -# blas +- vs2022 # [win64] +- gcc # [linux] +- clang # [osx] +c_compiler_version: +- '14' # [linux] +- '19' # [osx] +c_stdlib: +- vs # [win64] +- sysroot #[linux] +- macosx_deployment_target # [osx] +c_stdlib_version: +- '2.17' # [linux] +- '11.0' # [osx] +cdt_name: +- conda # [linux] +channel_sources: +- conda-forge +channel_targets: +- conda-forge main +fortran_compiler: +- flang # [win64] +- gfortran # [linux or osx] +fortran_compiler_version: +- '5' # [win64] +- '14' # [linux or osx] libblas: - - 3.9 *netlib +- 3.9 *netlib libcblas: - - 3.9 *netlib +- 3.9 *netlib liblapack: - - 3.9 *netlib -liblapacke: - - 3.9 *netlib \ No newline at end of file +- 3.9 *netlib +numpy: +- '2' +pin_run_as_build: + python: + min_pin: x.x + max_pin: x.x +python: +- 3.10.* *_cpython +- 3.11.* *_cpython +- 3.12.* *_cpython +- 3.13.* *_cp313 diff --git a/conda-recipe/meta.yaml b/conda-recipe/meta.yaml index e01ad376..f5f3f718 100644 --- a/conda-recipe/meta.yaml +++ b/conda-recipe/meta.yaml @@ -11,8 +11,13 @@ build: requirements: build: + - python # [build_platform != target_platform] + - cross-python_{{ target_platform }} # [build_platform != target_platform] + - numpy # [build_platform != target_platform] + - scikit-build >=0.15 # [build_platform != target_platform] - {{ compiler('fortran') }} - {{ compiler('c') }} + - {{ stdlib("c") }} - cmake >=3.14 - make # [linux] host: @@ -26,8 +31,7 @@ requirements: - setuptools >=45 - setuptools_scm >=7 run: - - python {{ PY_VER }} - - {{ pin_compatible('numpy') }} + - python test: requires: From 621cb80655bc7a57dd12e47293410c9ab6e8f4ec Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sat, 6 Sep 2025 21:08:13 +0200 Subject: [PATCH 399/405] Make build-conda require build-sdist in Github workflow --- .github/workflows/slycot-build-and-test.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index d7697016..413edc4d 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -153,6 +153,7 @@ jobs: build-conda: name: Build conda, ${{ matrix.os }} ${{ matrix.python }} runs-on: ${{ matrix.os }}-latest + needs: build-sdist strategy: fail-fast: false matrix: From 1a426a7a0579a24096788261a91f87c60cf01cf6 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 7 Sep 2025 10:07:57 +0200 Subject: [PATCH 400/405] Fix Github conda-build, and reduce Python version matrix --- .github/scripts/set-conda-test-matrix.py | 5 ++- .github/workflows/slycot-build-and-test.yml | 34 +++++++++++++++------ 2 files changed, 29 insertions(+), 10 deletions(-) diff --git a/.github/scripts/set-conda-test-matrix.py b/.github/scripts/set-conda-test-matrix.py index 2e0b9568..684ec752 100644 --- a/.github/scripts/set-conda-test-matrix.py +++ b/.github/scripts/set-conda-test-matrix.py @@ -16,7 +16,7 @@ } conda_jobs = [] -for conda_pkg_file in Path("slycot-conda-pkgs").glob("*/*.tar.bz2"): +for conda_pkg_file in Path("slycot-conda-pkgs").glob("*/*.conda"): cos = osmap[conda_pkg_file.parent.name.split("-")[0]] m = re.search(r'py(\d)(\d+)_', conda_pkg_file.name) pymajor, pyminor = int(m[1]), int(m[2]) @@ -28,5 +28,8 @@ 'blas_lib': cbl} conda_jobs.append(cjob) +if not conda_jobs: + raise SystemExit("No conda packages found") + matrix = { 'include': conda_jobs } print(json.dumps(matrix)) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 413edc4d..1958b288 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -162,7 +162,6 @@ jobs: - 'macos' - 'windows' python: - - '3.10' - '3.13' steps: @@ -174,14 +173,31 @@ jobs: - name: Setup Conda uses: conda-incubator/setup-miniconda@v3 with: - python-version: ${{ matrix.python }} activate-environment: build-env - miniforge-version: latest - conda-build-version: 25.7.0 channel-priority: strict + channels: defaults + conda-build-version: 25.7.0 + miniforge-version: latest + python-version: ${{ matrix.python }} - name: Conda build + shell: bash -el {0} run: | + set -e conda build conda-recipe --python ${{ matrix.python }} + # preserve directory structure for custom conda channel + CONDA_ROOT=$(conda info --base) + find "${CONDA_ROOT}/conda-bld" -maxdepth 2 -name 'slycot*.conda' | while read -r conda_pkg; do + conda_platform=$(basename $(dirname "${conda_pkg}")) + mkdir -p "slycot-conda-pkgs/${conda_platform}" + cp "${conda_pkg}" "slycot-conda-pkgs/${conda_platform}/" + done + conda index ./slycot-conda-pkgs + - name: Save to local conda pkg channel + uses: actions/upload-artifact@v4 + with: + name: slycot-conda-pkgs-${{ matrix.os }}-${{ matrix.python }} + path: slycot-conda-pkgs + retention-days: 5 create-wheel-test-matrix: @@ -342,13 +358,12 @@ jobs: - name: Setup Conda uses: conda-incubator/setup-miniconda@v3 with: - python-version: ${{ matrix.python }} - miniforge-version: latest activate-environment: test-env - environment-file: slycot-src/.github/conda-env/test-env.yml - channels: conda-forge,defaults channel-priority: strict - auto-activate-base: false + channels: defaults + environment-file: slycot-src/.github/conda-env/test-env.yml + miniforge-version: latest + python-version: ${{ matrix.python }} - name: Download conda packages uses: actions/download-artifact@v4 with: @@ -387,6 +402,7 @@ jobs: parallel: true file: slycot-src/coverage.xml + coveralls-final: name: Finalize parallel coveralls if: always() From 643aacfc7bef93dd9f21818571bdf626893c9d1b Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 7 Sep 2025 11:36:03 +0200 Subject: [PATCH 401/405] Add conda-forge to channels --- .github/workflows/slycot-build-and-test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 1958b288..08598b5a 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -175,7 +175,7 @@ jobs: with: activate-environment: build-env channel-priority: strict - channels: defaults + channels: conda-forge,defaults conda-build-version: 25.7.0 miniforge-version: latest python-version: ${{ matrix.python }} @@ -360,7 +360,7 @@ jobs: with: activate-environment: test-env channel-priority: strict - channels: defaults + channels: conda-forge,defaults environment-file: slycot-src/.github/conda-env/test-env.yml miniforge-version: latest python-version: ${{ matrix.python }} From 884f929fce30267c5a3a446eccb032d5f1a49bc9 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 7 Sep 2025 17:08:03 +0200 Subject: [PATCH 402/405] Fix Github workflow Conda build and test configs --- .github/workflows/slycot-build-and-test.yml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 08598b5a..8ecc8cf2 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -173,12 +173,11 @@ jobs: - name: Setup Conda uses: conda-incubator/setup-miniconda@v3 with: + python-version: ${{ matrix.python }} activate-environment: build-env - channel-priority: strict - channels: conda-forge,defaults - conda-build-version: 25.7.0 miniforge-version: latest - python-version: ${{ matrix.python }} + conda-build-version: 25.7.0 + channel-priority: strict - name: Conda build shell: bash -el {0} run: | @@ -358,12 +357,13 @@ jobs: - name: Setup Conda uses: conda-incubator/setup-miniconda@v3 with: + python-version: ${{ matrix.python }} + miniforge-version: latest activate-environment: test-env - channel-priority: strict - channels: conda-forge,defaults environment-file: slycot-src/.github/conda-env/test-env.yml - miniforge-version: latest - python-version: ${{ matrix.python }} + channels: conda-forge,defaults + channel-priority: strict + auto-activate-base: false - name: Download conda packages uses: actions/download-artifact@v4 with: From b448edca34327add60184e2d60e1ec6f8b754972 Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 7 Sep 2025 18:33:21 +0200 Subject: [PATCH 403/405] Add missing conda-env test file --- .github/conda-env/test-env.yml | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 .github/conda-env/test-env.yml diff --git a/.github/conda-env/test-env.yml b/.github/conda-env/test-env.yml new file mode 100644 index 00000000..bdc01362 --- /dev/null +++ b/.github/conda-env/test-env.yml @@ -0,0 +1,9 @@ +name: test-env +dependencies: + # in addtion to package dependencies and explicit LAPACK/BLAS implementations installed in workflow + - scipy + - matplotlib + - pytest + - pytest-cov + - pytest-timeout + - coverage From 2c899321171d2807fce0a89fd80374d7ac24c0cb Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 2 Nov 2025 18:32:37 +0200 Subject: [PATCH 404/405] Only run python-control tests with slycot pytest marker in CI --- .github/scripts/run-tests.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/scripts/run-tests.sh b/.github/scripts/run-tests.sh index f9a8b9fa..1091022e 100644 --- a/.github/scripts/run-tests.sh +++ b/.github/scripts/run-tests.sh @@ -16,6 +16,7 @@ donttest="test_root_locus_zoom or test_sisotool" # don't care about deprecation warnings here donttest="$donttest or test_default_deprecation" pytest control/tests \ + -m slycot \ --cov=$slycot_libdir \ --cov-config=${slycot_srcdir}/.coveragerc \ --ignore=control/tests/docstrings_test.py \ From 0498d5262f61a1f7d6b701bf7cde3539ea1b095d Mon Sep 17 00:00:00 2001 From: Rory Yorke Date: Sun, 2 Nov 2025 20:45:20 +0200 Subject: [PATCH 405/405] Set auto-update-conda to true for setup-miniconda Github action --- .github/workflows/slycot-build-and-test.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/slycot-build-and-test.yml b/.github/workflows/slycot-build-and-test.yml index 8ecc8cf2..cdd8fff1 100644 --- a/.github/workflows/slycot-build-and-test.yml +++ b/.github/workflows/slycot-build-and-test.yml @@ -173,6 +173,7 @@ jobs: - name: Setup Conda uses: conda-incubator/setup-miniconda@v3 with: + auto-update-conda: true python-version: ${{ matrix.python }} activate-environment: build-env miniforge-version: latest